Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch core-8-branch Through [34260c9af5] Excluding Merge-Ins
This is equivalent to a diff from dcd24c663d to 34260c9af5
|
2020-06-23
| ||
| 09:33 | Merge 8.6 check-in: 6421e4e7e1 user: jan.nijtmans tags: core-8-branch | |
| 06:36 | Merge-mark check-in: 34260c9af5 user: jan.nijtmans tags: core-8-branch | |
| 06:35 | Backport some changes in tclGetDate.y from 8.7. check-in: 9d38e87ebc user: jan.nijtmans tags: core-8-6-branch | |
| 06:16 | Backport some recent changes in tclDate.c back to tclGetDate.y, so they are not lost when re-generat... check-in: d3e08b882b user: jan.nijtmans tags: core-8-branch | |
|
2019-06-28
| ||
| 12:43 | merge 8.7 check-in: e082413024 user: dgp tags: trunk | |
|
2019-06-27
| ||
| 15:47 | Fix a warning due to a missing const in an internal minzip function Closed-Leaf check-in: 6aab010b03 user: gahr tags: fix-minizip-signature | |
| 13:32 | merge trunk check-in: 5ffd1df2aa user: dgp tags: dgp-properbytearray | |
| 13:32 | merge trunk check-in: 34fe090bc2 user: dgp tags: dgp-refactor | |
| 13:21 | merge trunk check-in: ae06aa5b02 user: dgp tags: novem | |
|
2019-06-26
| ||
| 09:36 | UNEXEC win/tclWinFile.c check-in: dcd24c663d user: jan.nijtmans tags: trunk | |
| 08:34 | Merge 8.7 check-in: 7723dac835 user: jan.nijtmans tags: trunk | |
Changes to .fossil-settings/binary-glob.
1 2 3 4 5 6 7 8 9 | compat/zlib/win32/zdll.lib compat/zlib/win32/zlib1.dll compat/zlib/win64/zdll.lib compat/zlib/win64/zlib1.dll compat/zlib/win64/libz.dll.a compat/zlib/zlib.3.pdf *.bmp *.gif *.png | > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | compat/zlib/win32/zdll.lib compat/zlib/win32/zlib1.dll compat/zlib/win64/zdll.lib compat/zlib/win64/zlib1.dll compat/zlib/win64/libz.dll.a compat/zlib/zlib.3.pdf compat/zlib/win32/zdll.lib compat/zlib/win32/zlib1.dll compat/zlib/win64/zdll.lib compat/zlib/win64/zlib1.dll compat/zlib/win64/libz.dll.a compat/zlib/zlib.3.pdf libtommath/win32/tommath.lib libtommath/win32/libtommath.dll libtommath/win64/tommath.lib libtommath/win64/libtommath.dll libtommath/win64/libtommath.dll.a *.a *.bmp *.dll *.exe *.gif *.gz *.jpg *.lib *.pdf *.png *.xlsx *.zip |
Changes to .fossil-settings/crlf-glob.
1 2 3 4 5 6 7 8 9 10 | compat/zlib/contrib/dotzlib/DotZLib/UnitTests.cs compat/zlib/contrib/vstudio/readme.txt compat/zlib/contrib/vstudio/*/zlib.rc compat/zlib/win32/*.txt compat/zlib/win64/*.txt libtommath/*.dsp libtommath/*.sln libtommath/*.vcproj tools/tcl.hpj.in tools/tcl.wse.in | > | 1 2 3 4 5 6 7 8 9 10 11 | 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.hpj.in tools/tcl.wse.in |
| ︙ | ︙ |
Changes to .fossil-settings/ignore-glob.
1 2 3 4 5 6 7 8 9 10 11 12 13 | *.a *.dll *.dylib *.exe *.exp *.lib *.o *.obj *.pdb *.res *.sl *.so */Makefile | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | *.a *.dll *.dylib *.exe *.exp *.la *.lib *.lo *.o *.obj *.pdb *.res *.sl *.so */Makefile |
| ︙ | ︙ | |||
24 25 26 27 28 29 30 | html libtommath/bn.ilg libtommath/bn.ind libtommath/pretty.build libtommath/tommath.src libtommath/*.log libtommath/*.pdf | | > | 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 | html libtommath/bn.ilg libtommath/bn.ind libtommath/pretty.build libtommath/tommath.src libtommath/*.log libtommath/*.pdf libtommath/gen.pl libtommath/*.sh libtommath/doc/* libtommath/tombc/* libtommath/pre_gen/* libtommath/pics/* libtommath/mtest/* libtommath/logs/* libtommath/etc/* libtommath/demo/* libtommath/*.out libtommath/*.tex unix/autoMkindex.tcl unix/dltest.marker unix/tcl.pc unix/tclIndex unix/pkgs/* win/Debug* win/Release* win/*.manifest win/pkgs/* win/coffbase.txt win/tcl.hpj win/nmhlp-out.txt |
Added .gitattributes.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 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 | # Set the default behavior, in case people don't have core.autocrlf set. * eol=lf * text=auto # Explicitly declare text files you want to always be normalized and converted # to native line endings on checkout. *.3 text *.c text *.css text *.enc text *.h text *.htm text *.html text *.java text *.js text *.json text *.n text *.svg text *.ts text *.tcl text *.test text # 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 *.png binary *.xlsx binary *.zip binary |
Added .gitignore.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 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 | *.a *.dll *.dylib *.exe *.exp *.lib *.o *.obj *.pdb *.res *.sl *.so */Makefile */config.cache */config.log */config.status */config.status.lineno */tclConfig.sh */tclsh* */tcltest* */versions.vc */version.vc */libtcl.vfs */libtcl_*.zip .fslckout _FOSSIL_ html libtommath/bn.ilg libtommath/bn.ind libtommath/pretty.build libtommath/tommath.src libtommath/*.log libtommath/*.pdf libtommath/*.pl libtommath/*.sh libtommath/doc/* libtommath/tombc/* libtommath/pre_gen/* libtommath/pics/* libtommath/mtest/* libtommath/logs/* libtommath/etc/* libtommath/demo/* libtommath/*.out libtommath/*.tex unix/autoMkindex.tcl unix/dltest.marker unix/tcl.pc unix/tclIndex unix/pkgs/* win/Debug* win/Release* win/*.manifest win/pkgs/* win/coffbase.txt win/tcl.hpj win/nmhlp-out.txt |
Changes to .project.
1 2 | <?xml version="1.0" encoding="UTF-8"?> <projectDescription> | | | 1 2 3 4 5 6 7 8 9 10 | <?xml version="1.0" encoding="UTF-8"?> <projectDescription> <name>tcl8</name> <comment></comment> <projects> </projects> <buildSpec> </buildSpec> <natures> </natures> |
| ︙ | ︙ |
Changes to .travis.yml.
1 2 | sudo: false language: c | | > > > > > > > > > > > > > > > | | | > | | | < > > | | > > | | | | < < < < < < < < < < | | | < < < < < < > > | | | < < < < < < > > > | | | < < < < < < > > > | | | | | | | | | | | | > > > > > > > > > > > > > | > | | > > > | | > | < > > | | > | < > > > | | < < > > > > > > | > | | < > > > > > > > | > > | > | > > > > | > > > > > < > < < < < | > | > | < < | | < < > | > > > > | | > > > > > | > > | | > | > > > | > > > > | | | > > | | < < < < | | > | < > > > | | > > > > | | > > | | > > > | < | < > | < > > > > > | > | > | < < > > > > | < | > > | | < < < < < < > > > | > | | < | > > > | > | > | > > > > > > > | > > | | > > > | < | < > > | > > > > | > | > | > > | | | > | > > > > > > > | > > | | > > > > | | < > | > > > | > | > | > | | > | > > > > > | | > > > | | > | < | > | > > > | > | < > > | < | | < > > > > > | | > | > > | | > > > > > | > | > > > > > | > > > > > | > | > > > > > | | < > | | < | < | > | < > < > | > > | < | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 |
sudo: false
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
homebrew:
packages:
- libtommath
update: true
matrix:
include:
# Testing on Linux with various compilers
- name: "Linux/GCC/Shared"
os: linux
dist: bionic
compiler: gcc
env:
- BUILD_DIR=unix
- name: "Linux/GCC/Shared: UTF_MAX=4"
os: linux
dist: bionic
compiler: gcc
env:
- BUILD_DIR=unix
- CFGOPT=CFLAGS=-DTCL_UTF_MAX=4
- name: "Linux/GCC/Shared: NO_DEPRECATED"
os: linux
dist: bionic
compiler: gcc
env:
- BUILD_DIR=unix
- CFGOPT="CFLAGS=-DTCL_NO_DEPRECATED=1"
- name: "Linux/GCC/Static"
os: linux
dist: bionic
compiler: gcc
env:
- CFGOPT="--disable-shared"
- BUILD_DIR=unix
- name: "Linux/GCC/Debug"
os: linux
dist: bionic
compiler: gcc
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols"
- name: "Linux/GCC/Mem-Debug"
os: linux
dist: bionic
compiler: gcc
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols=mem"
# C++ build.
- name: "Linux/G++/Shared"
os: linux
dist: bionic
compiler: g++
env:
- BUILD_DIR=unix
- CFGOPT="CC=g++ CFLAGS=-Dregister=dont+use+register"
# Older versions of GCC...
- name: "Linux/GCC 7/Shared"
os: linux
dist: bionic
compiler: gcc-7
addons:
apt:
sources:
- ubuntu-toolchain-r-test
packages:
- g++-7
env:
- BUILD_DIR=unix
- name: "Linux/GCC 6/Shared"
os: linux
dist: bionic
compiler: gcc-6
addons:
apt:
sources:
- ubuntu-toolchain-r-test
packages:
- g++-6
env:
- BUILD_DIR=unix
- name: "Linux/GCC 5/Shared"
os: linux
dist: bionic
compiler: gcc-5
addons:
apt:
sources:
- ubuntu-toolchain-r-test
packages:
- g++-5
env:
- BUILD_DIR=unix
# Clang
- name: "Linux/Clang/Shared"
os: linux
dist: bionic
compiler: clang
env:
- BUILD_DIR=unix
- name: "Linux/Clang/Shared:NO_DEPRECATED"
os: linux
dist: xenial
compiler: clang
env:
- BUILD_DIR=unix
- CFGOPT="CFLAGS=-DTCL_NO_DEPRECATED=1"
- name: "Linux/Clang/Static"
os: linux
dist: bionic
compiler: clang
env:
- CFGOPT="--disable-shared"
- BUILD_DIR=unix
- name: "Linux/Clang/Debug"
os: linux
dist: bionic
compiler: clang
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols"
- name: "Linux/Clang/Mem-Debug"
os: linux
dist: bionic
compiler: clang
env:
- BUILD_DIR=unix
- CFGOPT="--enable-symbols=mem"
# Testing on Mac, various styles
- name: "macOS/Clang/Xcode 11.5/Shared"
os: osx
osx_image: xcode11.5
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 11.5/Shared/Unix-like"
os: osx
osx_image: xcode11.5
env:
- BUILD_DIR=unix
- name: "macOS/Clang++/Xcode 11.5/Shared"
os: osx
osx_image: xcode11.5
env:
- BUILD_DIR=unix
- CFGOPT="CC=clang++ --enable-framework CFLAGS=-Dregister=dont+use+register CPPFLAGS=-D__private_extern__=extern"
script:
- make all tcltest
# Older MacOS versions
- name: "macOS/Clang/Xcode 11/Shared"
os: osx
osx_image: xcode11
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
addons:
homebrew:
packages:
- libtommath
- name: "macOS/Clang/Xcode 9/Shared"
os: osx
osx_image: xcode9.2
env:
- BUILD_DIR=macosx
install: []
script: *mactest
addons:
homebrew:
packages:
- libtommath
- name: "macOS/Clang/Xcode 8/Shared"
os: osx
osx_image: xcode8.3
env:
- BUILD_DIR=macosx
install: []
script: *mactest
addons:
homebrew:
packages:
- libtommath
# Test with mingw-w64 cross-compile
# Doesn't run tests because wine is only an imperfect Windows emulation
- name: "Linux-cross-Windows/GCC/Shared/no test"
os: linux
dist: bionic
compiler: x86_64-w64-mingw32-gcc
env:
- BUILD_DIR=win
- CFGOPT="--host=x86_64-w64-mingw32 --enable-64bit"
script: &crosstest
- make all tcltest
# Include a high visibility marker that tests are skipped outright
- >
echo "`tput setaf 3`SKIPPED TEST: CROSS COMPILING`tput sgr0`"
# Test with mingw-w64 (32 bit) cross-compile
# Doesn't run tests because wine is only an imperfect Windows emulation
- name: "Linux-cross-Windows-32/GCC/Shared/no test"
os: linux
dist: bionic
compiler: i686-w64-mingw32-gcc
env:
- BUILD_DIR=win
- CFGOPT=--host=i686-w64-mingw32
script: *crosstest
# Test on Windows with MSVC native
- name: "Windows/MSVC/Shared"
os: windows
compiler: cl
env: &vcenv
- BUILD_DIR=win
- VCDIR="/C/Program Files (x86)/Microsoft Visual Studio/2017/BuildTools/VC/Auxiliary/Build"
before_install: &vcpreinst
- 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"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=utfmax' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=utfmax' '-f' makefile.vc test
- name: "Windows/MSVC/Shared: NO_DEPRECATED"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=nodep' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=nodep' '-f' makefile.vc test
- name: "Windows/MSVC/Static"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=static,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:
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=symbols' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'OPTS=symbols' '-f' makefile.vc test
- name: "Windows/MSVC/Mem-Debug"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'STATS=memdbg' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x64 '&&' nmake 'STATS=memdbg' '-f' makefile.vc test
# Test on Windows with MSVC native (32-bit)
- name: "Windows/MSVC-x86/Shared"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x86 '&&' nmake '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x86 '&&' nmake '-f' makefile.vc test
- name: "Windows/MSVC-x86/Shared: UTF_MAX=4"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=utfmax' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=utfmax' '-f' makefile.vc test
- name: "Windows/MSVC-x86/Shared: NO_DEPRECATED"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=nodep' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=nodep' '-f' makefile.vc test
- name: "Windows/MSVC-x86/Static"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=static,msvcrt' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=static,msvcrt' '-f' makefile.vc test
- name: "Windows/MSVC-x86/Debug"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=symbols' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'OPTS=symbols' '-f' makefile.vc test
- name: "Windows/MSVC-x86/Mem-Debug"
os: windows
compiler: cl
env: *vcenv
before_install: *vcpreinst
install: []
script:
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'STATS=memdbg' '-f' makefile.vc all tcltest
- cmd.exe //C vcvarsall.bat x86 '&&' nmake 'STATS=memdbg' '-f' makefile.vc test
# Test on Windows with GCC native
- name: "Windows/GCC/Shared"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit"
before_install: &makepreinst
- choco install -y make zip
- cd ${BUILD_DIR}
- name: "Windows/GCC/Shared: UTF_MAX=4"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit CFLAGS=-DTCL_UTF_MAX=4"
before_install: *makepreinst
- name: "Windows/GCC/Shared: NO_DEPRECATED"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit CFLAGS=-DTCL_NO_DEPRECATED=1"
before_install: *makepreinst
- name: "Windows/G++/Shared"
os: windows
compiler: g++
env:
- BUILD_DIR=win
- CFGOPT="CC=g++ --enable-64bit"
before_install: *makepreinst
script:
- make all tcltest
- name: "Windows/GCC/Static"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit --disable-shared"
before_install: *makepreinst
- name: "Windows/GCC/Debug"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit --enable-symbols"
before_install: *makepreinst
- name: "Windows/GCC/Mem-Debug"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-64bit --enable-symbols=mem"
before_install: *makepreinst
# Test on Windows with GCC native (32-bit)
- name: "Windows/GCC-x86/Shared"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
before_install: *makepreinst
- name: "Windows/GCC-x86/Shared: UTF_MAX=4"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="CFLAGS=-DTCL_UTF_MAX=4"
before_install: *makepreinst
- name: "Windows/GCC-x86/Shared: NO_DEPRECATED"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="CFLAGS=-DTCL_NO_DEPRECATED=1"
before_install: *makepreinst
- name: "Windows/G++-x86/Shared"
os: windows
compiler: g++
env:
- BUILD_DIR=win
- CFGOPT="CC=g++"
before_install: *makepreinst
script:
- make all tcltest
- name: "Windows/GCC-x86/Static"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--disable-shared"
before_install: *makepreinst
- name: "Windows/GCC-x86/Debug"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-symbols"
before_install: *makepreinst
- name: "Windows/GCC-x86/Mem-Debug"
os: windows
compiler: gcc
env:
- BUILD_DIR=win
- CFGOPT="--enable-symbols=mem"
before_install: *makepreinst
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:
- make all tcltest
- make test
- make install
|
Changes to ChangeLog.
| ︙ | ︙ | |||
1843 1844 1845 1846 1847 1848 1849 | copying an object, make sure that the configuration of the variable resolver is also duplicated. 2012-01-22 Jan Nijtmans <nijtmans@users.sf.net> * tools/uniClass.tcl: [FRQ 3473670]: Various Unicode-related * tools/uniParse.tcl: speedups/robustness. Enhanced tools to be | | | 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 | copying an object, make sure that the configuration of the variable resolver is also duplicated. 2012-01-22 Jan Nijtmans <nijtmans@users.sf.net> * tools/uniClass.tcl: [FRQ 3473670]: Various Unicode-related * tools/uniParse.tcl: speedups/robustness. Enhanced tools to be * generic/tclUniData.c: able to handle characters > 0xFFFF. Done in * generic/tclUtf.c: all branches in order to simplify merges for * generic/regc_locale.c: new Unicode versions (such as 6.1) 2012-01-22 Donal K. Fellows <dkf@users.sf.net> * generic/tclDictObj.c (DictExistsCmd): [Bug 3475264]: Ensure that errors only ever happen when insufficient arguments are supplied, and |
| ︙ | ︙ |
Changes to ChangeLog.2000.
| ︙ | ︙ | |||
1775 1776 1777 1778 1779 1780 1781 | * tests/regexp.test: Added tests for infinite looping in [regexp -all]. * generic/tclCmdMZ.c: Fixed infinite loop bug with [regexp -all] [Bug: 4981]. | | | 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 | * tests/regexp.test: Added tests for infinite looping in [regexp -all]. * generic/tclCmdMZ.c: Fixed infinite loop bug with [regexp -all] [Bug: 4981]. * tests/*.test: Changed all occurrences of "namespace import ::tcltest" to "namespace import -force ::tcltest" [Bug: 3948]. 2000-04-09 Brent Welch <welch@scriptics.com> * lib/httpd2.1/http.tcl: Worked on the "server closes before reading post data" case, which unfortunately causes different error cases on Solaris, which can read the reply, and Linux and Windows, which cannot |
| ︙ | ︙ |
Changes to ChangeLog.2005.
| ︙ | ︙ | |||
2909 2910 2911 2912 2913 2914 2915 | * generic/tclInt.h (TclGetTruthValueFromObj): New routine. * generic/tclExecute.c: Updated callers to call new routine. * generic/tclBasic.c: Updated callers to call new routine. * generic/tclCompCmds.c: Updated callers to call new routine. * generic/tclDictObj.c: Updated callers to call new routine. * tests/obj.test: Corrected bad tests that actually expected | | | 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 | * generic/tclInt.h (TclGetTruthValueFromObj): New routine. * generic/tclExecute.c: Updated callers to call new routine. * generic/tclBasic.c: Updated callers to call new routine. * generic/tclCompCmds.c: Updated callers to call new routine. * generic/tclDictObj.c: Updated callers to call new routine. * tests/obj.test: Corrected bad tests that actually expected values like "47" and "0xAC" to be accepted as booleans. * generic/tclLiteral.c: Disabled the code that forces some literals into the "int" Tcl_ObjType during registration. We can re-enable it if this change causes trouble, but it seems more sensible to let Tcl's "on-demand" shimmering rule, and not try to pre-guess things. 2005-04-20 Kevin B. Kenny <kennykb@acm.org> |
| ︙ | ︙ |
Changes to README.md.
1 2 | # README: Tcl | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | # 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://travis-ci.org/tcltk/tcl) ## Contents 1. [Introduction](#intro) 2. [Documentation](#doc) 3. [Compiling and installing Tcl](#build) 4. [Development tools](#devtools) 5. [Tcl newsgroup](#complangtcl) |
| ︙ | ︙ | |||
39 40 41 42 43 44 45 | 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 at our website. The home page for this release, including new features, is | | | | | 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 | 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 at 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 Xchange](https://www.tcl-lang.org/about/). There have been many Tcl books on the market. Many are mentioned in [the Wiki](https://wiki.tcl-lang.org/_/ref?N=25206). The complete set of reference manual entries for Tcl 8.7 is [online, here](https://www.tcl-lang.org/man/tcl8.7/). ### <a id="doc.unix">2a.</a> Unix Documentation The `doc` subdirectory in this release contains a complete set of reference manual entries for Tcl. Files with extension "`.1`" are for programs (for example, `tclsh.1`); files with extension "`.3`" are for C library procedures; and files with extension "`.n`" describe Tcl commands. The file "`doc/Tcl.n`" gives a quick summary of the Tcl |
| ︙ | ︙ |
Changes to changes.
| ︙ | ︙ | |||
2303 2304 2305 2306 2307 2308 2309 | existing files. (JH) 9/6/96 (bug fix) If standard channel is NULL, because Tcl cannot connect to the standard channel, do not increment the refcount. The channel can be NULL if there is for example no standard input. (JL) 9/6/96 (portability improvement) Changed parsing of backslash sequences | | | 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 | existing files. (JH) 9/6/96 (bug fix) If standard channel is NULL, because Tcl cannot connect to the standard channel, do not increment the refcount. The channel can be NULL if there is for example no standard input. (JL) 9/6/96 (portability improvement) Changed parsing of backslash sequences like \n to translate directly to absolute values like 0xA instead of letting the compiler do the translation. This guarantees that the translation is done the same everywhere. (JO) 9/9/96 (bug fix) If channel is opened and not associated with any interpreter, but Tcl decides to use it as one of the standard channels, it became impossible to close the channel with Tcl_Close -- instead you had to call Tcl_UnregisterChannel. Fixed now so that it's safe to call |
| ︙ | ︙ | |||
8299 8300 8301 8302 8303 8304 8305 | 2013-09-19 (bug fix)[3487626] segfaults in [dict] compilers (porter) 2013-09-19 (bug fix)[31661d2] mem leak in [lreplace] (ade,porter) Many optmizations, improvements, and tightened stack management in bytecode. | | | 8299 8300 8301 8302 8303 8304 8305 8306 8307 8308 8309 8310 8311 8312 8313 |
2013-09-19 (bug fix)[3487626] segfaults in [dict] compilers (porter)
2013-09-19 (bug fix)[31661d2] mem leak in [lreplace] (ade,porter)
Many optmizations, improvements, and tightened stack management in bytecode.
--- Released 8.6.1, September 20, 2013 --- https://core.tcl-lang.org/tcl/ for details
2013-09-27 (enhancement) improved ::env synchronization (fellows)
2013-10-20 (bug fix)[2835313] segfault from
[apply {{} {while 1 {a {*}[return -level 0 -code continue]}}}] (fellows)
2013-10-22 (bug fix)[3556215] [scan %E%G%X] support (fellows)
|
| ︙ | ︙ | |||
8447 8448 8449 8450 8451 8452 8453 | 2014-08-12 tzdata updated to Olson's tzdata2014f (kenny) 2014-08-17 (bug fix)[7d52e11] [info class subclasses oo::object] should include ::oo::class (fellows) 2014-08-25 (TIP 429) New command [string cat] (leitgeb,ferrieux) | | | 8447 8448 8449 8450 8451 8452 8453 8454 8455 8456 8457 8458 8459 8460 8461 |
2014-08-12 tzdata updated to Olson's tzdata2014f (kenny)
2014-08-17 (bug fix)[7d52e11] [info class subclasses oo::object] should
include ::oo::class (fellows)
2014-08-25 (TIP 429) New command [string cat] (leitgeb,ferrieux)
--- Released 8.6.2, August 27, 2014 --- https://core.tcl-lang.org/tcl/ for details
2014-08-28 (bug)[b9e1a3] Correct Method Search Order (nadkarni,fellows)
=> TclOO 1.0.3
*** POTENTIAL INCOMPATIBILITY ***
2014-09-05 (bug)[ccc2c2] Regression [lreplace {} 1 1] (bron,fellows)
|
| ︙ | ︙ | |||
8487 8488 8489 8490 8491 8492 8493 | 2014-10-31 (bug)[dcc034] restore [open comX: r+] (lll,nijtmans) 2014-11-05 (bug)[214cc0] Restore [lappend v] return value (sayers,porter) 2014-11-06 (bug)[5adc35] Stop forcing EOF to be permanent (porter) | | | 8487 8488 8489 8490 8491 8492 8493 8494 8495 8496 8497 8498 8499 8500 8501 | 2014-10-31 (bug)[dcc034] restore [open comX: r+] (lll,nijtmans) 2014-11-05 (bug)[214cc0] Restore [lappend v] return value (sayers,porter) 2014-11-06 (bug)[5adc35] Stop forcing EOF to be permanent (porter) --- Released 8.6.3, November 12, 2014 --- https://core.tcl-lang.org/tcl/ for details 2014-11-21 (bug)[743338] Win: socket error encoding (ladayaroslav,nijtmans) 2014-12-01 (bug) restore tbcload/tclcompiler support (kupries) 2014-12-03 (bug)[0c043a] Fix compiled [set var($) val] (porter) |
| ︙ | ︙ | |||
8523 8524 8525 8526 8527 8528 8529 |
2015-02-11 tzdata updated to Olson's tzdata2015a (venkat)
2015-02-20 (bug)[32b615] Fix compiled [lreplace] (lreplace-4.[345]) (aspect)
2015-03-10 (enhancement) Revise OS X notifier for better Cocoa (walzer)
*** POTENTIAL INCOMPATIBILITY ***
| | | 8523 8524 8525 8526 8527 8528 8529 8530 8531 8532 8533 8534 8535 8536 8537 |
2015-02-11 tzdata updated to Olson's tzdata2015a (venkat)
2015-02-20 (bug)[32b615] Fix compiled [lreplace] (lreplace-4.[345]) (aspect)
2015-03-10 (enhancement) Revise OS X notifier for better Cocoa (walzer)
*** POTENTIAL INCOMPATIBILITY ***
--- Released 8.6.4, March 12, 2015 --- https://core.tcl-lang.org/tcl/ for details
2015-03-19 (bug)[e66e44] Win: Ctrl-C/Ctrl-Break in console not EOF (nadkarni)
2015-03-21 (bug)[d87cb1] Proper tailcall from compiled ensembles (sofer)
2015-04-23 (bug)[19ea02] Win: shared read from linked dirs (bogdan,oehhar)
|
| ︙ | ︙ | |||
8619 8620 8621 8622 8623 8624 8625 | 2016-02-03 (bug)[25842c] stream [zlib deflate] fails with 0 input (ade,fellows) 2016-02-04 (bug)[3d96b7][593baa][cf74de] crashes in OO teardown (porter,fellows) 2016-02-22 (bug)[9b4702] [info exists env(missing)] kills trace (nijtmans) | | | 8619 8620 8621 8622 8623 8624 8625 8626 8627 8628 8629 8630 8631 8632 8633 | 2016-02-03 (bug)[25842c] stream [zlib deflate] fails with 0 input (ade,fellows) 2016-02-04 (bug)[3d96b7][593baa][cf74de] crashes in OO teardown (porter,fellows) 2016-02-22 (bug)[9b4702] [info exists env(missing)] kills trace (nijtmans) --- Released 8.6.5, February 29, 2016 --- https://core.tcl-lang.org/tcl/ for details 2016-03-01 (bug)[803042] mem leak due to reference cycle (porter) 2016-03-08 (bug)[bbc304] reflected watch race condition (porter) 2016-03-17 (bug)[fadc99] compile-5.3 (rodriguez,porter) |
| ︙ | ︙ | |||
8693 8694 8695 8696 8697 8698 8699 |
2016-07-09 (bug)[1493a4] [namespace upvar] use of resolvers (beric,fellows)
*** POTENTIAL INCOMPATIBILITY ***
2016-07-10 (bug)[da340d] integer division in clock math (nadkarni)
2016-07-20 tzdata updated to Olson's tzdata2016f (venkat)
| | | 8693 8694 8695 8696 8697 8698 8699 8700 8701 8702 8703 8704 8705 8706 8707 |
2016-07-09 (bug)[1493a4] [namespace upvar] use of resolvers (beric,fellows)
*** POTENTIAL INCOMPATIBILITY ***
2016-07-10 (bug)[da340d] integer division in clock math (nadkarni)
2016-07-20 tzdata updated to Olson's tzdata2016f (venkat)
--- Released 8.6.6, July 27, 2016 --- https://core.tcl-lang.org/tcl/ for details
2016-09-07 (bug)[c09edf] Bad caching with custom resolver (neumann,nijtmans)
2016-09-07 (bug)[4dbdd9] Memleak in test var-8.3 (mr_calvin,porter)
2016-10-03 (bug)[2bf561] Allow empty command as alias target (yorick,nijtmans)
*** POTENTIAL INCOMPATIBILITY ***
|
| ︙ | ︙ | |||
8790 8791 8792 8793 8794 8795 8796 | 2017-06-26 (bug)[46f801] Repair autoloader fragility (porter) 2017-07-06 (bug)[adb198] Plug memleak in TclJoinPath (sebres,porter) 2017-07-17 (bug)[fb2208] Repeatable tclIndex generation (wiedemann,nijtmans) | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 8790 8791 8792 8793 8794 8795 8796 8797 8798 8799 8800 8801 8802 8803 8804 8805 8806 8807 8808 8809 8810 8811 8812 8813 8814 8815 8816 8817 8818 8819 8820 8821 8822 8823 8824 8825 8826 8827 8828 8829 8830 8831 8832 8833 8834 8835 8836 8837 8838 8839 8840 8841 8842 8843 8844 8845 8846 8847 8848 8849 8850 8851 8852 8853 |
2017-06-26 (bug)[46f801] Repair autoloader fragility (porter)
2017-07-06 (bug)[adb198] Plug memleak in TclJoinPath (sebres,porter)
2017-07-17 (bug)[fb2208] Repeatable tclIndex generation (wiedemann,nijtmans)
--- Released 8.6.7, August 9, 2017 --- https://core.tcl-lang.org/tcl/ for details
Changes to 8.7a1 include all changes to the 8.6 line through 8.6.7,
plus the following, which focuses on the high-level feature changes
in this changeset (new minor version) rather than bug fixes:
2016-03-17 (bug)[0b8c38] socket accept callbacks always in global ns (porter)
*** POTENTIAL INCOMPATIBILITY ***
2016-07-01 Hack accommodations for legacy Itcl 3 disabled (porter)
2016-07-12 Make TCL_HASH_TYPE build-time configurable (nijtmans)
2016-07-19 (bug)[0363f0] Partial array search ID reform (porter)
2016-07-19 (feature removed) Tcl_ObjType "array search" unregistered (porter)
*** POTENTIAL INCOMPATIBILITY for Tcl_GetObjType("array search") ***
2016-10-04 Server socket on port 0 chooses port supporting IPv4 * IPv6 (max)
2016-11-25 [array names -regexp] supports backrefs (goth)
2017-01-04 (TIP 456) New routine Tcl_OpenTcpServerEx() (limeboy)
2017-01-04 (TIP 459) New subcommand [package files] (nijtmans)
2017-01-16 threaded allocator initialization repair (vasiljevic,nijtmans)
2017-01-30 Add to Win shell builtins: assoc ftype move (ashok)
2017-03-31 TCL_MEM_DEBUG facilities better support 64-bit memory (nijtmans)
2017-04-13 \u escaped content in msg files converted to true utf-8 (nijtmans)
2017-05-18 (TIP 458) New epoll or kqueue notifiers are default (alborboz)
2017-05-31 Purge build support for SunOS-4.* (stu)
2017-06-22 (TIP 463) New option [regsub ... -command ...] (fellows)
2017-06-22 (TIP 470) Tcl_GetDefineContextObject();[oo::define [self]] (fellows)
=> TclOO 1.2.0
2017-06-23 (TIP 472) Support 0d as prefix of decimal numbers (iyer,griffin)
2017-08-31 (bug)[2a9465] http state 100 continue handling broken (oehlmann)
2017-09-02 (bug)[0e4d88] replace command, delete trace kills namespace (porter)
--- Released 8.7a1, September 8, 2017 --- http://core.tcl.tk/tcl/ for details
2017-08-10 [array names -regexp] supports backrefs (goth)
2017-08-10 Fix gcc build failures due to #pragma placement (cassoff,fellows)
2017-08-29 (bug)[b50fb2] exec redir append stdout and stderr to file (coulter)
|
| ︙ | ︙ | |||
8825 8826 8827 8828 8829 8830 8831 | 2017-12-06 (bug)[ce3a21] file normalize failure when tail is empty (porter) 2017-12-08 (new)[TIP 477] nmake build system reform (nadkarni) 2017-12-19 (bug)[586e71] EvalObjv exception handling at level #0 (sebres,porter) | | | 8874 8875 8876 8877 8878 8879 8880 8881 8882 8883 8884 8885 8886 8887 8888 | 2017-12-06 (bug)[ce3a21] file normalize failure when tail is empty (porter) 2017-12-08 (new)[TIP 477] nmake build system reform (nadkarni) 2017-12-19 (bug)[586e71] EvalObjv exception handling at level #0 (sebres,porter) --- Released 8.6.8, December 22, 2017 --- https://core.tcl-lang.org/tcl/ for details 2018-02-11 (enhance) stop blocking conversion of object to/from class (coulter) 2018-02-12 (enhance) NR-enable [package require] (coulter) 2018-02-14 (bug)[9fd5c6] crash in object deletion, test oo-11.5 (coulter) |
| ︙ | ︙ | |||
8891 8892 8893 8894 8895 8896 8897 | 2018-11-09 (bug)[35a8f1] overlong string length of some lists (owens) 2018-11-16 (bug)[00d04c] Repair [binary encode base64] (sebres) - Released 8.6.9, November 16, 2018 - details at http://core.tcl-lang.org/tcl/ - | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | < | < | < < < | < | < > | < | < > < | < | < < > < < > < > < > | < > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 8940 8941 8942 8943 8944 8945 8946 8947 8948 8949 8950 8951 8952 8953 8954 8955 8956 8957 8958 8959 8960 8961 8962 8963 8964 8965 8966 8967 8968 8969 8970 8971 8972 8973 8974 8975 8976 8977 8978 8979 8980 8981 8982 8983 8984 8985 8986 8987 8988 8989 8990 8991 8992 8993 8994 8995 8996 8997 8998 8999 9000 9001 9002 9003 9004 9005 9006 9007 9008 9009 9010 9011 9012 9013 9014 9015 9016 9017 9018 9019 9020 9021 9022 9023 9024 9025 9026 9027 9028 9029 9030 9031 9032 9033 9034 9035 9036 9037 9038 9039 9040 9041 9042 9043 9044 9045 9046 9047 9048 9049 9050 9051 9052 9053 9054 9055 9056 9057 9058 9059 9060 9061 9062 9063 9064 9065 9066 9067 9068 9069 9070 9071 9072 9073 9074 9075 9076 9077 9078 9079 9080 9081 9082 9083 9084 9085 9086 9087 9088 9089 9090 9091 9092 9093 9094 9095 9096 9097 9098 9099 9100 9101 9102 9103 9104 9105 9106 9107 9108 9109 9110 9111 9112 9113 9114 9115 9116 9117 9118 9119 9120 9121 9122 |
2018-11-09 (bug)[35a8f1] overlong string length of some lists (owens)
2018-11-16 (bug)[00d04c] Repair [binary encode base64] (sebres)
- Released 8.6.9, November 16, 2018 - details at http://core.tcl-lang.org/tcl/ -
2018-11-22 (bug)[7a9dc5] [file normalize ~/~foo] segfault (sebres)
2018-12-30 (bug)[3cf3a9] variable 'timezone' deprecated in vc2017 (nijtmans)
2019-01-09 (bug)[cc1e91] [list [list {*}[set a " "]]] regression (sebres)
2019-02-01 (bug)[e3f481] tests var-1.2[01] (sebres)
2019-03-01 (new) Update to Unicode 12.0 (nijtmans)
2019-03-05 (new)[TIP 527] New command [timerate] (sebres)
2019-03-08 (bug)[39fed4] [package require] memory validity (hume,porter)
2019-04-23 (new) New command tcl::unsupported::corotype (fellows)
2019-05-04 (bug) memlink when namespace deletion kills linked var (porter)
2019-05-28 (new) README file converted to README.md in Markdown (nijtmans)
2019-06-17 (bug)[8b9854] [info level 0] regression with ensembles (porter)
2019-06-20 (bug)[6bdadf] crash multi-arg write-traced [lappend] (fellows,porter)
2019-06-21 (bug)[f8a33c] crash Tcl_Exit before init (brooks,sebres)
2019-08-27 (bug)[fa6bf3] Bytecode fails epoch recovery at numLevel=0 (sebres)
2019-08-29 (bug)[fec0c1] C stack overflow compiling bytecode (ade,sebres)
2019-09-12 tzdata updated to Olson's tzdata2019c (jima)
2019-09-20 (new) registry/dde no longer need -DUNICODE (nijtmans)
=> registry 1.3.4
=> dde 1.4.2
2019-10-02 (bug)[16768d] Fix [info hostname] on NetBSD (rytaro)
2019-10-23 (new) libtommath updated to release 1.2.0 (nijtmans)
2019-10-25 OSX: system Tcl deprecated. End default use of its packages. (walzer)
2019-10-28 (bug)[bcd100] bad fs cache when system encoding changes (coulter)
2019-11-15 (bug)[135804] segfault in [next] after destroy (coulter,sebres)
- Released 8.6.10, Nov 21, 2019 - details at http://core.tcl-lang.org/tcl/ -
Changes to 8.7a3 include all changes to the 8.6 line through 8.6.10,
plus the following, which focuses on the high-level feature changes
in this changeset (new minor version) rather than bug fixes:
2017-11-01 (bug)[3c32a3] crash deleting class mixed into instance (coulter)
2017-11-03 [TIP 345] eliminate the encoding 'identity' (porter)
2017-11-04 (bug)[0d902e] [string first] on ASCII stored as Unicode (fellows)
2017-11-17 [TIP 422] Mark all Tcl_*VA() routines deprecated. (nijtmans)
2017-11-20 (support) Ended use of the obsolete values.h header (culler)
2017-11-30 (bug)[8e1e31] [lsort] ordering of U+0000 (nijtmans)
2017-12-07 [TIP 487] Terminate support for pre-XP Windows (nijtmans)
2017-12-08 [TIP 477] Reform of nmake build (nadkarni)
2017-12-20 (bug)[ba1419] Crash: complex ensemble delete, namespace-7.8 (coulter)
2018-01-17 [TIP 485] Removal of many deprecated features (nijtmans)
2018-01-27 (bug) Crash in [join $l $l], join-4.1 (porter)
2018-02-06 [TIP 493] Cease Distribution of http 1.0 (porter)
2018-02-06 [TIP 484] internal rep for native ints are all 64-bit (nijtmans)
2018-02-14 [TIP 476] Scan/Printf consistency (nijtmans)
2018-03-05 [TIP 351] [lsearch] striding
2018-03-05 [TIPs 330,336] tighten access to Interp fields (porter)
2018-03-12 [TIP 462] [::tcl::process]
2018-03-12 [TIP 490] add oo support for msgcat => msgcat 1.7.0 (oehlmann)
2018-03-12 [TIP 499] custom locale preference list (oehlmann)
=> msgcat 1.7.0
2018-03-20 [TIP 503] End CONST84 support for Tcl 8.3 (porter)
2018-03-30 Refactored [lrange] (spjuth)
2018-04-20 [TIP 389] Unicode beyond BMP (nijtmans)
2018-04-20 [TIP 421] [array for]
2018-05-11 [TIP 425] Windows panic callback use of UTF-8
2018-05-17 [TIP 491] Phase out --disable-threads support
2018-06-03 [TIP 500] TclOO Private Methods and Variables
2018-07-26 (bug)[ba921a] [string cat] of bytearrays (coulter,porter)
2018-09-02 [TIP 478] Many new features in TclOO (lester,fellows)
2018-09-04 (bug)[540bed] [binary format w] from bignum (nijtmans)
2018-09-12 [TIP 430] zipfs and embedded script library (woods)
2018-09-26 [TIP 508] [array default] (bonnet,fellows)
2018-09-27 [TIP 515] level value reform (nijtmans)
2018-09-27 [TIP 516] More OO slot operations (fellows)
2018-09-27 [TIP 426] [info cmdtype] (fellows)
2018-09-28 [TIP 509] Cross platform reentrant mutex
2018-10-08 [TIP 514] native integers are 64-bit
2018-10-12 [TIP 502] index value reform (porter)
2018-11-06 [TIP 406] http cookies (fellows)
2018-11-06 [TIP 445] Tcl_ObjType utilities (migrate to Tcl 9) (porter)
2018-11-06 [TIP 501] [string is dict]
2018-11-06 [TIP 519] inline export/unexport option for [oo::define]
2018-11-06 [TIP 523] [lpop]
2018-11-06 [TIP 524] TclOO custom dialects
2018-11-06 [TIP 506] Tcl_(Incr|Decr)RefCount macros -> functions (porter)
2018-11-15 [TIP 512] No stub for Tcl_SetExitProc()
2019-04-08 (bug)[45b9fa] crash in [try] (coulter)
2019-04-14 [TIP 160] terminal and serial channel controls
2019-04-14 [TIP 312] more types for Tcl_LinkVar
2019-04-14 [TIP 367] [lremove]
2019-04-14 [TIP 504] [string insert]
2019-04-16 [TIP 342] [dict getwithdefault]
2019-05-25 [TIP 431] [file tempdir]
2019-05-25 [TIP 383] [coroinject], [coroprobe]
2019-05-31 [TIP 544] Tcl_GetIntForIndex()
2019-06-12 Replace TclOffset() with offsetof()
2019-06-15 [TIP 461] string compare operators for [expr]
2019-06-16 [TIP 521] floating point classification functions for [expr]
2019-06-20 (bug)[6bdadf] crash multi-arg traced [lappend] (fellows)
2019-06-28 [TIP 547] New encodings utf-16, ucs-2
2019-09-14 [TIP 414] Tcl_InitSubsystems()
2019-09-14 [TIP 548] wchar_t conversion functions
- Released 8.7a3, Nov 21, 2019 --- http://core.tcl-lang.org/tcl/ for details -
|
Changes to compat/fake-rfc2553.c.
| ︙ | ︙ | |||
69 70 71 72 73 74 75 76 77 78 79 80 81 82 |
int fake_getnameinfo(const struct sockaddr *sa, size_t salen, char *host,
size_t hostlen, char *serv, size_t servlen, int flags)
{
struct sockaddr_in *sin = (struct sockaddr_in *)sa;
struct hostent *hp;
char tmpserv[16];
if (sa->sa_family != AF_UNSPEC && sa->sa_family != AF_INET)
return (EAI_FAMILY);
if (serv != NULL) {
snprintf(tmpserv, sizeof(tmpserv), "%d", ntohs(sin->sin_port));
if (strlcpy(serv, tmpserv, servlen) >= servlen)
return (EAI_MEMORY);
| > | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 |
int fake_getnameinfo(const struct sockaddr *sa, size_t salen, char *host,
size_t hostlen, char *serv, size_t servlen, int flags)
{
struct sockaddr_in *sin = (struct sockaddr_in *)sa;
struct hostent *hp;
char tmpserv[16];
(void)salen;
if (sa->sa_family != AF_UNSPEC && sa->sa_family != AF_INET)
return (EAI_FAMILY);
if (serv != NULL) {
snprintf(tmpserv, sizeof(tmpserv), "%d", ntohs(sin->sin_port));
if (strlcpy(serv, tmpserv, servlen) >= servlen)
return (EAI_MEMORY);
|
| ︙ | ︙ | |||
149 150 151 152 153 154 155 |
#ifndef HAVE_GETADDRINFO
static struct
addrinfo *malloc_ai(int port, u_long addr, const struct addrinfo *hints)
{
struct addrinfo *ai;
| | | 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 |
#ifndef HAVE_GETADDRINFO
static struct
addrinfo *malloc_ai(int port, u_long addr, const struct addrinfo *hints)
{
struct addrinfo *ai;
ai = (struct addrinfo *)malloc(sizeof(*ai) + sizeof(struct sockaddr_in));
if (ai == NULL)
return (NULL);
memset(ai, '\0', sizeof(*ai) + sizeof(struct sockaddr_in));
ai->ai_addr = (struct sockaddr *)(ai + 1);
/* XXX -- ssh doesn't use sa_len */
|
| ︙ | ︙ | |||
213 214 215 216 217 218 219 |
*res = malloc_ai(port, addr, hints);
if (*res == NULL)
return (EAI_MEMORY);
return (0);
}
if (!hostname) {
| | | 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 |
*res = malloc_ai(port, addr, hints);
if (*res == NULL)
return (EAI_MEMORY);
return (0);
}
if (!hostname) {
*res = malloc_ai(port, htonl(0x7F000001), hints);
if (*res == NULL)
return (EAI_MEMORY);
return (0);
}
if (inet_aton(hostname, &in)) {
*res = malloc_ai(port, in.s_addr, hints);
|
| ︙ | ︙ |
Changes to compat/gettod.c.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 24 25 26 |
int
gettimeofday(
struct timeval *tp,
struct timezone *tz)
{
struct timeb t;
ftime(&t);
tp->tv_sec = t.time;
| > | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
int
gettimeofday(
struct timeval *tp,
struct timezone *tz)
{
struct timeb t;
(void)tz;
ftime(&t);
tp->tv_sec = t.time;
tp->tv_usec = t.millitm * 1000;
return 0;
}
|
Changes to compat/mkstemp.c.
| ︙ | ︙ | |||
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, and for a DISCLAIMER OF ALL WARRANTIES. */ #include <errno.h> #include <fcntl.h> #include <stdlib.h> #include <unistd.h> /* *---------------------------------------------------------------------- * * mkstemp -- * * Create an open temporary file from a template. * * Results: * A file descriptor, or -1 (with errno set) in the case of an error. * * Side effects: * The template is updated to contain the real filename. * *---------------------------------------------------------------------- */ int mkstemp( | > | | | | | | 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 |
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include <errno.h>
#include <fcntl.h>
#include <stdlib.h>
#include <unistd.h>
#include <string.h>
/*
*----------------------------------------------------------------------
*
* mkstemp --
*
* Create an open temporary file from a template.
*
* Results:
* A file descriptor, or -1 (with errno set) in the case of an error.
*
* Side effects:
* The template is updated to contain the real filename.
*
*----------------------------------------------------------------------
*/
int
mkstemp(
char *tmpl) /* Template for filename. */
{
static const char alphanumerics[] =
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789";
char *a, *b;
int fd, count, alphanumericsLen = strlen(alphanumerics); /* == 62 */
a = tmpl + strlen(tmpl);
while (a > tmpl && *(a-1) == 'X') {
a--;
}
if (a == tmpl) {
errno = ENOENT;
return -1;
}
/*
* We'll only try up to 10 times; after that, we're suffering from enemy
* action and should let the caller know.
|
| ︙ | ︙ | |||
67 68 69 70 71 72 73 | *b = alphanumerics[(int)(r * alphanumericsLen)]; } /* * Template is now realized; try to open (with correct options). */ | | | 68 69 70 71 72 73 74 75 76 77 78 79 |
*b = alphanumerics[(int)(r * alphanumericsLen)];
}
/*
* Template is now realized; try to open (with correct options).
*/
fd = open(tmpl, O_RDWR|O_CREAT|O_EXCL, 0600);
} while (fd == -1 && errno == EEXIST && --count > 0);
return fd;
}
|
Changes to compat/opendir.c.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 |
* open a directory.
*/
DIR *
opendir(
char *name)
{
| | | | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
* open a directory.
*/
DIR *
opendir(
char *name)
{
DIR *dirp;
int fd;
const char *myname;
myname = ((*name == '\0') ? "." : name);
if ((fd = open(myname, 0, 0)) == -1) {
return NULL;
}
dirp = (DIR *) ckalloc(sizeof(DIR));
if (dirp == NULL) {
/* unreachable? */
close(fd);
return NULL;
}
dirp->dd_fd = fd;
dirp->dd_loc = 0;
|
| ︙ | ︙ | |||
61 62 63 64 65 66 67 | /* * get next entry in a directory. */ struct dirent * readdir( | | | | 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 |
/*
* get next entry in a directory.
*/
struct dirent *
readdir(
DIR *dirp)
{
struct olddirect *dp;
static struct dirent dir;
for (;;) {
if (dirp->dd_loc == 0) {
dirp->dd_size = read(dirp->dd_fd, dirp->dd_buf, DIRBLKSIZ);
if (dirp->dd_size <= 0) {
return NULL;
|
| ︙ | ︙ | |||
97 98 99 100 101 102 103 | /* * close a directory. */ void closedir( | | | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
/*
* close a directory.
*/
void
closedir(
DIR *dirp)
{
close(dirp->dd_fd);
dirp->dd_fd = -1;
dirp->dd_loc = 0;
ckfree(dirp);
}
|
Added compat/stdint.h.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 |
/* A portable stdint.h
****************************************************************************
* BSD License:
****************************************************************************
*
* Copyright (c) 2005-2016 Paul Hsieh
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions
* are met:
*
* 1. Redistributions of source code must retain the above copyright
* notice, this list of conditions and the following disclaimer.
* 2. Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
* 3. The name of the author may not be used to endorse or promote products
* derived from this software without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
* IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
* OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
* IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
* INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
* NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
* THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
* (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
* THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
****************************************************************************
*
* Version 0.1.16.0
*
* The ANSI C standard committee, for the C99 standard, specified the
* inclusion of a new standard include file called stdint.h. This is
* a very useful and long desired include file which contains several
* very precise definitions for integer scalar types that is critically
* important for making several classes of applications portable
* including cryptography, hashing, variable length integer libraries
* and so on. But for most developers its likely useful just for
* programming sanity.
*
* The problem is that some compiler vendors chose to ignore the C99
* standard and some older compilers have no opportunity to be updated.
* Because of this situation, simply including stdint.h in your code
* makes it unportable.
*
* So that's what this file is all about. It's an attempt to build a
* single universal include file that works on as many platforms as
* possible to deliver what stdint.h is supposed to. Even compilers
* that already come with stdint.h can use this file instead without
* any loss of functionality. A few things that should be noted about
* this file:
*
* 1) It is not guaranteed to be portable and/or present an identical
* interface on all platforms. The extreme variability of the
* ANSI C standard makes this an impossibility right from the
* very get go. Its really only meant to be useful for the vast
* majority of platforms that possess the capability of
* implementing usefully and precisely defined, standard sized
* integer scalars. Systems which are not intrinsically 2s
* complement may produce invalid constants.
*
* 2) There is an unavoidable use of non-reserved symbols.
*
* 3) Other standard include files are invoked.
*
* 4) This file may come in conflict with future platforms that do
* include stdint.h. The hope is that one or the other can be
* used with no real difference.
*
* 5) In the current version, if your platform can't represent
* int32_t, int16_t and int8_t, it just dumps out with a compiler
* error.
*
* 6) 64 bit integers may or may not be defined. Test for their
* presence with the test: #ifdef INT64_MAX or #ifdef UINT64_MAX.
* Note that this is different from the C99 specification which
* requires the existence of 64 bit support in the compiler. If
* this is not defined for your platform, yet it is capable of
* dealing with 64 bits then it is because this file has not yet
* been extended to cover all of your system's capabilities.
*
* 7) (u)intptr_t may or may not be defined. Test for its presence
* with the test: #ifdef PTRDIFF_MAX. If this is not defined
* for your platform, then it is because this file has not yet
* been extended to cover all of your system's capabilities, not
* because its optional.
*
* 8) The following might not been defined even if your platform is
* capable of defining it:
*
* WCHAR_MIN
* WCHAR_MAX
* (u)int64_t
* PTRDIFF_MIN
* PTRDIFF_MAX
* (u)intptr_t
*
* 9) The following have not been defined:
*
* WINT_MIN
* WINT_MAX
*
* 10) The criteria for defining (u)int_least(*)_t isn't clear,
* except for systems which don't have a type that precisely
* defined 8, 16, or 32 bit types (which this include file does
* not support anyways). Default definitions have been given.
*
* 11) The criteria for defining (u)int_fast(*)_t isn't something I
* would trust to any particular compiler vendor or the ANSI C
* committee. It is well known that "compatible systems" are
* commonly created that have very different performance
* characteristics from the systems they are compatible with,
* especially those whose vendors make both the compiler and the
* system. Default definitions have been given, but its strongly
* recommended that users never use these definitions for any
* reason (they do *NOT* deliver any serious guarantee of
* improved performance -- not in this file, nor any vendor's
* stdint.h).
*
* 12) The following macros:
*
* PRINTF_INTMAX_MODIFIER
* PRINTF_INT64_MODIFIER
* PRINTF_INT32_MODIFIER
* PRINTF_INT16_MODIFIER
* PRINTF_LEAST64_MODIFIER
* PRINTF_LEAST32_MODIFIER
* PRINTF_LEAST16_MODIFIER
* PRINTF_INTPTR_MODIFIER
*
* are strings which have been defined as the modifiers required
* for the "d", "u" and "x" printf formats to correctly output
* (u)intmax_t, (u)int64_t, (u)int32_t, (u)int16_t, (u)least64_t,
* (u)least32_t, (u)least16_t and (u)intptr_t types respectively.
* PRINTF_INTPTR_MODIFIER is not defined for some systems which
* provide their own stdint.h. PRINTF_INT64_MODIFIER is not
* defined if INT64_MAX is not defined. These are an extension
* beyond what C99 specifies must be in stdint.h.
*
* In addition, the following macros are defined:
*
* PRINTF_INTMAX_HEX_WIDTH
* PRINTF_INT64_HEX_WIDTH
* PRINTF_INT32_HEX_WIDTH
* PRINTF_INT16_HEX_WIDTH
* PRINTF_INT8_HEX_WIDTH
* PRINTF_INTMAX_DEC_WIDTH
* PRINTF_INT64_DEC_WIDTH
* PRINTF_INT32_DEC_WIDTH
* PRINTF_INT16_DEC_WIDTH
* PRINTF_UINT8_DEC_WIDTH
* PRINTF_UINTMAX_DEC_WIDTH
* PRINTF_UINT64_DEC_WIDTH
* PRINTF_UINT32_DEC_WIDTH
* PRINTF_UINT16_DEC_WIDTH
* PRINTF_UINT8_DEC_WIDTH
*
* Which specifies the maximum number of characters required to
* print the number of that type in either hexadecimal or decimal.
* These are an extension beyond what C99 specifies must be in
* stdint.h.
*
* Compilers tested (all with 0 warnings at their highest respective
* settings): Borland Turbo C 2.0, WATCOM C/C++ 11.0 (16 bits and 32
* bits), Microsoft Visual C++ 6.0 (32 bit), Microsoft Visual Studio
* .net (VC7), Intel C++ 4.0, GNU gcc v3.3.3
*
* This file should be considered a work in progress. Suggestions for
* improvements, especially those which increase coverage are strongly
* encouraged.
*
* Acknowledgements
*
* The following people have made significant contributions to the
* development and testing of this file:
*
* Chris Howie
* John Steele Scott
* Dave Thorup
* John Dill
* Florian Wobbe
* Christopher Sean Morrison
* Mikkel Fahnoe Jorgensen
*
*/
#include <stddef.h>
#include <limits.h>
#include <signal.h>
/*
* For gcc with _STDINT_H, fill in the PRINTF_INT*_MODIFIER macros, and
* do nothing else. On the Mac OS X version of gcc this is _STDINT_H_.
*/
#if ((defined(__SUNPRO_C) && __SUNPRO_C >= 0x570) || (defined(_MSC_VER) && _MSC_VER >= 1600) || (defined(__STDC__) && __STDC__ && defined(__STDC_VERSION__) && __STDC_VERSION__ >= 199901L) || (defined (__WATCOMC__) && (defined (_STDINT_H_INCLUDED) || __WATCOMC__ >= 1250)) || (defined(__GNUC__) && (__GNUC__ > 3 || defined(_STDINT_H) || defined(_STDINT_H_) || defined (__UINT_FAST64_TYPE__)) )) && !defined (_PSTDINT_H_INCLUDED)
#include <stdint.h>
#define _PSTDINT_H_INCLUDED
# if defined(__GNUC__) && (defined(__x86_64__) || defined(__ppc64__)) && !(defined(__APPLE__) && defined(__MACH__))
# ifndef PRINTF_INT64_MODIFIER
# define PRINTF_INT64_MODIFIER "l"
# endif
# ifndef PRINTF_INT32_MODIFIER
# define PRINTF_INT32_MODIFIER ""
# endif
# else
# ifndef PRINTF_INT64_MODIFIER
# define PRINTF_INT64_MODIFIER "ll"
# endif
# ifndef PRINTF_INT32_MODIFIER
# if (UINT_MAX == UINT32_MAX)
# define PRINTF_INT32_MODIFIER ""
# else
# define PRINTF_INT32_MODIFIER "l"
# endif
# endif
# endif
# ifndef PRINTF_INT16_MODIFIER
# define PRINTF_INT16_MODIFIER "h"
# endif
# ifndef PRINTF_INTMAX_MODIFIER
# define PRINTF_INTMAX_MODIFIER PRINTF_INT64_MODIFIER
# endif
# ifndef PRINTF_INT64_HEX_WIDTH
# define PRINTF_INT64_HEX_WIDTH "16"
# endif
# ifndef PRINTF_UINT64_HEX_WIDTH
# define PRINTF_UINT64_HEX_WIDTH "16"
# endif
# ifndef PRINTF_INT32_HEX_WIDTH
# define PRINTF_INT32_HEX_WIDTH "8"
# endif
# ifndef PRINTF_UINT32_HEX_WIDTH
# define PRINTF_UINT32_HEX_WIDTH "8"
# endif
# ifndef PRINTF_INT16_HEX_WIDTH
# define PRINTF_INT16_HEX_WIDTH "4"
# endif
# ifndef PRINTF_UINT16_HEX_WIDTH
# define PRINTF_UINT16_HEX_WIDTH "4"
# endif
# ifndef PRINTF_INT8_HEX_WIDTH
# define PRINTF_INT8_HEX_WIDTH "2"
# endif
# ifndef PRINTF_UINT8_HEX_WIDTH
# define PRINTF_UINT8_HEX_WIDTH "2"
# endif
# ifndef PRINTF_INT64_DEC_WIDTH
# define PRINTF_INT64_DEC_WIDTH "19"
# endif
# ifndef PRINTF_UINT64_DEC_WIDTH
# define PRINTF_UINT64_DEC_WIDTH "20"
# endif
# ifndef PRINTF_INT32_DEC_WIDTH
# define PRINTF_INT32_DEC_WIDTH "10"
# endif
# ifndef PRINTF_UINT32_DEC_WIDTH
# define PRINTF_UINT32_DEC_WIDTH "10"
# endif
# ifndef PRINTF_INT16_DEC_WIDTH
# define PRINTF_INT16_DEC_WIDTH "5"
# endif
# ifndef PRINTF_UINT16_DEC_WIDTH
# define PRINTF_UINT16_DEC_WIDTH "5"
# endif
# ifndef PRINTF_INT8_DEC_WIDTH
# define PRINTF_INT8_DEC_WIDTH "3"
# endif
# ifndef PRINTF_UINT8_DEC_WIDTH
# define PRINTF_UINT8_DEC_WIDTH "3"
# endif
# ifndef PRINTF_INTMAX_HEX_WIDTH
# define PRINTF_INTMAX_HEX_WIDTH PRINTF_UINT64_HEX_WIDTH
# endif
# ifndef PRINTF_UINTMAX_HEX_WIDTH
# define PRINTF_UINTMAX_HEX_WIDTH PRINTF_UINT64_HEX_WIDTH
# endif
# ifndef PRINTF_INTMAX_DEC_WIDTH
# define PRINTF_INTMAX_DEC_WIDTH PRINTF_UINT64_DEC_WIDTH
# endif
# ifndef PRINTF_UINTMAX_DEC_WIDTH
# define PRINTF_UINTMAX_DEC_WIDTH PRINTF_UINT64_DEC_WIDTH
# endif
/*
* Something really weird is going on with Open Watcom. Just pull some of
* these duplicated definitions from Open Watcom's stdint.h file for now.
*/
# if defined (__WATCOMC__) && __WATCOMC__ >= 1250
# if !defined (INT64_C)
# define INT64_C(x) (x + (INT64_MAX - INT64_MAX))
# endif
# if !defined (UINT64_C)
# define UINT64_C(x) (x + (UINT64_MAX - UINT64_MAX))
# endif
# if !defined (INT32_C)
# define INT32_C(x) (x + (INT32_MAX - INT32_MAX))
# endif
# if !defined (UINT32_C)
# define UINT32_C(x) (x + (UINT32_MAX - UINT32_MAX))
# endif
# if !defined (INT16_C)
# define INT16_C(x) (x)
# endif
# if !defined (UINT16_C)
# define UINT16_C(x) (x)
# endif
# if !defined (INT8_C)
# define INT8_C(x) (x)
# endif
# if !defined (UINT8_C)
# define UINT8_C(x) (x)
# endif
# if !defined (UINT64_MAX)
# define UINT64_MAX 18446744073709551615ULL
# endif
# if !defined (INT64_MAX)
# define INT64_MAX 9223372036854775807LL
# endif
# if !defined (UINT32_MAX)
# define UINT32_MAX 4294967295UL
# endif
# if !defined (INT32_MAX)
# define INT32_MAX 2147483647L
# endif
# if !defined (INTMAX_MAX)
# define INTMAX_MAX INT64_MAX
# endif
# if !defined (INTMAX_MIN)
# define INTMAX_MIN INT64_MIN
# endif
# endif
#endif
/*
* I have no idea what is the truly correct thing to do on older Solaris.
* From some online discussions, this seems to be what is being
* recommended. For people who actually are developing on older Solaris,
* what I would like to know is, does this define all of the relevant
* macros of a complete stdint.h? Remember, in pstdint.h 64 bit is
* considered optional.
*/
#if (defined(__SUNPRO_C) && __SUNPRO_C >= 0x420) && !defined(_PSTDINT_H_INCLUDED)
#include <sys/inttypes.h>
#define _PSTDINT_H_INCLUDED
#endif
#ifndef _PSTDINT_H_INCLUDED
#define _PSTDINT_H_INCLUDED
#ifndef SIZE_MAX
# define SIZE_MAX ((size_t)-1)
#endif
/*
* Deduce the type assignments from limits.h under the assumption that
* integer sizes in bits are powers of 2, and follow the ANSI
* definitions.
*/
#ifndef UINT8_MAX
# define UINT8_MAX 0xff
#endif
#if !defined(uint8_t) && !defined(_UINT8_T) && !defined(vxWorks)
# if (UCHAR_MAX == UINT8_MAX) || defined (S_SPLINT_S)
typedef unsigned char uint8_t;
# define UINT8_C(v) ((uint8_t) v)
# else
# error "Platform not supported"
# endif
#endif
#ifndef INT8_MAX
# define INT8_MAX 0x7f
#endif
#ifndef INT8_MIN
# define INT8_MIN INT8_C(0x80)
#endif
#if !defined(int8_t) && !defined(_INT8_T) && !defined(vxWorks)
# if (SCHAR_MAX == INT8_MAX) || defined (S_SPLINT_S)
typedef signed char int8_t;
# define INT8_C(v) ((int8_t) v)
# else
# error "Platform not supported"
# endif
#endif
#ifndef UINT16_MAX
# define UINT16_MAX 0xffff
#endif
#if !defined(uint16_t) && !defined(_UINT16_T) && !defined(vxWorks)
#if (UINT_MAX == UINT16_MAX) || defined (S_SPLINT_S)
typedef unsigned int uint16_t;
# ifndef PRINTF_INT16_MODIFIER
# define PRINTF_INT16_MODIFIER ""
# endif
# define UINT16_C(v) ((uint16_t) (v))
#elif (USHRT_MAX == UINT16_MAX)
typedef unsigned short uint16_t;
# define UINT16_C(v) ((uint16_t) (v))
# ifndef PRINTF_INT16_MODIFIER
# define PRINTF_INT16_MODIFIER "h"
# endif
#else
#error "Platform not supported"
#endif
#endif
#ifndef INT16_MAX
# define INT16_MAX 0x7fff
#endif
#ifndef INT16_MIN
# define INT16_MIN INT16_C(0x8000)
#endif
#if !defined(int16_t) && !defined(_INT16_T) && !defined(vxWorks)
#if (INT_MAX == INT16_MAX) || defined (S_SPLINT_S)
typedef signed int int16_t;
# define INT16_C(v) ((int16_t) (v))
# ifndef PRINTF_INT16_MODIFIER
# define PRINTF_INT16_MODIFIER ""
# endif
#elif (SHRT_MAX == INT16_MAX)
typedef signed short int16_t;
# define INT16_C(v) ((int16_t) (v))
# ifndef PRINTF_INT16_MODIFIER
# define PRINTF_INT16_MODIFIER "h"
# endif
#else
#error "Platform not supported"
#endif
#endif
#ifndef UINT32_MAX
# define UINT32_MAX (0xffffffffUL)
#endif
#if !defined(uint32_t) && !defined(_UINT32_T) && !defined(vxWorks)
#if (ULONG_MAX == UINT32_MAX) || defined (S_SPLINT_S)
typedef unsigned long uint32_t;
# define UINT32_C(v) v ## UL
# ifndef PRINTF_INT32_MODIFIER
# define PRINTF_INT32_MODIFIER "l"
# endif
#elif (UINT_MAX == UINT32_MAX)
typedef unsigned int uint32_t;
# ifndef PRINTF_INT32_MODIFIER
# define PRINTF_INT32_MODIFIER ""
# endif
# define UINT32_C(v) v ## U
#elif (USHRT_MAX == UINT32_MAX)
typedef unsigned short uint32_t;
# define UINT32_C(v) ((unsigned short) (v))
# ifndef PRINTF_INT32_MODIFIER
# define PRINTF_INT32_MODIFIER ""
# endif
#else
#error "Platform not supported"
#endif
#endif
#ifndef INT32_MAX
# define INT32_MAX (0x7fffffffL)
#endif
#ifndef INT32_MIN
# define INT32_MIN INT32_C(0x80000000)
#endif
#if !defined(int32_t) && !defined(_INT32_T) && !defined(vxWorks)
#if (LONG_MAX == INT32_MAX) || defined (S_SPLINT_S)
typedef signed long int32_t;
# define INT32_C(v) v ## L
# ifndef PRINTF_INT32_MODIFIER
# define PRINTF_INT32_MODIFIER "l"
# endif
#elif (INT_MAX == INT32_MAX)
typedef signed int int32_t;
# define INT32_C(v) v
# ifndef PRINTF_INT32_MODIFIER
# define PRINTF_INT32_MODIFIER ""
# endif
#elif (SHRT_MAX == INT32_MAX)
typedef signed short int32_t;
# define INT32_C(v) ((short) (v))
# ifndef PRINTF_INT32_MODIFIER
# define PRINTF_INT32_MODIFIER ""
# endif
#else
#error "Platform not supported"
#endif
#endif
/*
* The macro stdint_int64_defined is temporarily used to record
* whether or not 64 integer support is available. It must be
* defined for any 64 integer extensions for new platforms that are
* added.
*/
#undef stdint_int64_defined
#if (defined(__STDC__) && defined(__STDC_VERSION__)) || defined (S_SPLINT_S)
# if (__STDC__ && __STDC_VERSION__ >= 199901L) || defined (S_SPLINT_S)
# define stdint_int64_defined
typedef long long int64_t;
typedef unsigned long long uint64_t;
# define UINT64_C(v) v ## ULL
# define INT64_C(v) v ## LL
# ifndef PRINTF_INT64_MODIFIER
# define PRINTF_INT64_MODIFIER "ll"
# endif
# endif
#endif
#if !defined (stdint_int64_defined)
# if defined(__GNUC__) && !defined(vxWorks)
# define stdint_int64_defined
__extension__ typedef long long int64_t;
__extension__ typedef unsigned long long uint64_t;
# define UINT64_C(v) v ## ULL
# define INT64_C(v) v ## LL
# ifndef PRINTF_INT64_MODIFIER
# define PRINTF_INT64_MODIFIER "ll"
# endif
# elif defined(__MWERKS__) || defined (__SUNPRO_C) || defined (__SUNPRO_CC) || defined (__APPLE_CC__) || defined (_LONG_LONG) || defined (_CRAYC) || defined (S_SPLINT_S)
# define stdint_int64_defined
typedef long long int64_t;
typedef unsigned long long uint64_t;
# define UINT64_C(v) v ## ULL
# define INT64_C(v) v ## LL
# ifndef PRINTF_INT64_MODIFIER
# define PRINTF_INT64_MODIFIER "ll"
# endif
# elif (defined(__WATCOMC__) && defined(__WATCOM_INT64__)) || (defined(_MSC_VER) && _INTEGRAL_MAX_BITS >= 64) || (defined (__BORLANDC__) && __BORLANDC__ > 0x460) || defined (__alpha) || defined (__DECC)
# define stdint_int64_defined
typedef __int64 int64_t;
typedef unsigned __int64 uint64_t;
# define UINT64_C(v) v ## UI64
# define INT64_C(v) v ## I64
# ifndef PRINTF_INT64_MODIFIER
# define PRINTF_INT64_MODIFIER "I64"
# endif
# endif
#endif
#if !defined (LONG_LONG_MAX) && defined (INT64_C)
# define LONG_LONG_MAX INT64_C (9223372036854775807)
#endif
#ifndef ULONG_LONG_MAX
# define ULONG_LONG_MAX UINT64_C (18446744073709551615)
#endif
#if !defined (INT64_MAX) && defined (INT64_C)
# define INT64_MAX INT64_C (9223372036854775807)
#endif
#if !defined (INT64_MIN) && defined (INT64_C)
# define INT64_MIN INT64_C (-9223372036854775808)
#endif
#if !defined (UINT64_MAX) && defined (INT64_C)
# define UINT64_MAX UINT64_C (18446744073709551615)
#endif
/*
* Width of hexadecimal for number field.
*/
#ifndef PRINTF_INT64_HEX_WIDTH
# define PRINTF_INT64_HEX_WIDTH "16"
#endif
#ifndef PRINTF_INT32_HEX_WIDTH
# define PRINTF_INT32_HEX_WIDTH "8"
#endif
#ifndef PRINTF_INT16_HEX_WIDTH
# define PRINTF_INT16_HEX_WIDTH "4"
#endif
#ifndef PRINTF_INT8_HEX_WIDTH
# define PRINTF_INT8_HEX_WIDTH "2"
#endif
#ifndef PRINTF_INT64_DEC_WIDTH
# define PRINTF_INT64_DEC_WIDTH "19"
#endif
#ifndef PRINTF_INT32_DEC_WIDTH
# define PRINTF_INT32_DEC_WIDTH "10"
#endif
#ifndef PRINTF_INT16_DEC_WIDTH
# define PRINTF_INT16_DEC_WIDTH "5"
#endif
#ifndef PRINTF_INT8_DEC_WIDTH
# define PRINTF_INT8_DEC_WIDTH "3"
#endif
#ifndef PRINTF_UINT64_DEC_WIDTH
# define PRINTF_UINT64_DEC_WIDTH "20"
#endif
#ifndef PRINTF_UINT32_DEC_WIDTH
# define PRINTF_UINT32_DEC_WIDTH "10"
#endif
#ifndef PRINTF_UINT16_DEC_WIDTH
# define PRINTF_UINT16_DEC_WIDTH "5"
#endif
#ifndef PRINTF_UINT8_DEC_WIDTH
# define PRINTF_UINT8_DEC_WIDTH "3"
#endif
/*
* Ok, lets not worry about 128 bit integers for now. Moore's law says
* we don't need to worry about that until about 2040 at which point
* we'll have bigger things to worry about.
*/
#ifdef stdint_int64_defined
typedef int64_t intmax_t;
typedef uint64_t uintmax_t;
# define INTMAX_MAX INT64_MAX
# define INTMAX_MIN INT64_MIN
# define UINTMAX_MAX UINT64_MAX
# define UINTMAX_C(v) UINT64_C(v)
# define INTMAX_C(v) INT64_C(v)
# ifndef PRINTF_INTMAX_MODIFIER
# define PRINTF_INTMAX_MODIFIER PRINTF_INT64_MODIFIER
# endif
# ifndef PRINTF_INTMAX_HEX_WIDTH
# define PRINTF_INTMAX_HEX_WIDTH PRINTF_INT64_HEX_WIDTH
# endif
# ifndef PRINTF_INTMAX_DEC_WIDTH
# define PRINTF_INTMAX_DEC_WIDTH PRINTF_INT64_DEC_WIDTH
# endif
#else
typedef int32_t intmax_t;
typedef uint32_t uintmax_t;
# define INTMAX_MAX INT32_MAX
# define UINTMAX_MAX UINT32_MAX
# define UINTMAX_C(v) UINT32_C(v)
# define INTMAX_C(v) INT32_C(v)
# ifndef PRINTF_INTMAX_MODIFIER
# define PRINTF_INTMAX_MODIFIER PRINTF_INT32_MODIFIER
# endif
# ifndef PRINTF_INTMAX_HEX_WIDTH
# define PRINTF_INTMAX_HEX_WIDTH PRINTF_INT32_HEX_WIDTH
# endif
# ifndef PRINTF_INTMAX_DEC_WIDTH
# define PRINTF_INTMAX_DEC_WIDTH PRINTF_INT32_DEC_WIDTH
# endif
#endif
/*
* Because this file currently only supports platforms which have
* precise powers of 2 as bit sizes for the default integers, the
* least definitions are all trivial. Its possible that a future
* version of this file could have different definitions.
*/
#ifndef stdint_least_defined
typedef int8_t int_least8_t;
typedef uint8_t uint_least8_t;
typedef int16_t int_least16_t;
typedef uint16_t uint_least16_t;
typedef int32_t int_least32_t;
typedef uint32_t uint_least32_t;
# define PRINTF_LEAST32_MODIFIER PRINTF_INT32_MODIFIER
# define PRINTF_LEAST16_MODIFIER PRINTF_INT16_MODIFIER
# define UINT_LEAST8_MAX UINT8_MAX
# define INT_LEAST8_MAX INT8_MAX
# define UINT_LEAST16_MAX UINT16_MAX
# define INT_LEAST16_MAX INT16_MAX
# define UINT_LEAST32_MAX UINT32_MAX
# define INT_LEAST32_MAX INT32_MAX
# define INT_LEAST8_MIN INT8_MIN
# define INT_LEAST16_MIN INT16_MIN
# define INT_LEAST32_MIN INT32_MIN
# ifdef stdint_int64_defined
typedef int64_t int_least64_t;
typedef uint64_t uint_least64_t;
# define PRINTF_LEAST64_MODIFIER PRINTF_INT64_MODIFIER
# define UINT_LEAST64_MAX UINT64_MAX
# define INT_LEAST64_MAX INT64_MAX
# define INT_LEAST64_MIN INT64_MIN
# endif
#endif
#undef stdint_least_defined
/*
* The ANSI C committee has defined *int*_fast*_t types as well. This,
* of course, defies rationality -- you can't know what will be fast
* just from the type itself. Even for a given architecture, compatible
* implementations might have different performance characteristics.
* Developers are warned to stay away from these types when using this
* or any other stdint.h.
*/
typedef int_least8_t int_fast8_t;
typedef uint_least8_t uint_fast8_t;
typedef int_least16_t int_fast16_t;
typedef uint_least16_t uint_fast16_t;
typedef int_least32_t int_fast32_t;
typedef uint_least32_t uint_fast32_t;
#define UINT_FAST8_MAX UINT_LEAST8_MAX
#define INT_FAST8_MAX INT_LEAST8_MAX
#define UINT_FAST16_MAX UINT_LEAST16_MAX
#define INT_FAST16_MAX INT_LEAST16_MAX
#define UINT_FAST32_MAX UINT_LEAST32_MAX
#define INT_FAST32_MAX INT_LEAST32_MAX
#define INT_FAST8_MIN INT_LEAST8_MIN
#define INT_FAST16_MIN INT_LEAST16_MIN
#define INT_FAST32_MIN INT_LEAST32_MIN
#ifdef stdint_int64_defined
typedef int_least64_t int_fast64_t;
typedef uint_least64_t uint_fast64_t;
# define UINT_FAST64_MAX UINT_LEAST64_MAX
# define INT_FAST64_MAX INT_LEAST64_MAX
# define INT_FAST64_MIN INT_LEAST64_MIN
#endif
#undef stdint_int64_defined
/*
* Whatever piecemeal, per compiler thing we can do about the wchar_t
* type limits.
*/
#if defined(__WATCOMC__) || defined(_MSC_VER) || defined (__GNUC__) && !defined(vxWorks)
# include <wchar.h>
# ifndef WCHAR_MIN
# define WCHAR_MIN 0
# endif
# ifndef WCHAR_MAX
# define WCHAR_MAX ((wchar_t)-1)
# endif
#endif
/*
* Whatever piecemeal, per compiler/platform thing we can do about the
* (u)intptr_t types and limits.
*/
#if (defined (_MSC_VER) && defined (_UINTPTR_T_DEFINED)) || defined (_UINTPTR_T)
# define STDINT_H_UINTPTR_T_DEFINED
#endif
#ifndef STDINT_H_UINTPTR_T_DEFINED
# if defined (__alpha__) || defined (__ia64__) || defined (__x86_64__) || defined (_WIN64) || defined (__ppc64__)
# define stdint_intptr_bits 64
# elif defined (__WATCOMC__) || defined (__TURBOC__)
# if defined(__TINY__) || defined(__SMALL__) || defined(__MEDIUM__)
# define stdint_intptr_bits 16
# else
# define stdint_intptr_bits 32
# endif
# elif defined (__i386__) || defined (_WIN32) || defined (WIN32) || defined (__ppc64__)
# define stdint_intptr_bits 32
# elif defined (__INTEL_COMPILER)
/* TODO -- what did Intel do about x86-64? */
# else
/* #error "This platform might not be supported yet" */
# endif
# ifdef stdint_intptr_bits
# define stdint_intptr_glue3_i(a,b,c) a##b##c
# define stdint_intptr_glue3(a,b,c) stdint_intptr_glue3_i(a,b,c)
# ifndef PRINTF_INTPTR_MODIFIER
# define PRINTF_INTPTR_MODIFIER stdint_intptr_glue3(PRINTF_INT,stdint_intptr_bits,_MODIFIER)
# endif
# ifndef PTRDIFF_MAX
# define PTRDIFF_MAX stdint_intptr_glue3(INT,stdint_intptr_bits,_MAX)
# endif
# ifndef PTRDIFF_MIN
# define PTRDIFF_MIN stdint_intptr_glue3(INT,stdint_intptr_bits,_MIN)
# endif
# ifndef UINTPTR_MAX
# define UINTPTR_MAX stdint_intptr_glue3(UINT,stdint_intptr_bits,_MAX)
# endif
# ifndef INTPTR_MAX
# define INTPTR_MAX stdint_intptr_glue3(INT,stdint_intptr_bits,_MAX)
# endif
# ifndef INTPTR_MIN
# define INTPTR_MIN stdint_intptr_glue3(INT,stdint_intptr_bits,_MIN)
# endif
# ifndef INTPTR_C
# define INTPTR_C(x) stdint_intptr_glue3(INT,stdint_intptr_bits,_C)(x)
# endif
# ifndef UINTPTR_C
# define UINTPTR_C(x) stdint_intptr_glue3(UINT,stdint_intptr_bits,_C)(x)
# endif
typedef stdint_intptr_glue3(uint,stdint_intptr_bits,_t) uintptr_t;
typedef stdint_intptr_glue3( int,stdint_intptr_bits,_t) intptr_t;
# else
/* TODO -- This following is likely wrong for some platforms, and does
nothing for the definition of uintptr_t. */
typedef ptrdiff_t intptr_t;
# endif
# define STDINT_H_UINTPTR_T_DEFINED
#endif
/*
* Assumes sig_atomic_t is signed and we have a 2s complement machine.
*/
#ifndef SIG_ATOMIC_MAX
# define SIG_ATOMIC_MAX ((((sig_atomic_t) 1) << (sizeof (sig_atomic_t)*CHAR_BIT-1)) - 1)
#endif
#endif
#if defined (__TEST_PSTDINT_FOR_CORRECTNESS)
/*
* Please compile with the maximum warning settings to make sure macros are
* not defined more than once.
*/
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#define glue3_aux(x,y,z) x ## y ## z
#define glue3(x,y,z) glue3_aux(x,y,z)
#define DECLU(bits) glue3(uint,bits,_t) glue3(u,bits,) = glue3(UINT,bits,_C) (0);
#define DECLI(bits) glue3(int,bits,_t) glue3(i,bits,) = glue3(INT,bits,_C) (0);
#define DECL(us,bits) glue3(DECL,us,) (bits)
#define TESTUMAX(bits) glue3(u,bits,) = ~glue3(u,bits,); if (glue3(UINT,bits,_MAX) != glue3(u,bits,)) printf ("Something wrong with UINT%d_MAX\n", bits)
#define REPORTERROR(msg) { err_n++; if (err_first <= 0) err_first = __LINE__; printf msg; }
#define X_SIZE_MAX ((size_t)-1)
int main () {
int err_n = 0;
int err_first = 0;
DECL(I,8)
DECL(U,8)
DECL(I,16)
DECL(U,16)
DECL(I,32)
DECL(U,32)
#ifdef INT64_MAX
DECL(I,64)
DECL(U,64)
#endif
intmax_t imax = INTMAX_C(0);
uintmax_t umax = UINTMAX_C(0);
char str0[256], str1[256];
sprintf (str0, "%" PRINTF_INT32_MODIFIER "d", INT32_C(2147483647));
if (0 != strcmp (str0, "2147483647")) REPORTERROR (("Something wrong with PRINTF_INT32_MODIFIER : %s\n", str0));
if (atoi(PRINTF_INT32_DEC_WIDTH) != (int) strlen(str0)) REPORTERROR (("Something wrong with PRINTF_INT32_DEC_WIDTH : %s\n", PRINTF_INT32_DEC_WIDTH));
sprintf (str0, "%" PRINTF_INT32_MODIFIER "u", UINT32_C(4294967295));
if (0 != strcmp (str0, "4294967295")) REPORTERROR (("Something wrong with PRINTF_INT32_MODIFIER : %s\n", str0));
if (atoi(PRINTF_UINT32_DEC_WIDTH) != (int) strlen(str0)) REPORTERROR (("Something wrong with PRINTF_UINT32_DEC_WIDTH : %s\n", PRINTF_UINT32_DEC_WIDTH));
#ifdef INT64_MAX
sprintf (str1, "%" PRINTF_INT64_MODIFIER "d", INT64_C(9223372036854775807));
if (0 != strcmp (str1, "9223372036854775807")) REPORTERROR (("Something wrong with PRINTF_INT32_MODIFIER : %s\n", str1));
if (atoi(PRINTF_INT64_DEC_WIDTH) != (int) strlen(str1)) REPORTERROR (("Something wrong with PRINTF_INT64_DEC_WIDTH : %s, %d\n", PRINTF_INT64_DEC_WIDTH, (int) strlen(str1)));
sprintf (str1, "%" PRINTF_INT64_MODIFIER "u", UINT64_C(18446744073709550591));
if (0 != strcmp (str1, "18446744073709550591")) REPORTERROR (("Something wrong with PRINTF_INT32_MODIFIER : %s\n", str1));
if (atoi(PRINTF_UINT64_DEC_WIDTH) != (int) strlen(str1)) REPORTERROR (("Something wrong with PRINTF_UINT64_DEC_WIDTH : %s, %d\n", PRINTF_UINT64_DEC_WIDTH, (int) strlen(str1)));
#endif
sprintf (str0, "%d %x\n", 0, ~0);
sprintf (str1, "%d %x\n", i8, ~0);
if (0 != strcmp (str0, str1)) REPORTERROR (("Something wrong with i8 : %s\n", str1));
sprintf (str1, "%u %x\n", u8, ~0);
if (0 != strcmp (str0, str1)) REPORTERROR (("Something wrong with u8 : %s\n", str1));
sprintf (str1, "%d %x\n", i16, ~0);
if (0 != strcmp (str0, str1)) REPORTERROR (("Something wrong with i16 : %s\n", str1));
sprintf (str1, "%u %x\n", u16, ~0);
if (0 != strcmp (str0, str1)) REPORTERROR (("Something wrong with u16 : %s\n", str1));
sprintf (str1, "%" PRINTF_INT32_MODIFIER "d %x\n", i32, ~0);
if (0 != strcmp (str0, str1)) REPORTERROR (("Something wrong with i32 : %s\n", str1));
sprintf (str1, "%" PRINTF_INT32_MODIFIER "u %x\n", u32, ~0);
if (0 != strcmp (str0, str1)) REPORTERROR (("Something wrong with u32 : %s\n", str1));
#ifdef INT64_MAX
sprintf (str1, "%" PRINTF_INT64_MODIFIER "d %x\n", i64, ~0);
if (0 != strcmp (str0, str1)) REPORTERROR (("Something wrong with i64 : %s\n", str1));
#endif
sprintf (str1, "%" PRINTF_INTMAX_MODIFIER "d %x\n", imax, ~0);
if (0 != strcmp (str0, str1)) REPORTERROR (("Something wrong with imax : %s\n", str1));
sprintf (str1, "%" PRINTF_INTMAX_MODIFIER "u %x\n", umax, ~0);
if (0 != strcmp (str0, str1)) REPORTERROR (("Something wrong with umax : %s\n", str1));
TESTUMAX(8);
TESTUMAX(16);
TESTUMAX(32);
#ifdef INT64_MAX
TESTUMAX(64);
#endif
#define STR(v) #v
#define Q(v) printf ("sizeof " STR(v) " = %u\n", (unsigned) sizeof (v));
if (err_n) {
printf ("pstdint.h is not correct. Please use sizes below to correct it:\n");
}
Q(int)
Q(unsigned)
Q(long int)
Q(short int)
Q(int8_t)
Q(int16_t)
Q(int32_t)
#ifdef INT64_MAX
Q(int64_t)
#endif
#if UINT_MAX < X_SIZE_MAX
printf ("UINT_MAX < X_SIZE_MAX\n");
#else
printf ("UINT_MAX >= X_SIZE_MAX\n");
#endif
printf ("%" PRINTF_INT64_MODIFIER "u vs %" PRINTF_INT64_MODIFIER "u\n", UINT_MAX, X_SIZE_MAX);
return EXIT_SUCCESS;
}
#endif
|
Changes to compat/stdlib.h.
1 2 3 4 5 6 7 | /* * stdlib.h -- * * Declares facilities exported by the "stdlib" portion of the C library. * This file isn't complete in the ANSI-C sense; it only declares things * that are needed by Tcl. This file is needed even on many systems with * their own stdlib.h (e.g. SunOS) because not all stdlib.h files declare | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * stdlib.h -- * * Declares facilities exported by the "stdlib" portion of the C library. * This file isn't complete in the ANSI-C sense; it only declares things * that are needed by Tcl. This file is needed even on many systems with * their own stdlib.h (e.g. SunOS) because not all stdlib.h files declare * all the procedures needed here (such as strtol/strtoul). * * Copyright (c) 1991 The Regents of the University of California. * Copyright (c) 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. */ |
| ︙ | ︙ |
Changes to compat/strstr.c.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 | * None. * *---------------------------------------------------------------------- */ char * strstr( | | | | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 |
* None.
*
*----------------------------------------------------------------------
*/
char *
strstr(
char *string, /* String to search. */
char *substring) /* Substring to try to find in string. */
{
char *a, *b;
/*
* First scan quickly through the two strings looking for a
* single-character match. When it's found, then compare the rest of the
* substring.
*/
|
| ︙ | ︙ |
Changes to compat/strtol.c.
| ︙ | ︙ | |||
41 42 43 44 45 46 47 |
* character, or NULL. */
int base) /* Base for conversion. Must be less than 37.
* If 0, then the base is chosen from the
* leading characters of string: "0x" means
* hex, "0" means octal, anything else means
* decimal. */
{
| | | | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 |
* character, or NULL. */
int base) /* Base for conversion. Must be less than 37.
* If 0, then the base is chosen from the
* leading characters of string: "0x" means
* hex, "0" means octal, anything else means
* decimal. */
{
const char *p;
long result;
/*
* Skip any leading blanks.
*/
p = string;
while (isspace(UCHAR(*p))) {
p += 1;
}
/*
* Check for a sign.
*/
|
| ︙ | ︙ |
Changes to compat/strtoul.c.
| ︙ | ︙ | |||
58 59 60 61 62 63 64 |
* character, or NULL. */
int base) /* Base for conversion. Must be less than 37.
* If 0, then the base is chosen from the
* leading characters of string: "0x" means
* hex, "0" means octal, anything else means
* decimal. */
{
| | | | | | 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 |
* character, or NULL. */
int base) /* Base for conversion. Must be less than 37.
* If 0, then the base is chosen from the
* leading characters of string: "0x" means
* hex, "0" means octal, anything else means
* decimal. */
{
const char *p;
unsigned long int result = 0;
unsigned digit;
int anyDigits = 0;
int negative=0;
int overflow=0;
/*
* Skip any leading blanks.
*/
p = string;
while (isspace(UCHAR(*p))) {
p += 1;
}
if (*p == '-') {
negative = 1;
p += 1;
} else {
if (*p == '+') {
|
| ︙ | ︙ |
Changes to compat/waitpid.c.
| ︙ | ︙ | |||
66 67 68 69 70 71 72 |
pid_t pid, /* The pid to wait on. Must be -1 or greater
* than zero. */
int *statusPtr, /* Where to store wait status for the
* process. */
int options) /* OR'ed combination of WNOHANG and
* WUNTRACED. */
{
| | | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 |
pid_t pid, /* The pid to wait on. Must be -1 or greater
* than zero. */
int *statusPtr, /* Where to store wait status for the
* process. */
int options) /* OR'ed combination of WNOHANG and
* WUNTRACED. */
{
WaitInfo *waitPtr, *prevPtr;
pid_t result;
WAIT_STATUS_TYPE status;
if ((pid < -1) || (pid == 0)) {
errno = EINVAL;
return -1;
}
|
| ︙ | ︙ | |||
96 97 98 99 100 101 102 |
result = waitPtr->pid;
*statusPtr = *((int *) &waitPtr->status);
if (prevPtr == NULL) {
deadList = waitPtr->nextPtr;
} else {
prevPtr->nextPtr = waitPtr->nextPtr;
}
| | | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
result = waitPtr->pid;
*statusPtr = *((int *) &waitPtr->status);
if (prevPtr == NULL) {
deadList = waitPtr->nextPtr;
} else {
prevPtr->nextPtr = waitPtr->nextPtr;
}
ckfree(waitPtr);
return result;
}
/*
* Wait for any process to stop or exit. If it's an acceptable one then
* return it to the caller; otherwise store information about it in the
* list of exited processes and try again. On systems that have only wait
|
| ︙ | ︙ | |||
152 153 154 155 156 157 158 |
saveInfo:
for (waitPtr = deadList; waitPtr != NULL; waitPtr = waitPtr->nextPtr) {
if (waitPtr->pid == result) {
waitPtr->status = status;
goto waitAgain;
}
}
| | | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 |
saveInfo:
for (waitPtr = deadList; waitPtr != NULL; waitPtr = waitPtr->nextPtr) {
if (waitPtr->pid == result) {
waitPtr->status = status;
goto waitAgain;
}
}
waitPtr = (WaitInfo *) ckalloc(sizeof(WaitInfo));
waitPtr->pid = result;
waitPtr->status = status;
waitPtr->nextPtr = deadList;
deadList = waitPtr;
waitAgain:
continue;
}
}
|
Changes to compat/zlib/contrib/minizip/crypt.h.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | The new AES encryption added on Zip format by Winzip (see the page http://www.winzip.com/aes_info.htm ) and PKWare PKZip 5.x Strong Encryption is not supported. */ #define CRC32(c, b) ((*(pcrc_32_tab+(((int)(c) ^ (b)) & 0xff))) ^ ((c) >> 8)) | < < < < < < > | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 |
The new AES encryption added on Zip format by Winzip (see the page
http://www.winzip.com/aes_info.htm ) and PKWare PKZip 5.x Strong
Encryption is not supported.
*/
#define CRC32(c, b) ((*(pcrc_32_tab+(((int)(c) ^ (b)) & 0xff))) ^ ((c) >> 8))
/***********************************************************************
* Return the next byte in the pseudo-random sequence
*/
static int decrypt_byte(unsigned long* pkeys, const z_crc_t* pcrc_32_tab)
{
unsigned temp; /* POTENTIAL BUG: temp*(temp^1) may overflow in an
* unpredictable manner on 16-bit systems; not a problem
* with any known compiler so far, though */
(void)pcrc_32_tab;
temp = ((unsigned)(*(pkeys+2)) & 0xffff) | 2;
return (int)(((temp * (temp ^ 1)) >> 8) & 0xff);
}
/***********************************************************************
* Update the encryption keys with the next byte of plain text
*/
static int update_keys(unsigned long* pkeys,const z_crc_t* pcrc_32_tab,int c)
{
(*(pkeys+0)) = CRC32((*(pkeys+0)), c);
(*(pkeys+1)) += (*(pkeys+0)) & 0xff;
(*(pkeys+1)) = (*(pkeys+1)) * 134775813L + 1;
{
int keyshift = (int)((*(pkeys+1)) >> 24);
(*(pkeys+2)) = CRC32((*(pkeys+2)), keyshift);
}
return c;
}
/***********************************************************************
|
| ︙ | ︙ |
Changes to compat/zlib/contrib/minizip/ioapi.c.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 |
*/
#if defined(_WIN32) && (!(defined(_CRT_SECURE_NO_WARNINGS)))
#define _CRT_SECURE_NO_WARNINGS
#endif
| > > > > | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
*/
#if defined(_WIN32) && (!(defined(_CRT_SECURE_NO_WARNINGS)))
#define _CRT_SECURE_NO_WARNINGS
#endif
#if defined(_WIN32)
#define FOPEN_FUNC(filename, mode) fopen(filename, mode)
#define FTELLO_FUNC(stream) _ftelli64(stream)
#define FSEEKO_FUNC(stream, offset, origin) _fseeki64(stream, offset, origin)
#elif defined(__APPLE__) || defined(IOAPI_NO_64)
// In darwin and perhaps other BSD variants off_t is a 64 bit value, hence no need for specific 64 bit functions
#define FOPEN_FUNC(filename, mode) fopen(filename, mode)
#define FTELLO_FUNC(stream) ftello(stream)
#define FSEEKO_FUNC(stream, offset, origin) fseeko(stream, offset, origin)
#else
#define FOPEN_FUNC(filename, mode) fopen64(filename, mode)
#define FTELLO_FUNC(stream) ftello64(stream)
|
| ︙ | ︙ |
Changes to compat/zlib/contrib/minizip/minizip.c.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 |
#define _LARGEFILE64_SOURCE
#endif
#ifndef _FILE_OFFSET_BIT
#define _FILE_OFFSET_BIT 64
#endif
#endif
| > > > > | | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 |
#define _LARGEFILE64_SOURCE
#endif
#ifndef _FILE_OFFSET_BIT
#define _FILE_OFFSET_BIT 64
#endif
#endif
#if defined(_WIN32)
#define FOPEN_FUNC(filename, mode) fopen(filename, mode)
#define FTELLO_FUNC(stream) _ftelli64(stream)
#define FSEEKO_FUNC(stream, offset, origin) _fseeki64(stream, offset, origin)
#elif defined(__APPLE__) || defined(IOAPI_NO_64)
// In darwin and perhaps other BSD variants off_t is a 64 bit value, hence no need for specific 64 bit functions
#define FOPEN_FUNC(filename, mode) fopen(filename, mode)
#define FTELLO_FUNC(stream) ftello(stream)
#define FSEEKO_FUNC(stream, offset, origin) fseeko(stream, offset, origin)
#else
#define FOPEN_FUNC(filename, mode) fopen64(filename, mode)
#define FTELLO_FUNC(stream) ftello64(stream)
|
| ︙ | ︙ | |||
66 67 68 69 70 71 72 | #define WRITEBUFFERSIZE (16384) #define MAXFILENAME (256) #ifdef _WIN32 uLong filetime(f, tmzip, dt) | | | | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 |
#define WRITEBUFFERSIZE (16384)
#define MAXFILENAME (256)
#ifdef _WIN32
uLong filetime(f, tmzip, dt)
const char *f; /* name of file to get info on */
tm_zip *tmzip; /* return value: access, modific. and creation times */
uLong *dt; /* dostime */
{
int ret = 0;
{
FILETIME ftLocal;
HANDLE hFind;
WIN32_FIND_DATAA ff32;
|
| ︙ | ︙ | |||
90 91 92 93 94 95 96 |
}
}
return ret;
}
#else
#if defined(unix) || defined(__APPLE__)
uLong filetime(f, tmzip, dt)
| | | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 |
}
}
return ret;
}
#else
#if defined(unix) || defined(__APPLE__)
uLong filetime(f, tmzip, dt)
const char *f; /* name of file to get info on */
tm_zip *tmzip; /* return value: access, modific. and creation times */
uLong *dt; /* dostime */
{
int ret=0;
struct stat s; /* results of stat() */
struct tm* filedate;
time_t tm_t=0;
|
| ︙ | ︙ | |||
132 133 134 135 136 137 138 | tmzip->tm_mon = filedate->tm_mon ; tmzip->tm_year = filedate->tm_year; return ret; } #else uLong filetime(f, tmzip, dt) | | | | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 |
tmzip->tm_mon = filedate->tm_mon ;
tmzip->tm_year = filedate->tm_year;
return ret;
}
#else
uLong filetime(f, tmzip, dt)
const char *f; /* name of file to get info on */
tm_zip *tmzip; /* return value: access, modific. and creation times */
uLong *dt; /* dostime */
{
return 0;
}
#endif
#endif
|
| ︙ | ︙ |
Changes to compat/zlib/contrib/vstudio/vc10/zlibvc.sln.
| ︙ | ︙ |
Changes to compat/zlib/contrib/vstudio/vc11/zlibvc.sln.
| ︙ | ︙ |
Changes to compat/zlib/contrib/vstudio/vc12/zlibvc.sln.
| ︙ | ︙ |
Changes to compat/zlib/contrib/vstudio/vc14/zlibvc.sln.
| ︙ | ︙ |
Changes to compat/zlib/contrib/vstudio/vc9/zlibvc.sln.
| ︙ | ︙ |
Changes to doc/AddErrInfo.3.
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-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_AddErrorInfo 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_AddErrorInfo 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AppendObjToErrorInfo, Tcl_AddObjErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorCodeVA, Tcl_SetErrorLine, Tcl_GetErrorLine, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_GetReturnOptions\fR(\fIinterp, code\fR) .sp int \fBTcl_SetReturnOptions\fR(\fIinterp, options\fR) .sp \fBTcl_AddErrorInfo\fR(\fIinterp, message\fR) .sp \fBTcl_AppendObjToErrorInfo\fR(\fIinterp, objPtr\fR) .sp \fBTcl_AddObjErrorInfo\fR(\fIinterp, message, length\fR) .sp \fBTcl_SetObjErrorCode\fR(\fIinterp, errorObjPtr\fR) .sp \fBTcl_SetErrorCode\fR(\fIinterp, element, element, ... \fB(char *) NULL\fR) .sp \fBTcl_SetErrorCodeVA\fR(\fIinterp, argList\fR) .sp \fBTcl_GetErrorLine\fR(\fIinterp\fR) .sp \fBTcl_SetErrorLine\fR(\fIinterp, lineNum\fR) .sp const char * \fBTcl_PosixError\fR(\fIinterp\fR) |
| ︙ | ︙ | |||
54 55 56 57 58 59 60 | this points to the first byte of an array of \fIlength\fR bytes containing a string to append to the \fB\-errorinfo\fR return option. This byte array may contain embedded null bytes unless \fIlength\fR is negative. .AP Tcl_Obj *objPtr in A message to be appended to the \fB\-errorinfo\fR return option in the form of a Tcl_Obj value. | | | | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | this points to the first byte of an array of \fIlength\fR bytes containing a string to append to the \fB\-errorinfo\fR return option. This byte array may contain embedded null bytes unless \fIlength\fR is negative. .AP Tcl_Obj *objPtr in A message to be appended to the \fB\-errorinfo\fR return option in the form of a Tcl_Obj value. .AP int length in The number of bytes to copy from \fImessage\fR when appending to the \fB\-errorinfo\fR return option. If negative, all bytes up to the first null byte are used. .AP Tcl_Obj *errorObjPtr in The \fB\-errorcode\fR return option will be set to this value. .AP char *element in String to record as one element of the \fB\-errorcode\fR return option. Last \fIelement\fR argument must be NULL. .AP va_list argList in An argument list which must have been initialized using |
| ︙ | ︙ | |||
238 239 240 241 242 243 244 245 246 247 248 249 250 251 | \fBTcl_SetErrorCode\fR the Tcl interpreter automatically sets the \fB\-errorcode\fR return option to \fBNONE\fR. .PP The procedure \fBTcl_SetErrorCode\fR is also used to set the \fB\-errorcode\fR return option. However, it takes one or more strings to record instead of a value. Otherwise, it is similar to \fBTcl_SetObjErrorCode\fR in behavior. .PP The procedure \fBTcl_GetErrorLine\fR is used to read the integer value of the \fB\-errorline\fR return option without the overhead of a full call to \fBTcl_GetReturnOptions\fR. Likewise, \fBTcl_SetErrorLine\fR sets the \fB\-errorline\fR return option value. .PP \fBTcl_PosixError\fR | > > > > > > | 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 | \fBTcl_SetErrorCode\fR the Tcl interpreter automatically sets the \fB\-errorcode\fR return option to \fBNONE\fR. .PP The procedure \fBTcl_SetErrorCode\fR is also used to set the \fB\-errorcode\fR return option. However, it takes one or more strings to record instead of a value. Otherwise, it is similar to \fBTcl_SetObjErrorCode\fR in behavior. .PP \fBTcl_SetErrorCodeVA\fR is the same as \fBTcl_SetErrorCode\fR except that instead of taking a variable number of arguments it takes an argument list. Interfaces using argument lists have been found to be nonportable in practice. This function is deprecated and will be removed in Tcl 9.0. .PP The procedure \fBTcl_GetErrorLine\fR is used to read the integer value of the \fB\-errorline\fR return option without the overhead of a full call to \fBTcl_GetReturnOptions\fR. Likewise, \fBTcl_SetErrorLine\fR sets the \fB\-errorline\fR return option value. .PP \fBTcl_PosixError\fR |
| ︙ | ︙ |
Changes to doc/Alloc.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_Alloc 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | | | > > > > > > | > > > | > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | '\" '\" 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_Alloc 3 7.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_Alloc, Tcl_Free, Tcl_Realloc, Tcl_AttemptAlloc, Tcl_AttemptRealloc, ckalloc, ckfree, ckrealloc, attemptckalloc, attemptckrealloc \- allocate or free heap memory .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp char * \fBTcl_Alloc\fR(\fIsize\fR) .sp void \fBTcl_Free\fR(\fIptr\fR) .sp char * \fBTcl_Realloc\fR(\fIptr, size\fR) .sp char * \fBTcl_AttemptAlloc\fR(\fIsize\fR) .sp char * \fBTcl_AttemptRealloc\fR(\fIptr, size\fR) .sp char * \fBckalloc\fR(\fIsize\fR) .sp void \fBckfree\fR(\fIptr\fR) .sp char * \fBckrealloc\fR(\fIptr, size\fR) .sp char * \fBattemptckalloc\fR(\fIsize\fR) .sp char * \fBattemptckrealloc\fR(\fIptr, size\fR) .SH ARGUMENTS .AS char *size .AP "unsigned int" size in Size in bytes of the memory block to allocate. .AP char *ptr in Pointer to memory block to free or realloc. .BE |
| ︙ | ︙ | |||
60 61 62 63 64 65 66 | function to \fBTcl_Alloc\fR and \fBTcl_Realloc\fR, except that \fBTcl_AttemptAlloc\fR and \fBTcl_AttemptRealloc\fR will not cause the Tcl interpreter to \fBpanic\fR if the memory allocation fails. If the allocation fails, these functions will return NULL. Note that on some platforms, but not all, attempting to allocate a zero-sized block of memory will also cause these functions to return NULL. .PP | > > > > | < < | > > | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 | function to \fBTcl_Alloc\fR and \fBTcl_Realloc\fR, except that \fBTcl_AttemptAlloc\fR and \fBTcl_AttemptRealloc\fR will not cause the Tcl interpreter to \fBpanic\fR if the memory allocation fails. If the allocation fails, these functions will return NULL. Note that on some platforms, but not all, attempting to allocate a zero-sized block of memory will also cause these functions to return NULL. .PP The procedures \fBckalloc\fR, \fBckfree\fR, \fBckrealloc\fR, \fBattemptckalloc\fR, and \fBattemptckrealloc\fR are implemented as macros. Normally, they are synonyms for the corresponding procedures documented on this page. When Tcl and all modules calling Tcl are compiled with \fBTCL_MEM_DEBUG\fR defined, however, these macros are redefined to be special debugging versions of these procedures. To support Tcl's memory debugging within a module, use the macros rather than direct calls to \fBTcl_Alloc\fR, etc. .SH KEYWORDS alloc, allocation, free, malloc, memory, realloc, TCL_MEM_DEBUG |
Changes to doc/AllowExc.3.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | If a script is evaluated at top-level (i.e. no other scripts are pending evaluation when the script is invoked), and if the script terminates with a completion code other than \fBTCL_OK\fR, \fBTCL_ERROR\fR or \fBTCL_RETURN\fR, then Tcl normally converts this into a \fBTCL_ERROR\fR return with an appropriate message. The particular script evaluation procedures of Tcl that act in the manner are \fBTcl_EvalObjEx\fR, \fBTcl_EvalObjv\fR, \fBTcl_Eval\fR, \fBTcl_EvalEx\fR, | | > | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | If a script is evaluated at top-level (i.e. no other scripts are pending evaluation when the script is invoked), and if the script terminates with a completion code other than \fBTCL_OK\fR, \fBTCL_ERROR\fR or \fBTCL_RETURN\fR, then Tcl normally converts this into a \fBTCL_ERROR\fR return with an appropriate message. The particular script evaluation procedures of Tcl that act in the manner are \fBTcl_EvalObjEx\fR, \fBTcl_EvalObjv\fR, \fBTcl_Eval\fR, \fBTcl_EvalEx\fR, \fBTcl_GlobalEval\fR, \fBTcl_GlobalEvalObj\fR, \fBTcl_VarEval\fR and \fBTcl_VarEvalVA\fR. .PP However, if \fBTcl_AllowExceptions\fR is invoked immediately before calling one of those a procedures, then arbitrary completion codes are permitted from the script, and they are returned without modification. This is useful in cases where the caller can deal with exceptions such as \fBTCL_BREAK\fR or \fBTCL_CONTINUE\fR in a meaningful way. |
| ︙ | ︙ |
Changes to doc/AssocData.3.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | .BS .SH NAME Tcl_GetAssocData, Tcl_SetAssocData, Tcl_DeleteAssocData \- manage associations of string keys and user specified data with Tcl interpreters .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp | | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | .BS .SH NAME Tcl_GetAssocData, Tcl_SetAssocData, Tcl_DeleteAssocData \- manage associations of string keys and user specified data with Tcl interpreters .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp ClientData \fBTcl_GetAssocData\fR(\fIinterp, key, delProcPtr\fR) .sp \fBTcl_SetAssocData\fR(\fIinterp, key, delProc, clientData\fR) .sp \fBTcl_DeleteAssocData\fR(\fIinterp, key\fR) .SH ARGUMENTS .AS Tcl_InterpDeleteProc **delProcPtr .AP Tcl_Interp *interp in Interpreter in which to execute the specified command. .AP "const char" *key in Key for association with which to store data or from which to delete or retrieve data. Typically the module prefix for a package. .AP Tcl_InterpDeleteProc *delProc in Procedure to call when \fIinterp\fR is deleted. .AP Tcl_InterpDeleteProc **delProcPtr in Pointer to location in which to store address of current deletion procedure for association. Ignored if NULL. .AP ClientData clientData in Arbitrary one-word value associated with the given key in this interpreter. This data is owned by the caller. .BE .SH DESCRIPTION .PP These procedures allow extensions to associate their own data with |
| ︙ | ︙ | |||
60 61 62 63 64 65 66 | If the \fIdeleteProc\fR argument is non-NULL it specifies the address of a procedure to invoke if the interpreter is deleted before the association is deleted. \fIDeleteProc\fR should have arguments and result that match the type \fBTcl_InterpDeleteProc\fR: .PP .CS typedef void \fBTcl_InterpDeleteProc\fR( | | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
If the \fIdeleteProc\fR argument is non-NULL it specifies the address of a
procedure to invoke if the interpreter is deleted before the association
is deleted. \fIDeleteProc\fR should have arguments and result that match
the type \fBTcl_InterpDeleteProc\fR:
.PP
.CS
typedef void \fBTcl_InterpDeleteProc\fR(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR);
.CE
.PP
When \fIdeleteProc\fR is invoked the \fIclientData\fR and \fIinterp\fR
arguments will be the same as the corresponding arguments passed to
\fBTcl_SetAssocData\fR.
The deletion procedure will \fInot\fR be invoked if the association
|
| ︙ | ︙ |
Changes to doc/Async.3.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | .sp int \fBTcl_AsyncReady\fR() .SH ARGUMENTS .AS Tcl_AsyncHandler clientData .AP Tcl_AsyncProc *proc in Procedure to invoke to handle an asynchronous event. | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | .sp int \fBTcl_AsyncReady\fR() .SH ARGUMENTS .AS Tcl_AsyncHandler clientData .AP Tcl_AsyncProc *proc in Procedure to invoke to handle an asynchronous event. .AP ClientData clientData in One-word value to pass to \fIproc\fR. .AP Tcl_AsyncHandler async in Token for asynchronous event handler. .AP Tcl_Interp *interp in Tcl interpreter in which command was being evaluated when handler was invoked, or NULL if handler was invoked when there was no interpreter active. |
| ︙ | ︙ | |||
80 81 82 83 84 85 86 | the world is in a safe state, and \fIproc\fR can then carry out the actions associated with the asynchronous event. \fIProc\fR should have arguments and result that match the type \fBTcl_AsyncProc\fR: .PP .CS typedef int \fBTcl_AsyncProc\fR( | | | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 |
the world is in a safe state, and \fIproc\fR can then carry out
the actions associated with the asynchronous event.
\fIProc\fR should have arguments and result that match the
type \fBTcl_AsyncProc\fR:
.PP
.CS
typedef int \fBTcl_AsyncProc\fR(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
int \fIcode\fR);
.CE
.PP
The \fIclientData\fR will be the same as the \fIclientData\fR
argument passed to \fBTcl_AsyncCreate\fR when the handler was
created.
|
| ︙ | ︙ |
Added doc/Backslash.3.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 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 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_Backslash 3 "8.1" Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_Backslash \- parse a backslash sequence .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp char \fBTcl_Backslash\fR(\fIsrc, countPtr\fR) .SH ARGUMENTS .AS char *countPtr out .AP char *src in Pointer to a string starting with a backslash. .AP int *countPtr out If \fIcountPtr\fR is not NULL, \fI*countPtr\fR gets filled in with number of characters in the backslash sequence, including the backslash character. .BE .SH DESCRIPTION .PP The use of \fBTcl_Backslash\fR is deprecated in favor of \fBTcl_UtfBackslash\fR. .PP This is a utility procedure provided for backwards compatibility with non-internationalized Tcl extensions. It parses a backslash sequence and returns the low byte of the Unicode character corresponding to the sequence. \fBTcl_Backslash\fR modifies \fI*countPtr\fR to contain the number of characters in the backslash sequence. .PP See the Tcl manual entry for information on the valid backslash sequences. All of the sequences described in the Tcl manual entry are supported by \fBTcl_Backslash\fR. .SH "SEE ALSO" Tcl(n), Tcl_UtfBackslash(3) .SH KEYWORDS backslash, parse |
Changes to doc/ByteArrObj.3.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | unsigned char * \fBTcl_SetByteArrayLength\fR(\fIobjPtr, length\fR) .SH ARGUMENTS .AS "const unsigned char" *lengthPtr in/out .AP "const unsigned char" *bytes in The array of bytes used to initialize or set a byte-array value. May be NULL even if \fIlength\fR is non-zero. | | | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | unsigned char * \fBTcl_SetByteArrayLength\fR(\fIobjPtr, length\fR) .SH ARGUMENTS .AS "const unsigned char" *lengthPtr in/out .AP "const unsigned char" *bytes in The array of bytes used to initialize or set a byte-array value. May be NULL even if \fIlength\fR is non-zero. .AP int length in The length of the array of bytes. It must be >= 0. .AP Tcl_Obj *objPtr in/out For \fBTcl_SetByteArrayObj\fR, this points to the value to be converted to byte-array type. For \fBTcl_GetByteArrayFromObj\fR and \fBTcl_SetByteArrayLength\fR, this points to the value from which to get the byte-array value; if \fIobjPtr\fR does not already point to a byte-array value, it will be converted to one. .AP int *lengthPtr out |
| ︙ | ︙ |
Changes to doc/CallDel.3.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 | \fBTcl_DontCallWhenDeleted\fR(\fIinterp\fR, \fIproc\fR, \fIclientData\fR) .SH ARGUMENTS .AS Tcl_InterpDeleteProc clientData .AP Tcl_Interp *interp in Interpreter with which to associated callback. .AP Tcl_InterpDeleteProc *proc in Procedure to call when \fIinterp\fR is deleted. | | | | 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 |
\fBTcl_DontCallWhenDeleted\fR(\fIinterp\fR, \fIproc\fR, \fIclientData\fR)
.SH ARGUMENTS
.AS Tcl_InterpDeleteProc clientData
.AP Tcl_Interp *interp in
Interpreter with which to associated callback.
.AP Tcl_InterpDeleteProc *proc in
Procedure to call when \fIinterp\fR is deleted.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR.
.BE
.SH DESCRIPTION
.PP
\fBTcl_CallWhenDeleted\fR arranges for \fIproc\fR to be called by
\fBTcl_DeleteInterp\fR if/when \fIinterp\fR is deleted at some future
time. \fIProc\fR will be invoked just before the interpreter
is deleted, but the interpreter will still be valid at the
time of the call.
\fIProc\fR should have arguments and result that match the
type \fBTcl_InterpDeleteProc\fR:
.PP
.CS
typedef void \fBTcl_InterpDeleteProc\fR(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR);
.CE
.PP
The \fIclientData\fR and \fIinterp\fR parameters are
copies of the \fIclientData\fR and \fIinterp\fR arguments given
to \fBTcl_CallWhenDeleted\fR.
Typically, \fIclientData\fR points to an application-specific
|
| ︙ | ︙ |
Changes to doc/Cancel.3.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | not NULL, this object will have its reference count decremented before \fBTcl_CancelEval\fR returns. .AP int flags in ORed combination of flag bits that specify additional options. For \fBTcl_CancelEval\fR, only \fBTCL_CANCEL_UNWIND\fR is currently supported. For \fBTcl_Canceled\fR, only \fBTCL_LEAVE_ERR_MSG\fR and \fBTCL_CANCEL_UNWIND\fR are currently supported. | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | not NULL, this object will have its reference count decremented before \fBTcl_CancelEval\fR returns. .AP int flags in ORed combination of flag bits that specify additional options. For \fBTcl_CancelEval\fR, only \fBTCL_CANCEL_UNWIND\fR is currently supported. For \fBTcl_Canceled\fR, only \fBTCL_LEAVE_ERR_MSG\fR and \fBTCL_CANCEL_UNWIND\fR are currently supported. .AP ClientData clientData in Currently reserved for future use. It should be set to NULL. .BE .SH DESCRIPTION .PP \fBTcl_CancelEval\fR cancels or unwinds the script in progress soon after the next invocation of asynchronous handlers, causing \fBTCL_ERROR\fR to be |
| ︙ | ︙ |
Changes to doc/ChnlStack.3.
| ︙ | ︙ | |||
28 29 30 31 32 33 34 | .sp .SH ARGUMENTS .AS Tcl_ChannelType clientData .AP Tcl_Interp *interp in Interpreter for error reporting. .AP "const Tcl_ChannelType" *typePtr in The new channel I/O procedures to use for \fIchannel\fR. | | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | .sp .SH ARGUMENTS .AS Tcl_ChannelType clientData .AP Tcl_Interp *interp in Interpreter for error reporting. .AP "const Tcl_ChannelType" *typePtr in The new channel I/O procedures to use for \fIchannel\fR. .AP ClientData clientData in Arbitrary one-word value to pass to channel I/O procedures. .AP int mask in Conditions under which \fIchannel\fR will be used: OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR and \fBTCL_EXCEPTION\fR. This can be a subset of the operations currently allowed on \fIchannel\fR. .AP Tcl_Channel channel in An existing Tcl channel such as returned by \fBTcl_CreateChannel\fR. |
| ︙ | ︙ |
Changes to doc/Class.3.
| ︙ | ︙ | |||
37 38 39 40 41 42 43 | .sp Tcl_Object \fBTcl_CopyObjectInstance\fR(\fIinterp, object, name, nsName\fR) .sp int \fBTcl_ObjectDeleted\fR(\fIobject\fR) .sp | | | | | 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 | .sp Tcl_Object \fBTcl_CopyObjectInstance\fR(\fIinterp, object, name, nsName\fR) .sp int \fBTcl_ObjectDeleted\fR(\fIobject\fR) .sp ClientData \fBTcl_ObjectGetMetadata\fR(\fIobject, metaTypePtr\fR) .sp \fBTcl_ObjectSetMetadata\fR(\fIobject, metaTypePtr, metadata\fR) .sp ClientData \fBTcl_ClassGetMetadata\fR(\fIclass, metaTypePtr\fR) .sp \fBTcl_ClassSetMetadata\fR(\fIclass, metaTypePtr, metadata\fR) .sp Tcl_ObjectMapMethodNameProc \fBTcl_ObjectGetMethodNameMapper\fR(\fIobject\fR) .sp \fBTcl_ObjectSetMethodNameMapper\fR(\fIobject\fR, \fImethodNameMapper\fR) .SH ARGUMENTS .AS ClientData metadata in/out .AP Tcl_Interp *interp in/out Interpreter providing the context for looking up or creating an object, and into whose result error messages will be written on failure. .AP Tcl_Obj *objPtr in The name of the object to look up. .AP Tcl_Object object in Reference to the object to operate upon. |
| ︙ | ︙ | |||
75 76 77 78 79 80 81 | already exist. .AP int objc in The number of elements in the \fIobjv\fR array. .AP "Tcl_Obj *const" *objv in The arguments to the command to create the instance of the class. .AP int skip in The number of arguments at the start of the argument array, \fIobjv\fR, that | | > > | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 | already exist. .AP int objc in The number of elements in the \fIobjv\fR array. .AP "Tcl_Obj *const" *objv in The arguments to the command to create the instance of the class. .AP int skip in The number of arguments at the start of the argument array, \fIobjv\fR, that are not arguments to any constructors. This allows the generation of correct error messages even when complicated calling patterns are used (e.g., via the \fBnext\fR command). .AP Tcl_ObjectMetadataType *metaTypePtr in The type of \fImetadata\fR being set with \fBTcl_ClassSetMetadata\fR or retrieved with \fBTcl_ClassGetMetadata\fR. .AP ClientData metadata in An item of metadata to attach to the class, or NULL to remove the metadata associated with a particular \fImetaTypePtr\fR. .AP "Tcl_ObjectMapMethodNameProc" "methodNameMapper" in A pointer to a function to call to adjust the mapping of objects and method names to implementations, or NULL when no such mapping is required. .BE .SH DESCRIPTION |
| ︙ | ︙ | |||
105 106 107 108 109 110 111 | with that name, and then to use \fBTcl_GetObjectAsClass\fR. .PP Every object has its own command and namespace associated with it. The command may be retrieved using the \fBTcl_GetObjectCommand\fR function, the name of the object (and hence the name of the command) with \fBTcl_GetObjectName\fR, and the namespace may be retrieved using the \fBTcl_GetObjectNamespace\fR function. Note that the Tcl_Obj reference returned by \fBTcl_GetObjectName\fR | | > > > > > > > > > > > > | 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 | with that name, and then to use \fBTcl_GetObjectAsClass\fR. .PP Every object has its own command and namespace associated with it. The command may be retrieved using the \fBTcl_GetObjectCommand\fR function, the name of the object (and hence the name of the command) with \fBTcl_GetObjectName\fR, and the namespace may be retrieved using the \fBTcl_GetObjectNamespace\fR function. Note that the Tcl_Obj reference returned by \fBTcl_GetObjectName\fR is a shared reference. You can also get whether the object has been marked for deletion with \fBTcl_ObjectDeleted\fR (it returns true if deletion of the object has begun); this can be useful during the processing of methods. .PP Instances of classes are created using \fBTcl_NewObjectInstance\fR, which creates an object from any class (and which is internally called by both the \fBcreate\fR and \fBnew\fR methods of the \fBoo::class\fR class). It takes parameters that optionally give the name of the object and namespace to create, and which describe the arguments to pass to the class's constructor (if any). The result of the function will be either a reference to the newly created object, or NULL if the creation failed (when an error message will be left in the interpreter result). In addition, objects may be copied by using \fBTcl_CopyObjectInstance\fR which creates a copy of an object without running any constructors. .PP Note that the lifetime management of objects is handled internally within TclOO, and does not use \fBTcl_Preserve\fR. \fIIt is not safe to put a Tcl_Object handle in a C structure with a lifespan different to the object;\fR you should use the object's command name (as retrieved with \fBTcl_GetObjectName\fR) instead. It is safe to use a Tcl_Object handle for the lifespan of a call of a method on that object; handles do not become invalid while there is an outstanding call on their object (even if the only operation guaranteed to be safe on them is \fBTcl_ObjectDeleted\fR; the other operations are only guaranteed to work on non-deleted objects). .SH "OBJECT AND CLASS METADATA" .PP Every object and every class may have arbitrary amounts of metadata attached to it, which the object or class attaches no meaning to beyond what is described in a Tcl_ObjectMetadataType structure instance. Metadata to be attached is described by the type of the metadata (given in the \fImetaTypePtr\fR argument) and an arbitrary pointer (the \fImetadata\fR |
| ︙ | ︙ | |||
167 168 169 170 171 172 173 | .SS "TCL_OBJECTMETADATADELETEPROC FUNCTION SIGNATURE" .PP Functions matching this signature are used to delete metadata associated with a class or object. .PP .CS typedef void \fBTcl_ObjectMetadataDeleteProc\fR( | | | | | 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 |
.SS "TCL_OBJECTMETADATADELETEPROC FUNCTION SIGNATURE"
.PP
Functions matching this signature are used to delete metadata associated with
a class or object.
.PP
.CS
typedef void \fBTcl_ObjectMetadataDeleteProc\fR(
ClientData \fImetadata\fR);
.CE
.PP
The \fImetadata\fR argument gives the address of the metadata to be
deleted.
.SS "TCL_CLONEPROC FUNCTION SIGNATURE"
.PP
Functions matching this signature are used to create copies of metadata
associated with a class or object.
.PP
.CS
typedef int \fBTcl_CloneProc\fR(
Tcl_Interp *\fIinterp\fR,
ClientData \fIsrcMetadata\fR,
ClientData *\fIdstMetadataPtr\fR);
.CE
.PP
The \fIinterp\fR argument gives a place to write an error message when the
attempt to clone the object is to fail, in which case the clone procedure must
also return TCL_ERROR; it should return TCL_OK otherwise.
The \fIsrcMetadata\fR argument gives the address of the metadata to be cloned,
and the cloned metadata should be written into the variable pointed to by
|
| ︙ | ︙ |
Changes to doc/CrtChannel.3.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Channel \fBTcl_CreateChannel\fR(\fItypePtr, channelName, instanceData, mask\fR) .sp | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Channel \fBTcl_CreateChannel\fR(\fItypePtr, channelName, instanceData, mask\fR) .sp ClientData \fBTcl_GetChannelInstanceData\fR(\fIchannel\fR) .sp const Tcl_ChannelType * \fBTcl_GetChannelType\fR(\fIchannel\fR) .sp const char * \fBTcl_GetChannelName\fR(\fIchannel\fR) |
| ︙ | ︙ | |||
124 125 126 127 128 129 130 | can be called to perform I/O and other functions on the channel. .AP "const char" *channelName in The name of this channel, such as \fBfile3\fR; must not be in use by any other channel. Can be NULL, in which case the channel is created without a name. If the created channel is assigned to one of the standard channels (\fBstdin\fR, \fBstdout\fR or \fBstderr\fR), the assigned channel name will be the name of the standard channel. | | | | 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 | can be called to perform I/O and other functions on the channel. .AP "const char" *channelName in The name of this channel, such as \fBfile3\fR; must not be in use by any other channel. Can be NULL, in which case the channel is created without a name. If the created channel is assigned to one of the standard channels (\fBstdin\fR, \fBstdout\fR or \fBstderr\fR), the assigned channel name will be the name of the standard channel. .AP ClientData instanceData in Arbitrary one-word value to be associated with this channel. This value is passed to procedures in \fItypePtr\fR when they are invoked. .AP int mask in OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR to indicate whether a channel is readable and writable. .AP Tcl_Channel channel in The channel to operate on. .AP int direction in \fBTCL_READABLE\fR means the input handle is wanted; \fBTCL_WRITABLE\fR means the output handle is wanted. .AP ClientData *handlePtr out Points to the location where the desired OS-specific handle should be stored. .AP int size in The size, in bytes, of buffers to allocate in this channel. .AP int mask in An OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR and \fBTCL_EXCEPTION\fR that indicates events that have occurred on |
| ︙ | ︙ | |||
395 396 397 398 399 400 401 | .PP The \fIblockModeProc\fR field contains the address of a function called by the generic layer to set blocking and nonblocking mode on the device. \fIBlockModeProc\fR should match the following prototype: .PP .CS typedef int \fBTcl_DriverBlockModeProc\fR( | | | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 |
.PP
The \fIblockModeProc\fR field contains the address of a function called by
the generic layer to set blocking and nonblocking mode on the device.
\fIBlockModeProc\fR should match the following prototype:
.PP
.CS
typedef int \fBTcl_DriverBlockModeProc\fR(
ClientData \fIinstanceData\fR,
int \fImode\fR);
.CE
.PP
The \fIinstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when this channel was created. The \fImode\fR
argument is either \fBTCL_MODE_BLOCKING\fR or \fBTCL_MODE_NONBLOCKING\fR to
set the device into blocking or nonblocking mode. The function should
|
| ︙ | ︙ | |||
430 431 432 433 434 435 436 | .PP The \fIcloseProc\fR field contains the address of a function called by the generic layer to clean up driver-related information when the channel is closed. \fICloseProc\fR must match the following prototype: .PP .CS typedef int \fBTcl_DriverCloseProc\fR( | | | 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 |
.PP
The \fIcloseProc\fR field contains the address of a function called by the
generic layer to clean up driver-related information when the channel is
closed. \fICloseProc\fR must match the following prototype:
.PP
.CS
typedef int \fBTcl_DriverCloseProc\fR(
ClientData \fIinstanceData\fR,
Tcl_Interp *\fIinterp\fR);
.CE
.PP
The \fIinstanceData\fR argument is the same as the value provided to
\fBTcl_CreateChannel\fR when the channel was created. The function should
release any storage maintained by the channel driver for this channel, and
close the input and output devices encapsulated by this channel. All queued
|
| ︙ | ︙ | |||
452 453 454 455 456 457 458 | Alternatively, channels that support closing the read and write sides independently may set \fIcloseProc\fR to \fBTCL_CLOSE2PROC\fR and set \fIclose2Proc\fR to the address of a function that matches the following prototype: .PP .CS typedef int \fBTcl_DriverClose2Proc\fR( | | | 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 |
Alternatively, channels that support closing the read and write sides
independently may set \fIcloseProc\fR to \fBTCL_CLOSE2PROC\fR and set
\fIclose2Proc\fR to the address of a function that matches the
following prototype:
.PP
.CS
typedef int \fBTcl_DriverClose2Proc\fR(
ClientData \fIinstanceData\fR,
Tcl_Interp *\fIinterp\fR,
int \fIflags\fR);
.CE
.PP
The \fIclose2Proc\fR will be called with \fIflags\fR set to an OR'ed
combination of \fBTCL_CLOSE_READ\fR or \fBTCL_CLOSE_WRITE\fR to
indicate that the driver should close the read and/or write side of
|
| ︙ | ︙ | |||
483 484 485 486 487 488 489 | .PP The \fIinputProc\fR field contains the address of a function called by the generic layer to read data from the file or device and store it in an internal buffer. \fIInputProc\fR must match the following prototype: .PP .CS typedef int \fBTcl_DriverInputProc\fR( | | | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 |
.PP
The \fIinputProc\fR field contains the address of a function called by the
generic layer to read data from the file or device and store it in an
internal buffer. \fIInputProc\fR must match the following prototype:
.PP
.CS
typedef int \fBTcl_DriverInputProc\fR(
ClientData \fIinstanceData\fR,
char *\fIbuf\fR,
int \fIbufSize\fR,
int *\fIerrorCodePtr\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when the channel was created. The \fIbuf\fR
|
| ︙ | ︙ | |||
527 528 529 530 531 532 533 | .PP The \fIoutputProc\fR field contains the address of a function called by the generic layer to transfer data from an internal buffer to the output device. \fIOutputProc\fR must match the following prototype: .PP .CS typedef int \fBTcl_DriverOutputProc\fR( | | | 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 |
.PP
The \fIoutputProc\fR field contains the address of a function called by the
generic layer to transfer data from an internal buffer to the output device.
\fIOutputProc\fR must match the following prototype:
.PP
.CS
typedef int \fBTcl_DriverOutputProc\fR(
ClientData \fIinstanceData\fR,
const char *\fIbuf\fR,
int \fItoWrite\fR,
int *\fIerrorCodePtr\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when the channel was created. The \fIbuf\fR
|
| ︙ | ︙ | |||
566 567 568 569 570 571 572 | The \fIseekProc\fR field contains the address of a function called by the generic layer to move the access point at which subsequent input or output operations will be applied. \fISeekProc\fR must match the following prototype: .PP .CS typedef int \fBTcl_DriverSeekProc\fR( | | | 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 |
The \fIseekProc\fR field contains the address of a function called by the
generic layer to move the access point at which subsequent input or output
operations will be applied. \fISeekProc\fR must match the following
prototype:
.PP
.CS
typedef int \fBTcl_DriverSeekProc\fR(
ClientData \fIinstanceData\fR,
long \fIoffset\fR,
int \fIseekMode\fR,
int *\fIerrorCodePtr\fR);
.CE
.PP
The \fIinstanceData\fR argument is the same as the value given to
\fBTcl_CreateChannel\fR when this channel was created. \fIOffset\fR and
|
| ︙ | ︙ | |||
596 597 598 599 600 601 602 | within files larger than 2GB. The \fIwideSeekProc\fR will be called in preference to the \fIseekProc\fR, but both must be defined if the \fIwideSeekProc\fR is defined. \fIWideSeekProc\fR must match the following prototype: .PP .CS typedef Tcl_WideInt \fBTcl_DriverWideSeekProc\fR( | | | 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 |
within files larger than 2GB. The \fIwideSeekProc\fR will be called
in preference to the \fIseekProc\fR, but both must be defined if the
\fIwideSeekProc\fR is defined. \fIWideSeekProc\fR must match the
following prototype:
.PP
.CS
typedef Tcl_WideInt \fBTcl_DriverWideSeekProc\fR(
ClientData \fIinstanceData\fR,
Tcl_WideInt \fIoffset\fR,
int \fIseekMode\fR,
int *\fIerrorCodePtr\fR);
.CE
.PP
The arguments and return values mean the same thing as with
\fIseekProc\fR above, except that the type of offsets and the return
|
| ︙ | ︙ | |||
618 619 620 621 622 623 624 | .PP The \fIsetOptionProc\fR field contains the address of a function called by the generic layer to set a channel type specific option on a channel. \fIsetOptionProc\fR must match the following prototype: .PP .CS typedef int \fBTcl_DriverSetOptionProc\fR( | | | 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 |
.PP
The \fIsetOptionProc\fR field contains the address of a function called by
the generic layer to set a channel type specific option on a channel.
\fIsetOptionProc\fR must match the following prototype:
.PP
.CS
typedef int \fBTcl_DriverSetOptionProc\fR(
ClientData \fIinstanceData\fR,
Tcl_Interp *\fIinterp\fR,
const char *\fIoptionName\fR,
const char *\fInewValue\fR);
.CE
.PP
\fIoptionName\fR is the name of an option to set, and \fInewValue\fR is
the new value for that option, as a string. The \fIinstanceData\fR is the
|
| ︙ | ︙ | |||
644 645 646 647 648 649 650 | If the option value is successfully modified to the new value, the function returns \fBTCL_OK\fR. It should call \fBTcl_BadChannelOption\fR which itself returns \fBTCL_ERROR\fR if the \fIoptionName\fR is unrecognized. If \fInewValue\fR specifies a value for the option that is not supported or if a system call error occurs, | | | | | 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 |
If the option value is successfully modified to the new value, the function
returns \fBTCL_OK\fR.
It should call \fBTcl_BadChannelOption\fR which itself returns
\fBTCL_ERROR\fR if the \fIoptionName\fR is
unrecognized.
If \fInewValue\fR specifies a value for the option that
is not supported or if a system call error occurs,
the function should leave an error message in the result
of \fIinterp\fR if \fIinterp\fR is not NULL. The
function should also call \fBTcl_SetErrno\fR to store an appropriate POSIX
error code.
.PP
This value can be retrieved with \fBTcl_ChannelSetOptionProc\fR, which returns
a pointer to the function.
.SS GETOPTIONPROC
.PP
The \fIgetOptionProc\fR field contains the address of a function called by
the generic layer to get the value of a channel type specific option on a
channel. \fIgetOptionProc\fR must match the following prototype:
.PP
.CS
typedef int \fBTcl_DriverGetOptionProc\fR(
ClientData \fIinstanceData\fR,
Tcl_Interp *\fIinterp\fR,
const char *\fIoptionName\fR,
Tcl_DString *\fIoptionValue\fR);
.CE
.PP
\fIOptionName\fR is the name of an option supported by this type of
channel. If the option name is not NULL, the function stores its current
|
| ︙ | ︙ | |||
697 698 699 700 701 702 703 | The \fIwatchProc\fR field contains the address of a function called by the generic layer to initialize the event notification mechanism to notice events of interest on this channel. \fIWatchProc\fR should match the following prototype: .PP .CS typedef void \fBTcl_DriverWatchProc\fR( | | | 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 |
The \fIwatchProc\fR field contains the address of a function called
by the generic layer to initialize the event notification mechanism to
notice events of interest on this channel.
\fIWatchProc\fR should match the following prototype:
.PP
.CS
typedef void \fBTcl_DriverWatchProc\fR(
ClientData \fIinstanceData\fR,
int \fImask\fR);
.CE
.PP
The \fIinstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when this channel was created. The \fImask\fR
argument is an OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR
and \fBTCL_EXCEPTION\fR; it indicates events the caller is interested in
|
| ︙ | ︙ | |||
728 729 730 731 732 733 734 | .PP The \fIgetHandleProc\fR field contains the address of a function called by the generic layer to retrieve a device-specific handle from the channel. \fIGetHandleProc\fR should match the following prototype: .PP .CS typedef int \fBTcl_DriverGetHandleProc\fR( | | | | 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 |
.PP
The \fIgetHandleProc\fR field contains the address of a function called by
the generic layer to retrieve a device-specific handle from the channel.
\fIGetHandleProc\fR should match the following prototype:
.PP
.CS
typedef int \fBTcl_DriverGetHandleProc\fR(
ClientData \fIinstanceData\fR,
int \fIdirection\fR,
ClientData *\fIhandlePtr\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when this channel was created. The \fIdirection\fR
argument is either \fBTCL_READABLE\fR to retrieve the handle used
for input, or \fBTCL_WRITABLE\fR to retrieve the handle used for
output.
|
| ︙ | ︙ | |||
757 758 759 760 761 762 763 | .PP The \fIflushProc\fR field is currently reserved for future use. It should be set to NULL. \fIFlushProc\fR should match the following prototype: .PP .CS typedef int \fBTcl_DriverFlushProc\fR( | | | | 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 |
.PP
The \fIflushProc\fR field is currently reserved for future use.
It should be set to NULL.
\fIFlushProc\fR should match the following prototype:
.PP
.CS
typedef int \fBTcl_DriverFlushProc\fR(
ClientData \fIinstanceData\fR);
.CE
.PP
This value can be retrieved with \fBTcl_ChannelFlushProc\fR, which returns
a pointer to the function.
.SS HANDLERPROC
.PP
The \fIhandlerProc\fR field contains the address of a function called by
the generic layer to notify the channel that an event occurred. It should
be defined for stacked channel drivers that wish to be notified of events
that occur on the underlying (stacked) channel.
\fIHandlerProc\fR should match the following prototype:
.PP
.CS
typedef int \fBTcl_DriverHandlerProc\fR(
ClientData \fIinstanceData\fR,
int \fIinterestMask\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to \fBTcl_CreateChannel\fR
when this channel was created. The \fIinterestMask\fR is an OR-ed
combination of \fBTCL_READABLE\fR or \fBTCL_WRITABLE\fR; it indicates what
type of event occurred on this channel.
|
| ︙ | ︙ | |||
801 802 803 804 805 806 807 | The action \fITCL_CHANNEL_THREAD_INSERT\fR is used to notify the driver that it should update or initialize any thread-specific data it might be maintaining using the calling thread as the associate. See \fBTcl_CutChannel\fR and \fBTcl_SpliceChannel\fR for more detail. .PP .CS typedef void \fBTcl_DriverThreadActionProc\fR( | | | | 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 |
The action \fITCL_CHANNEL_THREAD_INSERT\fR is used to notify the
driver that it should update or initialize any thread-specific data it
might be maintaining using the calling thread as the associate. See
\fBTcl_CutChannel\fR and \fBTcl_SpliceChannel\fR for more detail.
.PP
.CS
typedef void \fBTcl_DriverThreadActionProc\fR(
ClientData \fIinstanceData\fR,
int \fIaction\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when this channel was created.
.PP
These values can be retrieved with \fBTcl_ChannelThreadActionProc\fR,
which returns a pointer to the function.
.SS "TRUNCATEPROC"
.PP
The \fItruncateProc\fR field contains the address of the function
called by the generic layer when a channel is truncated to some
length. It can be NULL.
.PP
.CS
typedef int \fBTcl_DriverTruncateProc\fR(
ClientData \fIinstanceData\fR,
Tcl_WideInt \fIlength\fR);
.CE
.PP
\fIInstanceData\fR is the same as the value passed to
\fBTcl_CreateChannel\fR when this channel was created, and
\fIlength\fR is the new length of the underlying file, which should
not be negative. The result should be 0 on success or an errno code
|
| ︙ | ︙ |
Changes to doc/CrtChnlHdlr.3.
| ︙ | ︙ | |||
28 29 30 31 32 33 34 | .AP int mask in Conditions under which \fIproc\fR should be called: OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR and \fBTCL_EXCEPTION\fR. Specify a zero value to temporarily disable an existing handler. .AP Tcl_FileProc *proc in Procedure to invoke whenever the channel indicated by \fIchannel\fR meets the conditions specified by \fImask\fR. | | | | 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 |
.AP int mask in
Conditions under which \fIproc\fR should be called: OR-ed combination of
\fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR and \fBTCL_EXCEPTION\fR. Specify
a zero value to temporarily disable an existing handler.
.AP Tcl_FileProc *proc in
Procedure to invoke whenever the channel indicated by \fIchannel\fR meets
the conditions specified by \fImask\fR.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR.
.BE
.SH DESCRIPTION
.PP
\fBTcl_CreateChannelHandler\fR arranges for \fIproc\fR to be called in the
future whenever input or output becomes possible on the channel identified
by \fIchannel\fR, or whenever an exceptional condition exists for
\fIchannel\fR. The conditions of interest under which \fIproc\fR will be
invoked are specified by the \fImask\fR argument.
See the manual entry for \fBfileevent\fR for a precise description of
what it means for a channel to be readable or writable.
\fIProc\fR must conform to the following prototype:
.PP
.CS
typedef void \fBTcl_ChannelProc\fR(
ClientData \fIclientData\fR,
int \fImask\fR);
.CE
.PP
The \fIclientData\fR argument is the same as the value passed to
\fBTcl_CreateChannelHandler\fR when the handler was created. Typically,
\fIclientData\fR points to a data structure containing application-specific
information about the channel. \fIMask\fR is an integer mask indicating
|
| ︙ | ︙ |
Changes to doc/CrtCloseHdlr.3.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 | .sp .SH ARGUMENTS .AS Tcl_CloseProc clientData .AP Tcl_Channel channel in The channel for which to create or delete a close callback. .AP Tcl_CloseProc *proc in The procedure to call as the callback. | | | | 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 |
.sp
.SH ARGUMENTS
.AS Tcl_CloseProc clientData
.AP Tcl_Channel channel in
The channel for which to create or delete a close callback.
.AP Tcl_CloseProc *proc in
The procedure to call as the callback.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR.
.BE
.SH DESCRIPTION
.PP
\fBTcl_CreateCloseHandler\fR arranges for \fIproc\fR to be called when
\fIchannel\fR is closed with \fBTcl_Close\fR or
\fBTcl_UnregisterChannel\fR, or using the Tcl \fBclose\fR command.
\fIProc\fR should match the following prototype:
.PP
.CS
typedef void \fBTcl_CloseProc\fR(
ClientData \fIclientData\fR);
.CE
.PP
The \fIclientData\fR is the same as the value provided in the call to
\fBTcl_CreateCloseHandler\fR.
.PP
\fBTcl_DeleteCloseHandler\fR removes a close callback for \fIchannel\fR.
The \fIproc\fR and \fIclientData\fR identify which close callback to
|
| ︙ | ︙ |
Changes to doc/CrtCommand.3.
| ︙ | ︙ | |||
21 22 23 24 25 26 27 | .AP Tcl_Interp *interp in Interpreter in which to create new command. .AP "const char" *cmdName in Name of command. .AP Tcl_CmdProc *proc in Implementation of new command: \fIproc\fR will be called whenever \fIcmdName\fR is invoked as a command. | | | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | .AP Tcl_Interp *interp in Interpreter in which to create new command. .AP "const char" *cmdName in Name of command. .AP Tcl_CmdProc *proc in Implementation of new command: \fIproc\fR will be called whenever \fIcmdName\fR is invoked as a command. .AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR and \fIdeleteProc\fR. .AP Tcl_CmdDeleteProc *deleteProc in Procedure to call before \fIcmdName\fR is deleted from the interpreter; allows for command-specific cleanup. If NULL, then no procedure is called before the command is deleted. .BE .SH DESCRIPTION |
| ︙ | ︙ | |||
71 72 73 74 75 76 77 | the process of being deleted, then it does not create a new command and it returns NULL. \fIProc\fR should have arguments and result that match the type \fBTcl_CmdProc\fR: .PP .CS typedef int \fBTcl_CmdProc\fR( | | | 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 |
the process of being deleted, then it does not create a new command
and it returns NULL.
\fIProc\fR should have arguments and result that match the type
\fBTcl_CmdProc\fR:
.PP
.CS
typedef int \fBTcl_CmdProc\fR(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
int \fIargc\fR,
const char *\fIargv\fR[]);
.CE
.PP
When \fIproc\fR is invoked the \fIclientData\fR and \fIinterp\fR
parameters will be copies of the \fIclientData\fR and \fIinterp\fR
|
| ︙ | ︙ | |||
127 128 129 130 131 132 133 | \fIDeleteProc\fR is invoked before the command is deleted, and gives the application an opportunity to release any structures associated with the command. \fIDeleteProc\fR should have arguments and result that match the type \fBTcl_CmdDeleteProc\fR: .PP .CS typedef void \fBTcl_CmdDeleteProc\fR( | | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 |
\fIDeleteProc\fR is invoked before the command is deleted, and gives the
application an opportunity to release any structures associated
with the command. \fIDeleteProc\fR should have arguments and
result that match the type \fBTcl_CmdDeleteProc\fR:
.PP
.CS
typedef void \fBTcl_CmdDeleteProc\fR(
ClientData \fIclientData\fR);
.CE
.PP
The \fIclientData\fR argument will be the same as the \fIclientData\fR
argument passed to \fBTcl_CreateCommand\fR.
.SH "SEE ALSO"
Tcl_CreateObjCommand, Tcl_DeleteCommand, Tcl_GetCommandInfo,
Tcl_SetCommandInfo, Tcl_GetCommandName, Tcl_SetObjResult
.SH KEYWORDS
bind, command, create, delete, interpreter, namespace
|
Changes to doc/CrtFileHdlr.3.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | Conditions under which \fIproc\fR should be called: OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR, and \fBTCL_EXCEPTION\fR. May be set to 0 to temporarily disable a handler. .AP Tcl_FileProc *proc in Procedure to invoke whenever the file or device indicated by \fIfile\fR meets the conditions specified by \fImask\fR. | | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | Conditions under which \fIproc\fR should be called: OR-ed combination of \fBTCL_READABLE\fR, \fBTCL_WRITABLE\fR, and \fBTCL_EXCEPTION\fR. May be set to 0 to temporarily disable a handler. .AP Tcl_FileProc *proc in Procedure to invoke whenever the file or device indicated by \fIfile\fR meets the conditions specified by \fImask\fR. .AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION .PP \fBTcl_CreateFileHandler\fR arranges for \fIproc\fR to be invoked in the future whenever I/O becomes possible on a file or an exceptional condition exists for the file. The file |
| ︙ | ︙ | |||
47 48 49 50 51 52 53 | as \fBvwait\fR. .PP \fIProc\fR should have arguments and result that match the type \fBTcl_FileProc\fR: .PP .CS typedef void \fBTcl_FileProc\fR( | | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
as \fBvwait\fR.
.PP
\fIProc\fR should have arguments and result that match the
type \fBTcl_FileProc\fR:
.PP
.CS
typedef void \fBTcl_FileProc\fR(
ClientData \fIclientData\fR,
int \fImask\fR);
.CE
.PP
The \fIclientData\fR parameter to \fIproc\fR is a copy
of the \fIclientData\fR
argument given to \fBTcl_CreateFileHandler\fR when the callback
was created. Typically, \fIclientData\fR points to a data
|
| ︙ | ︙ |
Changes to doc/CrtInterp.3.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 | \fBTcl_CreateInterp\fR() .sp \fBTcl_DeleteInterp\fR(\fIinterp\fR) .sp int \fBTcl_InterpDeleted\fR(\fIinterp\fR) .sp | < < | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | \fBTcl_CreateInterp\fR() .sp \fBTcl_DeleteInterp\fR(\fIinterp\fR) .sp int \fBTcl_InterpDeleted\fR(\fIinterp\fR) .sp int \fBTcl_InterpActive\fR(\fIinterp\fR) .SH ARGUMENTS .AS Tcl_Interp *interp .AP Tcl_Interp *interp in Token for interpreter to be destroyed or queried. .BE .SH DESCRIPTION .PP |
| ︙ | ︙ | |||
66 67 68 69 70 71 72 | .PP \fBTcl_InterpDeleted\fR is useful in deletion callbacks to distinguish between when only the memory the callback is responsible for is being deleted and when the whole interpreter is being deleted. In the former case the callback may recreate the data being deleted, but this would lead to an infinite loop if the interpreter were being deleted. .PP | < < | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | .PP \fBTcl_InterpDeleted\fR is useful in deletion callbacks to distinguish between when only the memory the callback is responsible for is being deleted and when the whole interpreter is being deleted. In the former case the callback may recreate the data being deleted, but this would lead to an infinite loop if the interpreter were being deleted. .PP \fBTcl_InterpActive\fR is useful for determining whether there is any execution of scripts ongoing in an interpreter, which is a useful piece of information when Tcl is embedded in a garbage-collected environment and it becomes necessary to determine whether the interpreter is a candidate for deletion. The function returns a true value if the interpreter has at least one active execution running inside it, and a false value otherwise. .SH "INTERPRETERS AND MEMORY MANAGEMENT" .PP \fBTcl_DeleteInterp\fR can be called at any time on an interpreter that may be used by nested evaluations and C code in various extensions. Tcl implements a simple mechanism that allows callers to use interpreters without worrying about the interpreter being deleted in a nested call, and without requiring special code to protect the interpreter, in most cases. |
| ︙ | ︙ | |||
134 135 136 137 138 139 140 | interpreter that has been freed and whose memory may already have been reused. .PP All uses of interpreters in Tcl and Tk have already been protected. Extension writers should ensure that their code also properly protects any additional interpreters used, as described above. .PP | < < | 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 | interpreter that has been freed and whose memory may already have been reused. .PP All uses of interpreters in Tcl and Tk have already been protected. Extension writers should ensure that their code also properly protects any additional interpreters used, as described above. .PP Note that the protection mechanisms do not work well with conventional garbage collection systems. When in such a managed environment, \fBTcl_InterpActive\fR should be used to determine when an interpreter is a candidate for deletion due to inactivity. .SH "SEE ALSO" Tcl_Preserve(3), Tcl_Release(3) .SH KEYWORDS command, create, delete, interpreter |
Added doc/CrtMathFnc.3.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 |
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH Tcl_CreateMathFunc 3 8.4 Tcl "Tcl Library Procedures"
.so man.macros
.BS
.SH NAME
Tcl_CreateMathFunc, Tcl_GetMathFuncInfo, Tcl_ListMathFuncs \- Define, query and enumerate math functions for expressions
.SH "NOTICE OF EVENTUAL DEPRECATION"
.PP
The \fBTcl_CreateMathFunc\fR and \fBTcl_GetMathFuncInfo\fR functions
are rendered somewhat obsolete by the ability to create functions for
expressions by placing commands in the \fBtcl::mathfunc\fR namespace,
as described in the \fBmathfunc\fR manual page; the API described on
this page is not expected to be maintained indefinitely.
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
void
\fBTcl_CreateMathFunc\fR(\fIinterp, name, numArgs, argTypes, proc, clientData\fR)
.sp
int
\fBTcl_GetMathFuncInfo\fR(\fIinterp, name, numArgsPtr, argTypesPtr, procPtr,
clientDataPtr\fR)
.sp
Tcl_Obj *
\fBTcl_ListMathFuncs\fR(\fIinterp, pattern\fR)
.SH ARGUMENTS
.AS Tcl_ValueType *clientDataPtr out
.AP Tcl_Interp *interp in
Interpreter in which new function will be defined.
.AP "const char" *name in
Name for new function.
.AP int numArgs in
Number of arguments to new function; also gives size of \fIargTypes\fR array.
.AP Tcl_ValueType *argTypes in
Points to an array giving the permissible types for each argument to
function.
.AP Tcl_MathProc *proc in
Procedure that implements the function.
.AP ClientData clientData in
Arbitrary one-word value to pass to \fIproc\fR when it is invoked.
.AP int *numArgsPtr out
Points to a variable that will be set to contain the number of
arguments to the function.
.AP Tcl_ValueType **argTypesPtr out
Points to a variable that will be set to contain a pointer to an array
giving the permissible types for each argument to the function which
will need to be freed up using \fITcl_Free\fR.
.AP Tcl_MathProc **procPtr out
Points to a variable that will be set to contain a pointer to the
implementation code for the function (or NULL if the function is
implemented directly in bytecode).
.AP ClientData *clientDataPtr out
Points to a variable that will be set to contain the clientData
argument passed to \fITcl_CreateMathFunc\fR when the function was
created if the function is not implemented directly in bytecode.
.AP "const char" *pattern in
Pattern to match against function names so as to filter them (by
passing to \fITcl_StringMatch\fR), or NULL to not apply any filter.
.BE
.SH DESCRIPTION
.PP
Tcl allows a number of mathematical functions to be used in
expressions, such as \fBsin\fR, \fBcos\fR, and \fBhypot\fR.
These functions are represented by commands in the namespace,
\fBtcl::mathfunc\fR. The \fBTcl_CreateMathFunc\fR function is
an obsolete way for applications to add additional functions
to those already provided by Tcl or to replace existing functions.
It should not be used by new applications, which should create
math functions using \fBTcl_CreateObjCommand\fR to create a command
in the \fBtcl::mathfunc\fR namespace.
.PP
In the \fBTcl_CreateMathFunc\fR interface,
\fIName\fR is the name of the function as it will appear in expressions.
If \fIname\fR does not already exist in the \fB::tcl::mathfunc\fR
namespace, then a new command is created in that namespace.
If \fIname\fR does exist, then the existing function is replaced.
\fINumArgs\fR and \fIargTypes\fR describe the arguments to the function.
Each entry in the \fIargTypes\fR array must be
one of \fBTCL_INT\fR, \fBTCL_DOUBLE\fR, \fBTCL_WIDE_INT\fR,
or \fBTCL_EITHER\fR to indicate whether the corresponding argument must be an
integer, a double-precision floating value, a wide (64-bit) integer,
or any, respectively.
.PP
Whenever the function is invoked in an expression Tcl will invoke
\fIproc\fR. \fIProc\fR should have arguments and result that match
the type \fBTcl_MathProc\fR:
.PP
.CS
typedef int \fBTcl_MathProc\fR(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
Tcl_Value *\fIargs\fR,
Tcl_Value *\fIresultPtr\fR);
.CE
.PP
When \fIproc\fR is invoked the \fIclientData\fR and \fIinterp\fR
arguments will be the same as those passed to \fBTcl_CreateMathFunc\fR.
\fIArgs\fR will point to an array of \fInumArgs\fR Tcl_Value structures,
which describe the actual arguments to the function:
.PP
.CS
typedef struct Tcl_Value {
Tcl_ValueType \fItype\fR;
long \fIintValue\fR;
double \fIdoubleValue\fR;
Tcl_WideInt \fIwideValue\fR;
} \fBTcl_Value\fR;
.CE
.PP
The \fItype\fR field indicates the type of the argument and is
one of \fBTCL_INT\fR, \fBTCL_DOUBLE\fR or \fBTCL_WIDE_INT\fR.
It will match the \fIargTypes\fR value specified for the function unless
the \fIargTypes\fR value was \fBTCL_EITHER\fR. Tcl converts
the argument supplied in the expression to the type requested in
\fIargTypes\fR, if that is necessary.
Depending on the value of the \fItype\fR field, the \fIintValue\fR,
\fIdoubleValue\fR or \fIwideValue\fR
field will contain the actual value of the argument.
.PP
\fIProc\fR should compute its result and store it either as an integer
in \fIresultPtr->intValue\fR or as a floating value in
\fIresultPtr->doubleValue\fR.
It should set also \fIresultPtr->type\fR to one of
\fBTCL_INT\fR, \fBTCL_DOUBLE\fR or \fBTCL_WIDE_INT\fR
to indicate which value was set.
Under normal circumstances \fIproc\fR should return \fBTCL_OK\fR.
If an error occurs while executing the function, \fIproc\fR should
return \fBTCL_ERROR\fR and leave an error message in the interpreter's result.
.PP
\fBTcl_GetMathFuncInfo\fR retrieves the values associated with
function \fIname\fR that were passed to a preceding
\fBTcl_CreateMathFunc\fR call. Normally, the return code is
\fBTCL_OK\fR but if the named function does not exist, \fBTCL_ERROR\fR
is returned and an error message is placed in the interpreter's
result.
.PP
If an error did not occur, the array reference placed in the variable
pointed to by \fIargTypesPtr\fR is newly allocated, and should be
released by passing it to \fBTcl_Free\fR. Some functions (the
standard set implemented in the core, and those defined by placing
commands in the \fBtcl::mathfunc\fR namespace) do not have
argument type information; attempting to retrieve values for
them causes a NULL to be stored in the variable pointed to by
\fIprocPtr\fR and the variable pointed to by \fIclientDataPtr\fR
will not be modified. The variable pointed to by \fInumArgsPointer\fR
will contain -1, and no argument types will be stored in the variable
pointed to by \fIargTypesPointer\fR.
.PP
\fBTcl_ListMathFuncs\fR returns a Tcl value containing a list of all
the math functions defined in the interpreter whose name matches
\fIpattern\fR. The returned value has a reference count of zero.
.SH "SEE ALSO"
expr(n), info(n), Tcl_CreateObjCommand(3), Tcl_Free(3), Tcl_NewListObj(3)
.SH KEYWORDS
expression, mathematical function
|
Changes to doc/CrtObjCmd.3.
| ︙ | ︙ | |||
55 56 57 58 59 60 61 | .AP Tcl_Interp *interp in Interpreter in which to create a new command or that contains a command. .AP char *cmdName in Name of command. .AP Tcl_ObjCmdProc *proc in Implementation of the new command: \fIproc\fR will be called whenever \fIcmdName\fR is invoked as a command. | | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | .AP Tcl_Interp *interp in Interpreter in which to create a new command or that contains a command. .AP char *cmdName in Name of command. .AP Tcl_ObjCmdProc *proc in Implementation of the new command: \fIproc\fR will be called whenever \fIcmdName\fR is invoked as a command. .AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR and \fIdeleteProc\fR. .AP Tcl_CmdDeleteProc *deleteProc in Procedure to call before \fIcmdName\fR is deleted from the interpreter; allows for command-specific cleanup. If NULL, then no procedure is called before the command is deleted. .AP Tcl_Command token in Token for command, returned by previous call to \fBTcl_CreateObjCommand\fR. |
| ︙ | ︙ | |||
98 99 100 101 102 103 104 | the process of being deleted, then it does not create a new command and it returns NULL. \fIproc\fR should have arguments and result that match the type \fBTcl_ObjCmdProc\fR: .PP .CS typedef int \fBTcl_ObjCmdProc\fR( | | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 |
the process of being deleted, then it does not create a new command
and it returns NULL.
\fIproc\fR should have arguments and result that match the type
\fBTcl_ObjCmdProc\fR:
.PP
.CS
typedef int \fBTcl_ObjCmdProc\fR(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
int \fIobjc\fR,
Tcl_Obj *const \fIobjv\fR[]);
.CE
.PP
When \fIproc\fR is invoked, the \fIclientData\fR and \fIinterp\fR parameters
will be copies of the \fIclientData\fR and \fIinterp\fR arguments given to
|
| ︙ | ︙ | |||
171 172 173 174 175 176 177 | \fIDeleteProc\fR is invoked before the command is deleted, and gives the application an opportunity to release any structures associated with the command. \fIDeleteProc\fR should have arguments and result that match the type \fBTcl_CmdDeleteProc\fR: .PP .CS typedef void \fBTcl_CmdDeleteProc\fR( | | | 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 |
\fIDeleteProc\fR is invoked before the command is deleted, and gives the
application an opportunity to release any structures associated
with the command. \fIDeleteProc\fR should have arguments and
result that match the type \fBTcl_CmdDeleteProc\fR:
.PP
.CS
typedef void \fBTcl_CmdDeleteProc\fR(
ClientData \fIclientData\fR);
.CE
.PP
The \fIclientData\fR argument will be the same as the \fIclientData\fR
argument passed to \fBTcl_CreateObjCommand\fR.
.PP
\fBTcl_DeleteCommand\fR deletes a command from a command interpreter.
Once the call completes, attempts to invoke \fIcmdName\fR in
|
| ︙ | ︙ | |||
213 214 215 216 217 218 219 |
pointed to by \fIinfoPtr\fR and returns 1.
A \fBTcl_CmdInfo\fR structure has the following fields:
.PP
.CS
typedef struct Tcl_CmdInfo {
int \fIisNativeObjectProc\fR;
Tcl_ObjCmdProc *\fIobjProc\fR;
| | | | | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 |
pointed to by \fIinfoPtr\fR and returns 1.
A \fBTcl_CmdInfo\fR structure has the following fields:
.PP
.CS
typedef struct Tcl_CmdInfo {
int \fIisNativeObjectProc\fR;
Tcl_ObjCmdProc *\fIobjProc\fR;
ClientData \fIobjClientData\fR;
Tcl_CmdProc *\fIproc\fR;
ClientData \fIclientData\fR;
Tcl_CmdDeleteProc *\fIdeleteProc\fR;
ClientData \fIdeleteData\fR;
Tcl_Namespace *\fInamespacePtr\fR;
} \fBTcl_CmdInfo\fR;
.CE
.PP
The \fIisNativeObjectProc\fR field has the value 1
if \fBTcl_CreateObjCommand\fR was called to register the command;
it is 0 if only \fBTcl_CreateCommand\fR was called.
|
| ︙ | ︙ | |||
243 244 245 246 247 248 249 | that implements the command. If \fBTcl_CreateCommand\fR was called for this command, this is the procedure passed to it; otherwise, this is a compatibility procedure registered by \fBTcl_CreateObjCommand\fR that simply calls the command's value-based procedure after converting its string arguments to Tcl values. | | | | | | 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 | that implements the command. If \fBTcl_CreateCommand\fR was called for this command, this is the procedure passed to it; otherwise, this is a compatibility procedure registered by \fBTcl_CreateObjCommand\fR that simply calls the command's value-based procedure after converting its string arguments to Tcl values. The field \fIdeleteData\fR is the ClientData value to pass to \fIdeleteProc\fR; it is normally the same as \fIclientData\fR but may be set independently using the \fBTcl_SetCommandInfo\fR procedure. The field \fInamespacePtr\fR holds a pointer to the Tcl_Namespace that contains the command. .PP \fBTcl_GetCommandInfoFromToken\fR is identical to \fBTcl_GetCommandInfo\fR except that it uses a command token returned from \fBTcl_CreateObjCommand\fR in place of the command name. If the \fItoken\fR parameter is NULL, it returns 0; otherwise, it returns 1 and fills in the structure designated by \fIinfoPtr\fR. .PP \fBTcl_SetCommandInfo\fR is used to modify the procedures and ClientData values associated with a command. Its \fIcmdName\fR argument is the name of a command in \fIinterp\fR. \fIcmdName\fR may include \fB::\fR namespace qualifiers to identify a command in a particular namespace. If this command does not exist then \fBTcl_SetCommandInfo\fR returns 0. Otherwise, it copies the information from \fI*infoPtr\fR to Tcl's internal structure for the command and returns 1. .PP \fBTcl_SetCommandInfoFromToken\fR is identical to \fBTcl_SetCommandInfo\fR except that it takes a command token as returned by \fBTcl_CreateObjCommand\fR instead of the command name. If the \fItoken\fR parameter is NULL, it returns 0. Otherwise, it copies the information from \fI*infoPtr\fR to Tcl's internal structure for the command and returns 1. .PP Note that \fBTcl_SetCommandInfo\fR and \fBTcl_SetCommandInfoFromToken\fR both allow the ClientData for a command's deletion procedure to be given a different value than the ClientData for its command procedure. .PP Note that neither \fBTcl_SetCommandInfo\fR nor \fBTcl_SetCommandInfoFromToken\fR will change a command's namespace. Use \fBTcl_Eval\fR to call the \fBrename\fR command to do that. .PP \fBTcl_GetCommandName\fR provides a mechanism for tracking commands that have been renamed. |
| ︙ | ︙ |
Changes to doc/CrtSlave.3.
| ︙ | ︙ | |||
115 116 117 118 119 120 121 | .PP These procedures are intended for access to the multiple interpreter 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 | | | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | .PP These procedures are intended for access to the multiple interpreter 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_CreateSlave\fR creates a new interpreter as a slave of \fIinterp\fR. It also creates a slave command named \fIslaveName\fR in \fIinterp\fR which allows \fIinterp\fR to manipulate the new slave. If \fIisSafe\fR is zero, the command creates a trusted slave in which Tcl code has access to all the Tcl commands. If it is \fB1\fR, the command creates a |
| ︙ | ︙ | |||
154 155 156 157 158 159 160 | \fIinterp\fR. The slave interpreter is identified by \fIslaveName\fR. If no such slave interpreter exists, \fBNULL\fR is returned. .PP \fBTcl_GetMaster\fR returns a pointer to the master interpreter of \fIinterp\fR. If \fIinterp\fR has no master (it is a top-level interpreter) then \fBNULL\fR is returned. .PP | | | | | | 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 | \fIinterp\fR. The slave interpreter is identified by \fIslaveName\fR. If no such slave interpreter exists, \fBNULL\fR is returned. .PP \fBTcl_GetMaster\fR returns a pointer to the master interpreter of \fIinterp\fR. If \fIinterp\fR has no master (it is a top-level interpreter) then \fBNULL\fR is returned. .PP \fBTcl_GetInterpPath\fR stores in the result of \fIaskingInterp\fR the relative path between \fIaskingInterp\fR and \fIslaveInterp\fR; \fIslaveInterp\fR must be a slave of \fIaskingInterp\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 \fIaskingInterp\fR. .PP \fBTcl_CreateAlias\fR creates a command named \fIslaveCmd\fR in \fIslaveInterp\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 \fIslaveCmd\fR and passed to \fItargetCmd\fR. This operation returns \fBTCL_OK\fR if it succeeds, or \fBTCL_ERROR\fR if |
| ︙ | ︙ | |||
194 195 196 197 198 199 200 | strings. .PP \fBTcl_ExposeCommand\fR moves the command named \fIhiddenCmdName\fR from the set of hidden commands to the set of exposed commands, putting it under the name \fIcmdName\fR. \fIHiddenCmdName\fR must be the name of an existing hidden | | | | | | | | | | | | | | 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 | strings. .PP \fBTcl_ExposeCommand\fR moves the command named \fIhiddenCmdName\fR from the set of hidden commands to the set of exposed commands, putting it under the name \fIcmdName\fR. \fIHiddenCmdName\fR must be the name of an existing hidden command, or the operation will return \fBTCL_ERROR\fR and leave an error message as the result of \fIinterp\fR. If an exposed command named \fIcmdName\fR already exists, the operation returns \fBTCL_ERROR\fR and leaves an error message as the result of \fIinterp\fR. If the operation succeeds, it returns \fBTCL_OK\fR. After executing this command, attempts to use \fIcmdName\fR in any script evaluation mechanism will again succeed. .PP \fBTcl_HideCommand\fR moves the command named \fIcmdName\fR from the set of exposed commands to the set of hidden commands, under the name \fIhiddenCmdName\fR. \fICmdName\fR must be the name of an existing exposed command, or the operation will return \fBTCL_ERROR\fR and leave an error message as the result of \fIinterp\fR. Currently both \fIcmdName\fR and \fIhiddenCmdName\fR must not contain namespace qualifiers, or the operation will return \fBTCL_ERROR\fR and leave an error message as the result of \fIinterp\fR. The \fICmdName\fR will be looked up in the global namespace, and not relative to the current namespace, even if the current namespace is not the global one. If a hidden command whose name is \fIhiddenCmdName\fR already exists, the operation also returns \fBTCL_ERROR\fR and an error message is left as the result of \fIinterp\fR. If the operation succeeds, it returns \fBTCL_OK\fR. After executing this command, attempts to use \fIcmdName\fR in any script evaluation mechanism will fail. .PP 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, master, slave |
Changes to doc/CrtTimerHdlr.3.
| ︙ | ︙ | |||
20 21 22 23 24 25 26 | \fBTcl_DeleteTimerHandler\fR(\fItoken\fR) .SH ARGUMENTS .AS Tcl_TimerToken milliseconds .AP int milliseconds in How many milliseconds to wait before invoking \fIproc\fR. .AP Tcl_TimerProc *proc in Procedure to invoke after \fImilliseconds\fR have elapsed. | | | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | \fBTcl_DeleteTimerHandler\fR(\fItoken\fR) .SH ARGUMENTS .AS Tcl_TimerToken milliseconds .AP int milliseconds in How many milliseconds to wait before invoking \fIproc\fR. .AP Tcl_TimerProc *proc in Procedure to invoke after \fImilliseconds\fR have elapsed. .AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .AP Tcl_TimerToken token in Token for previously created timer handler (the return value from some previous call to \fBTcl_CreateTimerHandler\fR). .BE .SH DESCRIPTION .PP |
| ︙ | ︙ | |||
47 48 49 50 51 52 53 | \fIproc\fR, then the call to \fIproc\fR will be delayed. .PP \fIProc\fR should have arguments and return value that match the type \fBTcl_TimerProc\fR: .PP .CS typedef void \fBTcl_TimerProc\fR( | | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
\fIproc\fR, then the call to \fIproc\fR will be delayed.
.PP
\fIProc\fR should have arguments and return value that match
the type \fBTcl_TimerProc\fR:
.PP
.CS
typedef void \fBTcl_TimerProc\fR(
ClientData \fIclientData\fR);
.CE
.PP
The \fIclientData\fR parameter to \fIproc\fR is a
copy of the \fIclientData\fR argument given to
\fBTcl_CreateTimerHandler\fR when the callback
was created. Typically, \fIclientData\fR points to a data
structure containing application-specific information about
|
| ︙ | ︙ |
Changes to doc/CrtTrace.3.
| ︙ | ︙ | |||
37 38 39 40 41 42 43 | Flags governing the trace execution. See below for details. .AP Tcl_CmdObjTraceProc *objProc in Procedure to call for each command that is executed. See below for details of the calling sequence. .AP Tcl_CmdTraceProc *proc in Procedure to call for each command that is executed. See below for details on the calling sequence. | | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | Flags governing the trace execution. See below for details. .AP Tcl_CmdObjTraceProc *objProc in Procedure to call for each command that is executed. See below for details of the calling sequence. .AP Tcl_CmdTraceProc *proc in Procedure to call for each command that is executed. See below for details on the calling sequence. .AP ClientData clientData in Arbitrary one-word value to pass to \fIobjProc\fR or \fIproc\fR. .AP Tcl_CmdObjTraceDeleteProc *deleteProc in Procedure to call when the trace is deleted. See below for details of the calling sequence. A NULL pointer is permissible and results in no callback when the trace is deleted. .AP Tcl_Trace trace in Token for trace to be removed (return value from previous call |
| ︙ | ︙ | |||
62 63 64 65 66 67 68 | interpreter. .PP \fIobjProc\fR should have arguments and result that match the type, \fBTcl_CmdObjTraceProc\fR: .PP .CS typedef int \fBTcl_CmdObjTraceProc\fR( | | | | 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 |
interpreter.
.PP
\fIobjProc\fR should have arguments and result that match the type,
\fBTcl_CmdObjTraceProc\fR:
.PP
.CS
typedef int \fBTcl_CmdObjTraceProc\fR(
\fBClientData\fR \fIclientData\fR,
\fBTcl_Interp\fR* \fIinterp\fR,
int \fIlevel\fR,
const char *\fIcommand\fR,
\fBTcl_Command\fR \fIcommandToken\fR,
int \fIobjc\fR,
\fBTcl_Obj\fR *const \fIobjv\fR[]);
.CE
.PP
The \fIclientData\fR and \fIinterp\fR parameters are copies of the
corresponding arguments given to \fBTcl_CreateTrace\fR.
\fIClientData\fR typically points to an application-specific data
structure that describes what to do when \fIobjProc\fR is invoked. The
\fIlevel\fR parameter gives the nesting level of the command (1 for
top-level commands passed to \fBTcl_Eval\fR by the application, 2 for
the next-level commands passed to \fBTcl_Eval\fR as part of parsing or
interpreting level-1 commands, and so on). The \fIcommand\fR parameter
points to a string containing the text of the command, before any
argument substitution. The \fIcommandToken\fR parameter is a Tcl
|
| ︙ | ︙ | |||
140 141 142 143 144 145 146 | When \fBTcl_DeleteTrace\fR is called, the interpreter invokes the \fIdeleteProc\fR that was passed as a parameter to \fBTcl_CreateObjTrace\fR. The \fIdeleteProc\fR must match the type, \fBTcl_CmdObjTraceDeleteProc\fR: .PP .CS typedef void \fBTcl_CmdObjTraceDeleteProc\fR( | | | | | 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 |
When \fBTcl_DeleteTrace\fR is called, the interpreter invokes the
\fIdeleteProc\fR that was passed as a parameter to
\fBTcl_CreateObjTrace\fR. The \fIdeleteProc\fR must match the type,
\fBTcl_CmdObjTraceDeleteProc\fR:
.PP
.CS
typedef void \fBTcl_CmdObjTraceDeleteProc\fR(
\fBClientData\fR \fIclientData\fR);
.CE
.PP
The \fIclientData\fR parameter will be the same as the
\fIclientData\fR parameter that was originally passed to
\fBTcl_CreateObjTrace\fR.
.PP
\fBTcl_CreateTrace\fR is an alternative interface for command tracing,
\fInot recommended for new applications\fR. It is provided for backward
compatibility with code that was developed for older versions of the
Tcl interpreter. It is similar to \fBTcl_CreateObjTrace\fR, except
that its \fIproc\fR parameter should have arguments and result that
match the type \fBTcl_CmdTraceProc\fR:
.PP
.CS
typedef void \fBTcl_CmdTraceProc\fR(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
int \fIlevel\fR,
char *\fIcommand\fR,
Tcl_CmdProc *\fIcmdProc\fR,
ClientData \fIcmdClientData\fR,
int \fIargc\fR,
const char *\fIargv\fR[]);
.CE
.PP
The parameters to the \fIproc\fR callback are similar to those of the
\fIobjProc\fR callback above. The \fIcommandToken\fR is
replaced with \fIcmdProc\fR, a pointer to the (string-based) command
|
| ︙ | ︙ |
Changes to doc/DString.3.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_DString 3 7.4 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | | > > | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 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 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_DString 3 7.4 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_DStringInit, Tcl_DStringAppend, Tcl_DStringAppendElement, Tcl_DStringStartSublist, Tcl_DStringEndSublist, Tcl_DStringLength, Tcl_DStringValue, Tcl_DStringSetLength, Tcl_DStringTrunc, Tcl_DStringFree, Tcl_DStringResult, Tcl_DStringGetResult \- manipulate dynamic strings .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp \fBTcl_DStringInit\fR(\fIdsPtr\fR) .sp char * \fBTcl_DStringAppend\fR(\fIdsPtr, bytes, length\fR) .sp char * \fBTcl_DStringAppendElement\fR(\fIdsPtr, element\fR) .sp \fBTcl_DStringStartSublist\fR(\fIdsPtr\fR) .sp \fBTcl_DStringEndSublist\fR(\fIdsPtr\fR) .sp int \fBTcl_DStringLength\fR(\fIdsPtr\fR) .sp char * \fBTcl_DStringValue\fR(\fIdsPtr\fR) .sp \fBTcl_DStringSetLength\fR(\fIdsPtr, newLength\fR) .sp \fBTcl_DStringTrunc\fR(\fIdsPtr, newLength\fR) .sp \fBTcl_DStringFree\fR(\fIdsPtr\fR) .sp \fBTcl_DStringResult\fR(\fIinterp, dsPtr\fR) .sp \fBTcl_DStringGetResult\fR(\fIinterp, dsPtr\fR) .SH ARGUMENTS .AS Tcl_DString newLength in/out .AP Tcl_DString *dsPtr in/out Pointer to structure that is used to manage a dynamic string. .AP "const char" *bytes in Pointer to characters to append to dynamic string. .AP "const char" *element in Pointer to characters to append as list element to dynamic string. .AP int length in Number of bytes from \fIbytes\fR to add to dynamic string. If -1, add all characters up to null terminating character. .AP int newLength in New length for dynamic string, not including null terminating character. .AP Tcl_Interp *interp in/out Interpreter whose result is to be set from or moved to the dynamic string. .BE |
| ︙ | ︙ | |||
121 122 123 124 125 126 127 128 129 130 131 132 133 134 | for the string if needed. However, \fBTcl_DStringSetLength\fR will not initialize the new space except to provide a terminating null character; it is up to the caller to fill in the new space. \fBTcl_DStringSetLength\fR does not free up the string's storage space even if the string is truncated to zero length, so \fBTcl_DStringFree\fR will still need to be called. .PP \fBTcl_DStringFree\fR should be called when you are finished using the string. It frees up any memory that was allocated for the string and reinitializes the string's value to an empty string. .PP \fBTcl_DStringResult\fR sets the result of \fIinterp\fR to the value of the dynamic string given by \fIdsPtr\fR. It does this by moving | > > > > | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 | for the string if needed. However, \fBTcl_DStringSetLength\fR will not initialize the new space except to provide a terminating null character; it is up to the caller to fill in the new space. \fBTcl_DStringSetLength\fR does not free up the string's storage space even if the string is truncated to zero length, so \fBTcl_DStringFree\fR will still need to be called. .PP \fBTcl_DStringTrunc\fR changes the length of a dynamic string. This procedure is now deprecated. \fBTcl_DStringSetLength\fR should be used instead. .PP \fBTcl_DStringFree\fR should be called when you are finished using the string. It frees up any memory that was allocated for the string and reinitializes the string's value to an empty string. .PP \fBTcl_DStringResult\fR sets the result of \fIinterp\fR to the value of the dynamic string given by \fIdsPtr\fR. It does this by moving |
| ︙ | ︙ |
Changes to doc/DoWhenIdle.3.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 | \fBTcl_DoWhenIdle\fR(\fIproc, clientData\fR) .sp \fBTcl_CancelIdleCall\fR(\fIproc, clientData\fR) .SH ARGUMENTS .AS Tcl_IdleProc clientData .AP Tcl_IdleProc *proc in Procedure to invoke. | | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | \fBTcl_DoWhenIdle\fR(\fIproc, clientData\fR) .sp \fBTcl_CancelIdleCall\fR(\fIproc, clientData\fR) .SH ARGUMENTS .AS Tcl_IdleProc clientData .AP Tcl_IdleProc *proc in Procedure to invoke. .AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION .PP \fBTcl_DoWhenIdle\fR arranges for \fIproc\fR to be invoked when the application becomes idle. The application is considered to be idle when \fBTcl_DoOneEvent\fR has been |
| ︙ | ︙ | |||
39 40 41 42 43 44 45 | use \fBTcl_DoOneEvent\fR to dispatch events. .PP \fIProc\fR should have arguments and result that match the type \fBTcl_IdleProc\fR: .PP .CS typedef void \fBTcl_IdleProc\fR( | | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
use \fBTcl_DoOneEvent\fR to dispatch events.
.PP
\fIProc\fR should have arguments and result that match the
type \fBTcl_IdleProc\fR:
.PP
.CS
typedef void \fBTcl_IdleProc\fR(
ClientData \fIclientData\fR);
.CE
.PP
The \fIclientData\fR parameter to \fIproc\fR is a copy of the \fIclientData\fR
argument given to \fBTcl_DoWhenIdle\fR. Typically, \fIclientData\fR
points to a data structure containing application-specific information about
what \fIproc\fR should do.
.PP
|
| ︙ | ︙ |
Changes to doc/DumpActiveMemory.3.
| ︙ | ︙ | |||
39 40 41 42 43 44 45 | They are only functional when Tcl has been compiled with \fBTCL_MEM_DEBUG\fR defined at compile-time. When \fBTCL_MEM_DEBUG\fR is not defined, these functions are all no-ops. .PP \fBTcl_DumpActiveMemory\fR will output a list of all currently allocated memory to the specified file. The information output for each allocated block of memory is: starting and ending addresses | | | | | 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 | They are only functional when Tcl has been compiled with \fBTCL_MEM_DEBUG\fR defined at compile-time. When \fBTCL_MEM_DEBUG\fR is not defined, these functions are all no-ops. .PP \fBTcl_DumpActiveMemory\fR will output a list of all currently allocated memory to the specified file. The information output for each allocated block of memory is: starting and ending addresses (excluding guard zone), size, source file where \fBckalloc\fR was called to allocate the block and line number in that file. It is especially useful to call \fBTcl_DumpActiveMemory\fR after the Tcl interpreter has been deleted. .PP \fBTcl_InitMemory\fR adds the Tcl \fBmemory\fR command to the interpreter given by \fIinterp\fR. \fBTcl_InitMemory\fR is called by \fBTcl_Main\fR. .PP \fBTcl_ValidateAllMemory\fR forces a validation of the guard zones of all currently allocated blocks of memory. Normally validation of a block occurs when its freed, unless full validation is enabled, in which case validation of all blocks occurs when \fBckalloc\fR and \fBckfree\fR are called. This function forces the validation to occur at any point. .SH "SEE ALSO" TCL_MEM_DEBUG, memory .SH KEYWORDS memory, debug |
| ︙ | ︙ |
Changes to doc/Encoding.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1997-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_GetEncoding 3 "8.1" Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1997-1998 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_GetEncoding 3 "8.1" Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_GetEncoding, Tcl_FreeEncoding, Tcl_GetEncodingFromObj, Tcl_ExternalToUtfDString, Tcl_ExternalToUtf, Tcl_UtfToExternalDString, Tcl_UtfToExternal, Tcl_GetEncodingName, Tcl_SetSystemEncoding, Tcl_GetEncodingNameFromEnvironment, Tcl_GetEncodingNames, Tcl_CreateEncoding, Tcl_GetEncodingSearchPath, Tcl_SetEncodingSearchPath, Tcl_GetDefaultEncodingDir, Tcl_SetDefaultEncodingDir \- procedures for creating and using encodings .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Encoding \fBTcl_GetEncoding\fR(\fIinterp, name\fR) .sp |
| ︙ | ︙ | |||
58 59 60 61 62 63 64 65 66 67 68 69 70 71 | \fBTcl_CreateEncoding\fR(\fItypePtr\fR) .sp Tcl_Obj * \fBTcl_GetEncodingSearchPath\fR() .sp int \fBTcl_SetEncodingSearchPath\fR(\fIsearchPath\fR) .SH ARGUMENTS .AS "const Tcl_EncodingType" *dstWrotePtr in/out .AP Tcl_Interp *interp in Interpreter to use for error reporting, or NULL if no error reporting is desired. .AP "const char" *name in Name of encoding to load. | > > > > > > | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | \fBTcl_CreateEncoding\fR(\fItypePtr\fR) .sp Tcl_Obj * \fBTcl_GetEncodingSearchPath\fR() .sp int \fBTcl_SetEncodingSearchPath\fR(\fIsearchPath\fR) .sp const char * \fBTcl_GetDefaultEncodingDir\fR(\fIvoid\fR) .sp void \fBTcl_SetDefaultEncodingDir\fR(\fIpath\fR) .SH ARGUMENTS .AS "const Tcl_EncodingType" *dstWrotePtr in/out .AP Tcl_Interp *interp in Interpreter to use for error reporting, or NULL if no error reporting is desired. .AP "const char" *name in Name of encoding to load. |
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | .AP "const char" *src in For the \fBTcl_ExternalToUtf\fR functions, an array of bytes in the specified encoding that are to be converted to UTF-8. For the \fBTcl_UtfToExternal\fR and \fBTcl_WinUtfToTChar\fR functions, an array of UTF-8 characters to be converted to the specified encoding. .AP "const TCHAR" *tsrc in An array of Windows TCHAR characters to convert to UTF-8. | | | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 | .AP "const char" *src in For the \fBTcl_ExternalToUtf\fR functions, an array of bytes in the specified encoding that are to be converted to UTF-8. For the \fBTcl_UtfToExternal\fR and \fBTcl_WinUtfToTChar\fR functions, an array of UTF-8 characters to be converted to the specified encoding. .AP "const TCHAR" *tsrc in An array of Windows TCHAR characters to convert to UTF-8. .AP int srcLen in Length of \fIsrc\fR or \fItsrc\fR in bytes. If the length is negative, the encoding-specific length of the string is used. .AP Tcl_DString *dstPtr out Pointer to an uninitialized or free \fBTcl_DString\fR in which the converted result will be stored. .AP int flags in Various flag bits OR-ed together. |
| ︙ | ︙ | |||
245 246 247 248 249 250 251 | the source buffer and up to \fIdstLen\fR converted bytes are stored in \fIdst\fR. In all cases, \fI*srcReadPtr\fR is filled with the number of bytes that were successfully converted from \fIsrc\fR and \fI*dstWrotePtr\fR is filled with the corresponding number of bytes that were stored in \fIdst\fR. The return values are the same as the return values for \fBTcl_ExternalToUtf\fR. .PP | | < | | | > > > > > > > | 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 | the source buffer and up to \fIdstLen\fR converted bytes are stored in \fIdst\fR. In all cases, \fI*srcReadPtr\fR is filled with the number of bytes that were successfully converted from \fIsrc\fR and \fI*dstWrotePtr\fR is filled with the corresponding number of bytes that were stored in \fIdst\fR. The return values are the same as the return values for \fBTcl_ExternalToUtf\fR. .PP \fBTcl_WinUtfToTChar\fR and \fBTcl_WinTCharToUtf\fR are Windows-only convenience functions for converting between UTF-8 and Windows strings based on the TCHAR type which is by convention a Unicode character on Windows NT. Those functions are deprecated. You can use \fBTcl_UtfToWCharDString\fR resp. \fBTcl_WCharToUtfDString\fR as replacement. If you want compatibility with earlier Tcl releases than 8.7, use \fBTcl_UtfToUniCharDString\fR resp. \fBTcl_UniCharToUtfDString\fR as replacement, and make sure you compile your extension with -DTCL_UTF_MAX=3. Beware: Those replacement functions don't initialize their Tcl_DString (you'll have to do that yourself), and \fBTcl_UniCharToUtfDString\fR from Tcl 8.6 doesn't accept -1 as length parameter. .PP \fBTcl_GetEncodingName\fR is roughly the inverse of \fBTcl_GetEncoding\fR. Given an \fIencoding\fR, the return value is the \fIname\fR argument that was used to create the encoding. The string returned by \fBTcl_GetEncodingName\fR is only guaranteed to persist until the \fIencoding\fR is deleted. The caller must not modify this string. .PP |
| ︙ | ︙ | |||
277 278 279 280 281 282 283 | the environment suitable for the platform. It accepts \fIbufPtr\fR, a pointer to an uninitialized or freed \fBTcl_DString\fR and writes the encoding name to it. The \fBTcl_DStringValue\fR is returned. .PP \fBTcl_GetEncodingNames\fR sets the \fIinterp\fR result to a list consisting of the names of all the encodings that are currently defined or can be dynamically loaded, searching the encoding path specified by | | | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 | the environment suitable for the platform. It accepts \fIbufPtr\fR, a pointer to an uninitialized or freed \fBTcl_DString\fR and writes the encoding name to it. The \fBTcl_DStringValue\fR is returned. .PP \fBTcl_GetEncodingNames\fR sets the \fIinterp\fR result to a list consisting of the names of all the encodings that are currently defined or can be dynamically loaded, searching the encoding path specified by \fBTcl_SetDefaultEncodingDir\fR. This procedure does not ensure that the dynamically-loadable encoding files contain valid data, but merely that they exist. .PP \fBTcl_CreateEncoding\fR defines a new encoding and registers the C procedures that are called back to convert between the encoding and UTF-8. Encodings created by \fBTcl_CreateEncoding\fR are thereafter visible in the database used by \fBTcl_GetEncoding\fR. Just as with the |
| ︙ | ︙ | |||
304 305 306 307 308 309 310 |
.PP
.CS
typedef struct Tcl_EncodingType {
const char *\fIencodingName\fR;
Tcl_EncodingConvertProc *\fItoUtfProc\fR;
Tcl_EncodingConvertProc *\fIfromUtfProc\fR;
Tcl_EncodingFreeProc *\fIfreeProc\fR;
| | | 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 |
.PP
.CS
typedef struct Tcl_EncodingType {
const char *\fIencodingName\fR;
Tcl_EncodingConvertProc *\fItoUtfProc\fR;
Tcl_EncodingConvertProc *\fIfromUtfProc\fR;
Tcl_EncodingFreeProc *\fIfreeProc\fR;
ClientData \fIclientData\fR;
int \fInullSize\fR;
} \fBTcl_EncodingType\fR;
.CE
.PP
The \fIencodingName\fR provides a string name for the encoding, by
which it can be referred in other procedures such as
\fBTcl_GetEncoding\fR. The \fItoUtfProc\fR refers to a callback
|
| ︙ | ︙ | |||
335 336 337 338 339 340 341 | CNS11643) are not accepted. .PP The callback procedures \fItoUtfProc\fR and \fIfromUtfProc\fR should match the type \fBTcl_EncodingConvertProc\fR: .PP .CS typedef int \fBTcl_EncodingConvertProc\fR( | | | 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 |
CNS11643) are not accepted.
.PP
The callback procedures \fItoUtfProc\fR and \fIfromUtfProc\fR should match the
type \fBTcl_EncodingConvertProc\fR:
.PP
.CS
typedef int \fBTcl_EncodingConvertProc\fR(
ClientData \fIclientData\fR,
const char *\fIsrc\fR,
int \fIsrcLen\fR,
int \fIflags\fR,
Tcl_EncodingState *\fIstatePtr\fR,
char *\fIdst\fR,
int \fIdstLen\fR,
int *\fIsrcReadPtr\fR,
|
| ︙ | ︙ | |||
367 368 369 370 371 372 373 | procedure will be a non-NULL location. .PP The callback procedure \fIfreeProc\fR, if non-NULL, should match the type \fBTcl_EncodingFreeProc\fR: .PP .CS typedef void \fBTcl_EncodingFreeProc\fR( | | | 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 |
procedure will be a non-NULL location.
.PP
The callback procedure \fIfreeProc\fR, if non-NULL, should match the type
\fBTcl_EncodingFreeProc\fR:
.PP
.CS
typedef void \fBTcl_EncodingFreeProc\fR(
ClientData \fIclientData\fR);
.CE
.PP
This \fIfreeProc\fR function is called when the encoding is deleted. The
\fIclientData\fR parameter is the same as the \fIclientData\fR field
specified to \fBTcl_CreateEncoding\fR when the encoding was created.
.PP
\fBTcl_GetEncodingSearchPath\fR and \fBTcl_SetEncodingSearchPath\fR
|
| ︙ | ︙ | |||
392 393 394 395 396 397 398 399 400 401 402 403 404 405 | \fBTcl_SetEncodingSearchPath\fR stores \fIsearchPath\fR and returns \fBTCL_OK\fR, unless \fIsearchPath\fR is not a valid Tcl list, which causes \fBTCL_ERROR\fR to be returned. The elements of \fIsearchPath\fR are not verified as existing readable filesystem directories. When searching for encoding data files takes place, and non-existent or non-readable filesystem directories on the \fIsearchPath\fR are silently ignored. .SH "ENCODING FILES" Space would prohibit precompiling into Tcl every possible encoding algorithm, so many encodings are stored on disk as dynamically-loadable encoding files. This behavior also allows the user to create additional encoding files that can be loaded using the same mechanism. These encoding files contain information about the tables and/or escape sequences used to map between an external encoding and Unicode. The | > > > > > > > > > | 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 | \fBTcl_SetEncodingSearchPath\fR stores \fIsearchPath\fR and returns \fBTCL_OK\fR, unless \fIsearchPath\fR is not a valid Tcl list, which causes \fBTCL_ERROR\fR to be returned. The elements of \fIsearchPath\fR are not verified as existing readable filesystem directories. When searching for encoding data files takes place, and non-existent or non-readable filesystem directories on the \fIsearchPath\fR are silently ignored. .PP \fBTcl_GetDefaultEncodingDir\fR and \fBTcl_SetDefaultEncodingDir\fR are obsolete interfaces best replaced with calls to \fBTcl_GetEncodingSearchPath\fR and \fBTcl_SetEncodingSearchPath\fR. They are called to access and set the first element of the \fIsearchPath\fR list. Since Tcl searches \fIsearchPath\fR for encoding data files in list order, these routines establish the .QW default directory in which to find encoding data files. .SH "ENCODING FILES" Space would prohibit precompiling into Tcl every possible encoding algorithm, so many encodings are stored on disk as dynamically-loadable encoding files. This behavior also allows the user to create additional encoding files that can be loaded using the same mechanism. These encoding files contain information about the tables and/or escape sequences used to map between an external encoding and Unicode. The |
| ︙ | ︙ |
Changes to doc/Ensemble.3.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 | .sp int \fBTcl_GetEnsembleMappingDict\fR(\fIinterp, token, dictObjPtr\fR) .sp int \fBTcl_SetEnsembleMappingDict\fR(\fIinterp, token, dictObj\fR) .sp | < < | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | .sp int \fBTcl_GetEnsembleMappingDict\fR(\fIinterp, token, dictObjPtr\fR) .sp int \fBTcl_SetEnsembleMappingDict\fR(\fIinterp, token, dictObj\fR) .sp int \fBTcl_GetEnsembleParameterList\fR(\fIinterp, token, listObjPtr\fR) .sp int \fBTcl_SetEnsembleParameterList\fR(\fIinterp, token, listObj\fR) .sp int \fBTcl_GetEnsembleSubcommandList\fR(\fIinterp, token, listObjPtr\fR) .sp int \fBTcl_SetEnsembleSubcommandList\fR(\fIinterp, token, listObj\fR) .sp |
| ︙ | ︙ | |||
159 160 161 162 163 164 165 | ensemble) and the dictionary obtained from \fBTcl_GetEnsembleMappingDict\fR should always be treated as immutable even if it is unshared. All command names in prefixes set via \fBTcl_SetEnsembleMappingDict\fR must be fully qualified. .TP \fBformal pre-subcommand parameter list\fR (read-write) | < < | 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 | ensemble) and the dictionary obtained from \fBTcl_GetEnsembleMappingDict\fR should always be treated as immutable even if it is unshared. All command names in prefixes set via \fBTcl_SetEnsembleMappingDict\fR must be fully qualified. .TP \fBformal pre-subcommand parameter list\fR (read-write) A list of formal parameter names (the names only being used when generating error messages) that come at invocation of the ensemble between the name of the ensemble and the subcommand argument. NULL (the default) is equivalent to the empty list. May be read and written using \fBTcl_GetEnsembleParameterList\fR and \fBTcl_SetEnsembleParameterList\fR respectively. The result of both of those functions is a Tcl result code (\fBTCL_OK\fR, or \fBTCL_ERROR\fR if the token does not refer to an ensemble) and the dictionary obtained from \fBTcl_GetEnsembleParameterList\fR should always be treated as immutable even if it is unshared. .TP \fBsubcommand list\fR (read-write) . A list of all the subcommand names for the ensemble, or NULL if this is to be derived from either the keys of the mapping dictionary (see above) or (if that is also NULL) from the set of commands exported by the bound namespace. May be read and written using |
| ︙ | ︙ |
Changes to doc/Eval.3.
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_Eval 3 8.1 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 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval, Tcl_VarEvalVA \- execute Tcl scripts .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp int \fBTcl_EvalObjEx\fR(\fIinterp, objPtr, flags\fR) .sp |
| ︙ | ︙ | |||
34 35 36 37 38 39 40 41 42 43 44 45 46 47 | \fBTcl_GlobalEval\fR(\fIinterp, script\fR) .sp int \fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR) .sp int \fBTcl_VarEval\fR(\fIinterp, part, part, ... \fB(char *) NULL\fR) .SH ARGUMENTS .AS Tcl_Interp **termPtr .AP Tcl_Interp *interp in Interpreter in which to execute the script. The interpreter's result is modified to hold the result or error message from the script. .AP Tcl_Obj *objPtr in A Tcl value containing the script to execute. | > > > | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | \fBTcl_GlobalEval\fR(\fIinterp, script\fR) .sp int \fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR) .sp int \fBTcl_VarEval\fR(\fIinterp, part, part, ... \fB(char *) NULL\fR) .sp int \fBTcl_VarEvalVA\fR(\fIinterp, argList\fR) .SH ARGUMENTS .AS Tcl_Interp **termPtr .AP Tcl_Interp *interp in Interpreter in which to execute the script. The interpreter's result is modified to hold the result or error message from the script. .AP Tcl_Obj *objPtr in A Tcl value containing the script to execute. |
| ︙ | ︙ | |||
60 61 62 63 64 65 66 67 68 69 70 71 72 73 | The number of bytes in \fIscript\fR, not including any null terminating character. If \-1, then all characters up to the first null byte are used. .AP "const char" *script in Points to first byte of script to execute (null-terminated and UTF-8). .AP char *part in String forming part of a Tcl script. .BE .SH DESCRIPTION .PP The procedures described here are invoked to execute Tcl scripts in various forms. \fBTcl_EvalObjEx\fR is the core procedure and is used by many of the others. | > > > | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | The number of bytes in \fIscript\fR, not including any null terminating character. If \-1, then all characters up to the first null byte are used. .AP "const char" *script in Points to first byte of script to execute (null-terminated and UTF-8). .AP char *part in String forming part of a Tcl script. .AP va_list argList in An argument list which must have been initialized using \fBva_start\fR, and cleared using \fBva_end\fR. .BE .SH DESCRIPTION .PP The procedures described here are invoked to execute Tcl scripts in various forms. \fBTcl_EvalObjEx\fR is the core procedure and is used by many of the others. |
| ︙ | ︙ | |||
118 119 120 121 122 123 124 | \fBTcl_ExternalToUtfDString\fR or \fBTcl_ExternalToUtf\fR when it is known to possibly contain upper ASCII characters whose possible combinations might be a UTF-8 special code. The string is parsed and executed directly (using \fBTcl_EvalObjv\fR) instead of compiling it and executing the bytecodes. In situations where it is known that the script will never be executed again, \fBTcl_Eval\fR may be faster than \fBTcl_EvalObjEx\fR. \fBTcl_Eval\fR returns a completion code and result just like | | > > > > | > > | > > > > > | 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 | \fBTcl_ExternalToUtfDString\fR or \fBTcl_ExternalToUtf\fR when it is known to possibly contain upper ASCII characters whose possible combinations might be a UTF-8 special code. The string is parsed and executed directly (using \fBTcl_EvalObjv\fR) instead of compiling it and executing the bytecodes. In situations where it is known that the script will never be executed again, \fBTcl_Eval\fR may be faster than \fBTcl_EvalObjEx\fR. \fBTcl_Eval\fR returns a completion code and result just like \fBTcl_EvalObjEx\fR. Note: for backward compatibility with versions before Tcl 8.0, \fBTcl_Eval\fR copies the value result in \fIinterp\fR to \fIinterp->result\fR (use is deprecated) where it can be accessed directly. This makes \fBTcl_Eval\fR somewhat slower than \fBTcl_EvalEx\fR, which does not do the copy. .PP \fBTcl_EvalEx\fR is an extended version of \fBTcl_Eval\fR that takes additional arguments \fInumBytes\fR and \fIflags\fR. For the efficiency reason given above, \fBTcl_EvalEx\fR is generally preferred over \fBTcl_Eval\fR. .PP \fBTcl_GlobalEval\fR and \fBTcl_GlobalEvalObj\fR are older procedures that are now deprecated. They are similar to \fBTcl_EvalEx\fR and \fBTcl_EvalObjEx\fR except that the script is evaluated in the global namespace and its variable context consists of global variables only (it ignores any Tcl procedures that are active). These functions are equivalent to using the \fBTCL_EVAL_GLOBAL\fR flag (see below). .PP \fBTcl_VarEval\fR takes any number of string arguments of any length, concatenates them into a single string, then calls \fBTcl_Eval\fR to execute that string as a Tcl command. It returns the result of the command and also modifies the interpreter result in the same way as \fBTcl_Eval\fR. The last argument to \fBTcl_VarEval\fR must be NULL to indicate the end of arguments. \fBTcl_VarEval\fR is now deprecated. .PP \fBTcl_VarEvalVA\fR is the same as \fBTcl_VarEval\fR except that instead of taking a variable number of arguments it takes an argument list. Interfaces using argument lists have been found to be nonportable in practice. This function is deprecated and will be removed in Tcl 9.0. .SH "FLAG BITS" .PP Any ORed combination of the following values may be used for the \fIflags\fR argument to procedures such as \fBTcl_EvalObjEx\fR: .TP 23 \fBTCL_EVAL_DIRECT\fR |
| ︙ | ︙ |
Changes to doc/Exit.3.
| ︙ | ︙ | |||
38 39 40 41 42 43 44 | Exact meaning may be platform-specific. 0 usually means a normal exit, any nonzero value usually means that an error occurred. .AP Tcl_ExitProc *proc in Procedure to invoke before exiting application, or (for \fBTcl_SetExitProc\fR) NULL to uninstall the current application exit procedure. | | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | Exact meaning may be platform-specific. 0 usually means a normal exit, any nonzero value usually means that an error occurred. .AP Tcl_ExitProc *proc in Procedure to invoke before exiting application, or (for \fBTcl_SetExitProc\fR) NULL to uninstall the current application exit procedure. .AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION .PP The procedures described here provide a graceful mechanism to end the execution of a \fBTcl\fR application. Exit handlers are invoked to cleanup the |
| ︙ | ︙ | |||
60 61 62 63 64 65 66 | Note that if other code invokes \fBexit\fR system procedure directly, or otherwise causes the application to terminate without calling \fBTcl_Exit\fR, the exit handlers will not be run. \fBTcl_Exit\fR internally invokes the \fBexit\fR system call, thus it never returns control to its caller. If an application exit handler has been installed (see \fBTcl_SetExitProc\fR), that handler is invoked with an argument | | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 | Note that if other code invokes \fBexit\fR system procedure directly, or otherwise causes the application to terminate without calling \fBTcl_Exit\fR, the exit handlers will not be run. \fBTcl_Exit\fR internally invokes the \fBexit\fR system call, thus it never returns control to its caller. If an application exit handler has been installed (see \fBTcl_SetExitProc\fR), that handler is invoked with an argument consisting of the exit status (cast to ClientData); the application exit handler should not return control to Tcl. .PP \fBTcl_Finalize\fR is similar to \fBTcl_Exit\fR except that it does not exit from the current process. It is useful for cleaning up when a process is finished using \fBTcl\fR but wishes to continue executing, and when \fBTcl\fR is used in a dynamically loaded extension that is about to be unloaded. |
| ︙ | ︙ | |||
89 90 91 92 93 94 95 | by \fBTcl_FinalizeThread\fR and \fBTcl_ExitThread\fR. This provides a hook for cleanup operations such as flushing buffers and freeing global memory. \fIProc\fR should match the type \fBTcl_ExitProc\fR: .PP .CS typedef void \fBTcl_ExitProc\fR( | | | 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 |
by \fBTcl_FinalizeThread\fR and \fBTcl_ExitThread\fR.
This provides a hook for cleanup operations such as flushing buffers
and freeing global memory.
\fIProc\fR should match the type \fBTcl_ExitProc\fR:
.PP
.CS
typedef void \fBTcl_ExitProc\fR(
ClientData \fIclientData\fR);
.CE
.PP
The \fIclientData\fR parameter to \fIproc\fR is a
copy of the \fIclientData\fR argument given to
\fBTcl_CreateExitHandler\fR or \fBTcl_CreateThreadExitHandler\fR when
the callback
was created. Typically, \fIclientData\fR points to a data
|
| ︙ | ︙ | |||
129 130 131 132 133 134 135 | \fBTcl_SetExitProc\fR installs an application exit handler, returning the previously-installed application exit handler or NULL if no application handler was installed. If an application exit handler is installed, that exit handler takes over complete responsibility for finalization of Tcl's subsystems via \fBTcl_Finalize\fR at an appropriate time. The argument passed to \fIproc\fR when it is invoked will be the exit status code (as passed to \fBTcl_Exit\fR) | | | > | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 | \fBTcl_SetExitProc\fR installs an application exit handler, returning the previously-installed application exit handler or NULL if no application handler was installed. If an application exit handler is installed, that exit handler takes over complete responsibility for finalization of Tcl's subsystems via \fBTcl_Finalize\fR at an appropriate time. The argument passed to \fIproc\fR when it is invoked will be the exit status code (as passed to \fBTcl_Exit\fR) cast to a ClientData value. .PP \fBTcl_SetExitProc\fR can not be used in stub-enabled extensions. Its symbol entry in the stub table is deprecated and it will be removed in Tcl 9.0. .SH "SEE ALSO" exit(n) .SH KEYWORDS abort, callback, cleanup, dynamic loading, end application, exit, unloading, thread |
Changes to doc/FileSystem.3.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 | .sp int \fBTcl_FSRegister\fR(\fIclientData, fsPtr\fR) .sp int \fBTcl_FSUnregister\fR(\fIfsPtr\fR) .sp | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | .sp int \fBTcl_FSRegister\fR(\fIclientData, fsPtr\fR) .sp int \fBTcl_FSUnregister\fR(\fIfsPtr\fR) .sp ClientData \fBTcl_FSData\fR(\fIfsPtr\fR) .sp void \fBTcl_FSMountsChanged\fR(\fIfsPtr\fR) .sp const Tcl_Filesystem * \fBTcl_FSGetFileSystemForPath\fR(\fIpathPtr\fR) |
| ︙ | ︙ | |||
59 60 61 62 63 64 65 |
int
\fBTcl_FSEvalFile\fR(\fIinterp, pathPtr\fR)
.sp
int
\fBTcl_FSLoadFile\fR(\fIinterp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
loadHandlePtr, unloadProcPtr\fR)
.sp
| < < | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
int
\fBTcl_FSEvalFile\fR(\fIinterp, pathPtr\fR)
.sp
int
\fBTcl_FSLoadFile\fR(\fIinterp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
loadHandlePtr, unloadProcPtr\fR)
.sp
int
\fBTcl_FSUnloadFile\fR(\fIinterp, loadHandle\fR)
.sp
int
\fBTcl_FSMatchInDirectory\fR(\fIinterp, resultPtr, pathPtr, pattern, types\fR)
.sp
Tcl_Obj *
\fBTcl_FSLink\fR(\fIlinkNamePtr, toPtr, linkAction\fR)
.sp
|
| ︙ | ︙ | |||
121 122 123 124 125 126 127 | .sp Tcl_Obj * \fBTcl_FSJoinToPath\fR(\fIbasePtr, objc, objv\fR) .sp int \fBTcl_FSConvertToPathType\fR(\fIinterp, pathPtr\fR) .sp | | < | 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 | .sp Tcl_Obj * \fBTcl_FSJoinToPath\fR(\fIbasePtr, objc, objv\fR) .sp int \fBTcl_FSConvertToPathType\fR(\fIinterp, pathPtr\fR) .sp ClientData \fBTcl_FSGetInternalRep\fR(\fIpathPtr, fsPtr\fR) .sp Tcl_Obj * \fBTcl_FSGetTranslatedPath\fR(\fIinterp, pathPtr\fR) .sp const char * \fBTcl_FSGetTranslatedStringPath\fR(\fIinterp, pathPtr\fR) .sp Tcl_Obj * \fBTcl_FSNewNativePath\fR(\fIfsPtr, clientData\fR) .sp const void * \fBTcl_FSGetNativePath\fR(\fIpathPtr\fR) .sp Tcl_Obj * \fBTcl_FSFileSystemInfo\fR(\fIpathPtr\fR) .sp Tcl_StatBuf * \fBTcl_AllocStatBuf\fR() .sp Tcl_WideInt \fBTcl_GetAccessTimeFromStat\fR(\fIstatPtr\fR) .sp unsigned \fBTcl_GetBlockSizeFromStat\fR(\fIstatPtr\fR) .sp Tcl_WideUInt |
| ︙ | ︙ | |||
181 182 183 184 185 186 187 | \fBTcl_GetModificationTimeFromStat\fR(\fIstatPtr\fR) .sp Tcl_WideUInt \fBTcl_GetSizeFromStat\fR(\fIstatPtr\fR) .sp int \fBTcl_GetUserIdFromStat\fR(\fIstatPtr\fR) | < | 178 179 180 181 182 183 184 185 186 187 188 189 190 191 | \fBTcl_GetModificationTimeFromStat\fR(\fIstatPtr\fR) .sp Tcl_WideUInt \fBTcl_GetSizeFromStat\fR(\fIstatPtr\fR) .sp int \fBTcl_GetUserIdFromStat\fR(\fIstatPtr\fR) .SH ARGUMENTS .AS Tcl_GlobTypeData **srcPathPtr out .AP "const Tcl_Filesystem" *fsPtr in Points to a structure containing the addresses of procedures that can be called to perform the various filesystem operations. .AP Tcl_Obj *pathPtr in The path represented by this value is used for the operation in |
| ︙ | ︙ | |||
208 209 210 211 212 213 214 | Only files or directories matching this pattern will be returned. .AP Tcl_GlobTypeData *types in Only files or directories matching the type descriptions contained in this structure will be returned. This parameter may be NULL. .AP Tcl_Interp *interp in Interpreter to use either for results, evaluation, or reporting error messages. | | | 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 | Only files or directories matching this pattern will be returned. .AP Tcl_GlobTypeData *types in Only files or directories matching the type descriptions contained in this structure will be returned. This parameter may be NULL. .AP Tcl_Interp *interp in Interpreter to use either for results, evaluation, or reporting error messages. .AP ClientData clientData in The native description of the path value to create. .AP Tcl_Obj *firstPtr in The first of two path values to compare. The value may be converted to \fBpath\fR type. .AP Tcl_Obj *secondPtr in The second of two path values to compare. The value may be converted to \fBpath\fR type. |
| ︙ | ︙ | |||
245 246 247 248 249 250 251 | Name of a procedure to look up in the file's symbol table .AP "const char" *sym2 in Name of a procedure to look up in the file's symbol table .AP Tcl_PackageInitProc **proc1Ptr out Filled with the init function for this code. .AP Tcl_PackageInitProc **proc2Ptr out Filled with the safe-init function for this code. | | | 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 | Name of a procedure to look up in the file's symbol table .AP "const char" *sym2 in Name of a procedure to look up in the file's symbol table .AP Tcl_PackageInitProc **proc1Ptr out Filled with the init function for this code. .AP Tcl_PackageInitProc **proc2Ptr out Filled with the safe-init function for this code. .AP ClientData *clientDataPtr out Filled with the clientData value to pass to this code's unload function when it is called. .AP Tcl_LoadHandle *loadHandlePtr out Filled with an abstract token representing the loaded file. .AP Tcl_FSUnloadFileProc **unloadProcPtr out Filled with the function to use to unload this piece of code. .AP Tcl_LoadHandle loadHandle in |
| ︙ | ︙ | |||
440 441 442 443 444 445 446 | \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 in dynamically loading binary code), Tcl will attempt to copy the file to a temporary directory and load that temporary file. | < < < < | 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 | \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 in dynamically loading binary code), Tcl will attempt to copy the file to a temporary directory and load that temporary file. \fBTcl_FSUnloadFile\fR reverses the operation, asking for the library indicated by the \fIloadHandle\fR to be removed from the process. Note that, unlike with the \fBunload\fR command, this does not give the library any opportunity to clean up. .PP Both the above functions return a standard Tcl completion code. If an error occurs, an error message is left in the \fIinterp\fR's result. .PP The token provided via the variable indicated by \fIloadHandlePtr\fR may be used with \fBTcl_FindSymbol\fR. .PP \fBTcl_FSMatchInDirectory\fR is used by the globbing code to search a directory for all files which match a given pattern. The appropriate function for the filesystem to which \fIpathPtr\fR belongs will be called. .PP The return value is a standard Tcl result indicating whether an error occurred in globbing. Error messages are placed in interp (unless |
| ︙ | ︙ | |||
720 721 722 723 724 725 726 | freed. This function is of little practical use, and \fBTcl_FSGetNormalizedPath\fR or \fBTcl_FSGetNativePath\fR are usually better functions to use for most purposes. .PP \fBTcl_FSGetTranslatedStringPath\fR does the same as \fBTcl_FSGetTranslatedPath\fR, but returns a character string or NULL. The string returned is dynamically allocated and owned by the caller, | | | 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 | freed. This function is of little practical use, and \fBTcl_FSGetNormalizedPath\fR or \fBTcl_FSGetNativePath\fR are usually better functions to use for most purposes. .PP \fBTcl_FSGetTranslatedStringPath\fR does the same as \fBTcl_FSGetTranslatedPath\fR, but returns a character string or NULL. The string returned is dynamically allocated and owned by the caller, which must store it or call \fBckfree\fR to ensure it is freed. Again, \fBTcl_FSGetNormalizedPath\fR or \fBTcl_FSGetNativePath\fR are usually better functions to use for most purposes. .PP \fBTcl_FSNewNativePath\fR performs something like the reverse of the usual obj->path->nativerep conversions. If some code retrieves a path in native form (from, e.g.\ \fBreadlink\fR or a native dialog), and that path is to be used at the Tcl level, then calling this function is an |
| ︙ | ︙ | |||
787 788 789 790 791 792 793 | absolute. .PP It returns one of \fBTCL_PATH_ABSOLUTE\fR, \fBTCL_PATH_RELATIVE\fR, or \fBTCL_PATH_VOLUME_RELATIVE\fR .SS "PORTABLE STAT RESULT API" .PP \fBTcl_AllocStatBuf\fR allocates a \fITcl_StatBuf\fR on the system heap (which | | < | 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 | absolute. .PP It returns one of \fBTCL_PATH_ABSOLUTE\fR, \fBTCL_PATH_RELATIVE\fR, or \fBTCL_PATH_VOLUME_RELATIVE\fR .SS "PORTABLE STAT RESULT API" .PP \fBTcl_AllocStatBuf\fR allocates a \fITcl_StatBuf\fR on the system heap (which may be deallocated by being passed to \fBckfree\fR). This allows extensions to invoke \fBTcl_FSStat\fR and \fBTcl_FSLstat\fR without being dependent on the size of the buffer. That in turn depends on the flags used to build Tcl. .PP The portable fields of a \fITcl_StatBuf\fR may be read using the following functions, each of which returns the value of the corresponding field listed in the table below. Note that on some platforms there may be other fields in the \fITcl_StatBuf\fR as it is an alias for a suitable system structure, but only the portable ones are made available here. See your system documentation for a full description of these fields. .DS |
| ︙ | ︙ | |||
815 816 817 818 819 820 821 | \fBTcl_GetAccessTimeFromStat\fR st_atime \fBTcl_GetModificationTimeFromStat\fR st_mtime \fBTcl_GetChangeTimeFromStat\fR st_ctime \fBTcl_GetSizeFromStat\fR st_size \fBTcl_GetBlocksFromStat\fR st_blocks \fBTcl_GetBlockSizeFromStat\fR st_blksize .DE | < | 806 807 808 809 810 811 812 813 814 815 816 817 818 819 | \fBTcl_GetAccessTimeFromStat\fR st_atime \fBTcl_GetModificationTimeFromStat\fR st_mtime \fBTcl_GetChangeTimeFromStat\fR st_ctime \fBTcl_GetSizeFromStat\fR st_size \fBTcl_GetBlocksFromStat\fR st_blocks \fBTcl_GetBlockSizeFromStat\fR st_blksize .DE .SH "THE VIRTUAL FILESYSTEM API" .PP A filesystem provides a \fBTcl_Filesystem\fR structure that contains pointers to functions that implement the various operations on a filesystem; these operations are invoked as needed by the generic layer, which generally occurs through the functions listed above. .PP |
| ︙ | ︙ | |||
837 838 839 840 841 842 843 | not check if the same filesystem is registered multiple times (and in general that is not a good thing to do). \fBTCL_OK\fR will be returned. .PP \fBTcl_FSUnregister\fR removes the given filesystem structure from the list of known filesystems, if it is known, and returns \fBTCL_OK\fR. If the filesystem is not currently registered, \fBTCL_ERROR\fR is returned. .PP | | | 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 | not check if the same filesystem is registered multiple times (and in general that is not a good thing to do). \fBTCL_OK\fR will be returned. .PP \fBTcl_FSUnregister\fR removes the given filesystem structure from the list of known filesystems, if it is known, and returns \fBTCL_OK\fR. If the filesystem is not currently registered, \fBTCL_ERROR\fR is returned. .PP \fBTcl_FSData\fR will return the ClientData associated with the given filesystem, if that filesystem is registered. Otherwise it will return NULL. .PP \fBTcl_FSMountsChanged\fR is used to inform the Tcl's core that the set of mount points for the given (already registered) filesystem have changed, and that cached file representations may therefore no longer be correct. |
| ︙ | ︙ | |||
1014 1015 1016 1017 1018 1019 1020 |
cache the fact that this path belongs to this filesystem. Such caches
are invalidated when filesystem structures are added or removed from
Tcl's internal list of known filesystems.
.PP
.CS
typedef int \fBTcl_FSPathInFilesystemProc\fR(
Tcl_Obj *\fIpathPtr\fR,
| | | | | | | | 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 |
cache the fact that this path belongs to this filesystem. Such caches
are invalidated when filesystem structures are added or removed from
Tcl's internal list of known filesystems.
.PP
.CS
typedef int \fBTcl_FSPathInFilesystemProc\fR(
Tcl_Obj *\fIpathPtr\fR,
ClientData *\fIclientDataPtr\fR);
.CE
.SS DUPINTERNALREPPROC
.PP
This function makes a copy of a path's internal representation, and is
called when Tcl needs to duplicate a path value. If NULL, Tcl will
simply not copy the internal representation, which may then need to be
regenerated later.
.PP
.CS
typedef ClientData \fBTcl_FSDupInternalRepProc\fR(
ClientData \fIclientData\fR);
.CE
.SS FREEINTERNALREPPROC
Free the internal representation. This must be implemented if internal
representations need freeing (i.e.\ if some memory is allocated when an
internal representation is generated), but may otherwise be NULL.
.PP
.CS
typedef void \fBTcl_FSFreeInternalRepProc\fR(
ClientData \fIclientData\fR);
.CE
.SS INTERNALTONORMALIZEDPROC
.PP
Function to convert internal representation to a normalized path. Only
required if the filesystem creates pure path values with no string/path
representation. The return value is a Tcl value whose string
representation is the normalized path.
.PP
.CS
typedef Tcl_Obj *\fBTcl_FSInternalToNormalizedProc\fR(
ClientData \fIclientData\fR);
.CE
.SS CREATEINTERNALREPPROC
.PP
Function to take a path value, and calculate an internal
representation for it, and store that native representation in the
value. May be NULL if paths have no internal representation, or if
the \fITcl_FSPathInFilesystemProc\fR for this filesystem always
immediately creates an internal representation for paths it accepts.
.PP
.CS
typedef ClientData \fBTcl_FSCreateInternalRepProc\fR(
Tcl_Obj *\fIpathPtr\fR);
.CE
.SS NORMALIZEPATHPROC
.PP
Function to normalize a path. Should be implemented for all
filesystems which can have multiple string representations for the same
path value. In Tcl, every
|
| ︙ | ︙ |
Changes to doc/FindExec.3.
| ︙ | ︙ | |||
55 56 57 58 59 60 61 | \fBTcl_GetNameOfExecutable\fR simply returns a pointer to the internal full path name of the executable file as computed by \fBTcl_FindExecutable\fR. This procedure call is the C API equivalent to the \fBinfo nameofexecutable\fR command. NULL is returned if the internal full path name has not been computed or unknown. .PP | | > | 55 56 57 58 59 60 61 62 63 64 65 | \fBTcl_GetNameOfExecutable\fR simply returns a pointer to the internal full path name of the executable file as computed by \fBTcl_FindExecutable\fR. This procedure call is the C API equivalent to the \fBinfo nameofexecutable\fR command. NULL is returned if the internal full path name has not been computed or unknown. .PP \fBTcl_FindExecutable\fR can not be used in stub-enabled extensions. Its symbol entry in the stub table is deprecated and it will be removed in Tcl 9.0. .SH KEYWORDS binary, executable file |
Changes to doc/GetInt.3.
| ︙ | ︙ | |||
60 61 62 63 64 65 66 67 | .QW \fB0d\fR then \fIsrc\fR is expected to be in decimal form; otherwise, if the first such characters are .QW \fB0o\fR then \fIsrc\fR is expected to be in octal form; otherwise, if the first such characters are .QW \fB0b\fR then \fIsrc\fR | > > > | | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | .QW \fB0d\fR then \fIsrc\fR is expected to be in decimal form; otherwise, if the first such characters are .QW \fB0o\fR then \fIsrc\fR is expected to be in octal form; otherwise, if the first such characters are .QW \fB0b\fR then \fIsrc\fR is expected to be in binary form; otherwise, if the first such character is .QW \fB0\fR then \fIsrc\fR is expected to be in octal form; otherwise, \fIsrc\fR is expected to be in decimal form. .PP \fBTcl_GetDouble\fR expects \fIsrc\fR to consist of a floating-point number, which is: white space; a sign; a sequence of digits; a decimal point .QW \fB.\fR ; a sequence of digits; the letter .QW \fBe\fR ; |
| ︙ | ︙ |
Changes to doc/GetOpnFl.3.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 | String identifying channel, such as \fBstdin\fR or \fBfile4\fR. .AP int write in Non-zero means the file will be used for writing, zero means it will be used for reading. .AP int checkUsage in If non-zero, then an error will be generated if the file was not opened for the access indicated by \fIwrite\fR. | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | String identifying channel, such as \fBstdin\fR or \fBfile4\fR. .AP int write in Non-zero means the file will be used for writing, zero means it will be used for reading. .AP int checkUsage in If non-zero, then an error will be generated if the file was not opened for the access indicated by \fIwrite\fR. .AP ClientData *filePtr out Points to word in which to store pointer to FILE structure for the file given by \fIchanID\fR. .BE .SH DESCRIPTION .PP \fBTcl_GetOpenFile\fR takes as argument a file identifier of the form |
| ︙ | ︙ |
Changes to doc/GetTime.3.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 | .AP Tcl_Time *timePtr out Points to memory in which to store the date and time information. .AP Tcl_GetTimeProc getProc in Pointer to handler function replacing \fBTcl_GetTime\fR's access to the OS. .AP Tcl_ScaleTimeProc scaleProc in Pointer to handler function for the conversion of time delays in the virtual domain to real-time. | | | | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | .AP Tcl_Time *timePtr out Points to memory in which to store the date and time information. .AP Tcl_GetTimeProc getProc in Pointer to handler function replacing \fBTcl_GetTime\fR's access to the OS. .AP Tcl_ScaleTimeProc scaleProc in Pointer to handler function for the conversion of time delays in the virtual domain to real-time. .AP ClientData clientData in Value passed through to the two handler functions. .AP Tcl_GetTimeProc *getProcPtr out Pointer to place the currently registered get handler function into. .AP Tcl_ScaleTimeProc *scaleProcPtr out Pointer to place the currently registered scale handler function into. .AP ClientData *clientDataPtr out Pointer to place the currently registered pass-through value into. .BE .SH DESCRIPTION .PP The \fBTcl_GetTime\fR function retrieves the current time as a \fITcl_Time\fR structure in memory the caller provides. This structure has the following definition: |
| ︙ | ︙ | |||
79 80 81 82 83 84 85 |
any argument which is NULL is ignored and not set.
.PP
The signatures of the handler functions are as follows:
.PP
.CS
typedef void \fBTcl_GetTimeProc\fR(
Tcl_Time *\fItimebuf\fR,
| | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 |
any argument which is NULL is ignored and not set.
.PP
The signatures of the handler functions are as follows:
.PP
.CS
typedef void \fBTcl_GetTimeProc\fR(
Tcl_Time *\fItimebuf\fR,
ClientData \fIclientData\fR);
typedef void \fBTcl_ScaleTimeProc\fR(
Tcl_Time *\fItimebuf\fR,
ClientData \fIclientData\fR);
.CE
.PP
The \fItimebuf\fR fields contain the time to manipulate, and the
\fIclientData\fR fields contain a pointer supplied at the time the handler
functions were registered.
.PP
Any handler pair specified has to return data which is consistent between
|
| ︙ | ︙ |
Changes to doc/Hash.3.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | \fBTcl_CreateHashEntry\fR(\fItablePtr, key, newPtr\fR) .sp \fBTcl_DeleteHashEntry\fR(\fIentryPtr\fR) .sp Tcl_HashEntry * \fBTcl_FindHashEntry\fR(\fItablePtr, key\fR) .sp | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | \fBTcl_CreateHashEntry\fR(\fItablePtr, key, newPtr\fR) .sp \fBTcl_DeleteHashEntry\fR(\fIentryPtr\fR) .sp Tcl_HashEntry * \fBTcl_FindHashEntry\fR(\fItablePtr, key\fR) .sp ClientData \fBTcl_GetHashValue\fR(\fIentryPtr\fR) .sp \fBTcl_SetHashValue\fR(\fIentryPtr, value\fR) .sp void * \fBTcl_GetHashKey\fR(\fItablePtr, entryPtr\fR) .sp |
| ︙ | ︙ | |||
62 63 64 65 66 67 68 | Key to use for probe into table. Exact form depends on \fIkeyType\fR used to create table. .AP int *newPtr out The word at \fI*newPtr\fR is set to 1 if a new entry was created and 0 if there was already an entry for \fIkey\fR. .AP Tcl_HashEntry *entryPtr in Pointer to hash table entry. | | | > | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | Key to use for probe into table. Exact form depends on \fIkeyType\fR used to create table. .AP int *newPtr out The word at \fI*newPtr\fR is set to 1 if a new entry was created and 0 if there was already an entry for \fIkey\fR. .AP Tcl_HashEntry *entryPtr in Pointer to hash table entry. .AP ClientData value in New value to assign to hash table entry. Need not have type ClientData, but must fit in same space as ClientData. .AP Tcl_HashSearch *searchPtr in Pointer to record to use to keep track of progress in enumerating all the entries in a hash table. .BE .SH DESCRIPTION .PP A hash table consists of zero or more entries, each consisting of a |
| ︙ | ︙ | |||
181 182 183 184 185 186 187 188 189 190 191 192 193 194 | .PP \fBTcl_FindHashEntry\fR is similar to \fBTcl_CreateHashEntry\fR except that it does not create a new entry if the key doesn't exist; instead, it returns NULL as result. .PP \fBTcl_GetHashValue\fR and \fBTcl_SetHashValue\fR are used to read and write an entry's value, respectively. .PP \fBTcl_GetHashKey\fR returns the key for a given hash table entry, either as a pointer to a string, a one-word .PQ "char *" key, or as a pointer to the first word of an array of integers, depending on the \fIkeyType\fR used to create a hash table. | > > > > > | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 | .PP \fBTcl_FindHashEntry\fR is similar to \fBTcl_CreateHashEntry\fR except that it does not create a new entry if the key doesn't exist; instead, it returns NULL as result. .PP \fBTcl_GetHashValue\fR and \fBTcl_SetHashValue\fR are used to read and write an entry's value, respectively. Values are stored and retrieved as type .QW ClientData , which is large enough to hold a pointer value. On almost all machines this is large enough to hold an integer value too. .PP \fBTcl_GetHashKey\fR returns the key for a given hash table entry, either as a pointer to a string, a one-word .PQ "char *" key, or as a pointer to the first word of an array of integers, depending on the \fIkeyType\fR used to create a hash table. |
| ︙ | ︙ | |||
219 220 221 222 223 224 225 | \fBTcl_FirstHashEntry\fR or \fBTcl_NextHashEntry\fR. .PP \fBTcl_HashStats\fR returns a dynamically-allocated string with overall information about a hash table, such as the number of entries it contains, the number of buckets in its hash array, and the utilization of the buckets. It is the caller's responsibility to free the result string | | | 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 | \fBTcl_FirstHashEntry\fR or \fBTcl_NextHashEntry\fR. .PP \fBTcl_HashStats\fR returns a dynamically-allocated string with overall information about a hash table, such as the number of entries it contains, the number of buckets in its hash array, and the utilization of the buckets. It is the caller's responsibility to free the result string by passing it to \fBckfree\fR. .PP The header file \fBtcl.h\fR defines the actual data structures used to implement hash tables. This is necessary so that clients can allocate Tcl_HashTable structures and so that macros can be used to read and write the values of entries. However, users of the hashing routines should never refer directly |
| ︙ | ︙ |
Changes to doc/InitStubs.3.
| ︙ | ︙ | |||
59 60 61 62 63 64 65 | Call \fBTcl_InitStubs\fR in the extension before calling any other Tcl functions. .IP 2) 5 Define the \fBUSE_TCL_STUBS\fR symbol. Typically, you would include the \fB\-DUSE_TCL_STUBS\fR flag when compiling the extension. .IP 3) 5 Link the extension with the Tcl stubs library instead of the standard | | | | | 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 | Call \fBTcl_InitStubs\fR in the extension before calling any other Tcl functions. .IP 2) 5 Define the \fBUSE_TCL_STUBS\fR symbol. Typically, you would include the \fB\-DUSE_TCL_STUBS\fR flag when compiling the extension. .IP 3) 5 Link the extension with the Tcl stubs library instead of the standard Tcl library. For example, to use the Tcl 8.6 ABI on Unix platforms, the library name is \fIlibtclstub8.6.a\fR; on Windows platforms, the library name is \fItclstub86.lib\fR. .PP If the extension also requires the Tk API, it must also call \fBTk_InitStubs\fR to initialize the Tk stubs interface and link with the Tk stubs libraries. See the \fBTk_InitStubs\fR page for more information. .SH DESCRIPTION \fBTcl_InitStubs\fR attempts to initialize the stub table pointers |
| ︙ | ︙ |
Added doc/InitSubSyst.3.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 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) 2018 Tcl Core Team '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .so man.macros .TH Tcl_InitSubsystems 3 8.7 Tcl "Tcl Library Procedures" .BS .SH NAME Tcl_InitSubsystems \- initialize the Tcl library. .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp void \fBTcl_InitSubsystems\fR(\fIvoid\fR) .SH DESCRIPTION .PP The \fBTcl_InitSubsystems\fR procedure initializes the Tcl library. This procedure is typically invoked as the very first thing in the application's main program. .PP \fBTcl_InitSubsystems\fR is very similar in use to \fBTcl_FindExecutable\fR. It can be used when Tcl is used as utility library, no other encodings than utf8, iso8859-1 or unicode are used, and no interest exists in the value of \fBinfo nameofexecutable\fR. The system encoding will not be extracted from the environment, but falls back to iso8859-1. .SH KEYWORDS binary, executable file |
Changes to doc/Interp.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | | | | | > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < | < < < < < < < < < < < < < < < < < < < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 |
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH Tcl_Interp 3 8.7 Tcl "Tcl Library Procedures"
.so man.macros
.BS
.SH NAME
Tcl_Interp \- client-visible fields of interpreter structures
.SH SYNOPSIS
.nf
\fB#include <tcl.h>\fR
.sp
typedef struct {
char *\fIresult\fR; /* NO LONGER AVAILABLE */
Tcl_FreeProc *\fIfreeProc\fR; /* NO LONGER AVAILABLE */
int \fIerrorLine\fR; /* NO LONGER AVAILABLE */
} \fBTcl_Interp\fR;
typedef void \fBTcl_FreeProc\fR(
char *\fIblockPtr\fR);
.BE
.SH DESCRIPTION
.PP
The \fBTcl_CreateInterp\fR procedure returns a pointer to a \fBTcl_Interp\fR
structure. Callers of \fBTcl_CreateInterp\fR should use this pointer
as an opaque token, suitable for nothing other than passing back to
other routines in the Tcl interface from the same thread that called
\fBTcl_CreateInterp\fR. The \fBTcl_Interp\fR struct no longer has any
supported client-visible fields. Supported public routines such as
\fBTcl_SetResult\fR, \fBTcl_GetResult\fR, \fBTcl_SetErrorLine\fR,
\fBTcl_GetErrorLine\fR must be used instead.
.PP
Any legacy programs and extensions trying to access the fields above
in their source code will need conversion to compile for Tcl 8.7 and later.
.SH KEYWORDS
interpreter, result
|
Changes to doc/Limit.3.
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | Function to call when a particular limit is exceeded. If the \fIhandlerProc\fR removes or raises the limit during its processing, the limited interpreter will be permitted to continue to process after the handler returns. Many handlers may be attached to the same interpreter limit; their order of execution is not defined, and they must be identified by \fIhandlerProc\fR and \fIclientData\fR when they are deleted. | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 | Function to call when a particular limit is exceeded. If the \fIhandlerProc\fR removes or raises the limit during its processing, the limited interpreter will be permitted to continue to process after the handler returns. Many handlers may be attached to the same interpreter limit; their order of execution is not defined, and they must be identified by \fIhandlerProc\fR and \fIclientData\fR when they are deleted. .AP ClientData clientData in Arbitrary pointer-sized word used to pass some context to the \fIhandlerProc\fR function. .AP Tcl_LimitHandlerDeleteProc *deleteProc in Function to call whenever a handler is deleted. May be NULL if the \fIclientData\fR requires no deletion. .BE .SH DESCRIPTION |
| ︙ | ︙ | |||
158 159 160 161 162 163 164 | To add a handler callback to be invoked when a limit is exceeded, call \fBTcl_LimitAddHandler\fR. The \fIhandlerProc\fR argument describes the function that will actually be called; it should have the following prototype: .PP .CS typedef void \fBTcl_LimitHandlerProc\fR( | | | | 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 |
To add a handler callback to be invoked when a limit is exceeded, call
\fBTcl_LimitAddHandler\fR. The \fIhandlerProc\fR argument describes
the function that will actually be called; it should have the
following prototype:
.PP
.CS
typedef void \fBTcl_LimitHandlerProc\fR(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR);
.CE
.PP
The \fIclientData\fR argument to the handler will be whatever is
passed to the \fIclientData\fR argument to \fBTcl_LimitAddHandler\fR,
and the \fIinterp\fR is the interpreter that had its limit exceeded.
.PP
The \fIdeleteProc\fR argument to \fBTcl_LimitAddHandler\fR is a
function to call to delete the \fIclientData\fR value. It may be
\fBTCL_STATIC\fR or NULL if no deletion action is necessary, or
\fBTCL_DYNAMIC\fR if all that is necessary is to free the structure with
\fBTcl_Free\fR. Otherwise, it should refer to a function with the
following prototype:
.PP
.CS
typedef void \fBTcl_LimitHandlerDeleteProc\fR(
ClientData \fIclientData\fR);
.CE
.PP
A limit handler may be deleted using \fBTcl_LimitRemoveHandler\fR; the
handler removed will be the first one found (out of the handlers added
with \fBTcl_LimitAddHandler\fR) with exactly matching \fItype\fR,
\fIhandlerProc\fR and \fIclientData\fR arguments. This function
always invokes the \fIdeleteProc\fR on the \fIclientData\fR (unless
the \fIdeleteProc\fR was NULL or \fBTCL_STATIC\fR).
.SH KEYWORDS
interpreter, resource, limit, commands, time, callback
|
Changes to doc/LinkVar.3.
| ︙ | ︙ | |||
55 56 57 58 59 60 61 | In \fBTcl_LinkArray\fR, the additional linked types \fBTCL_LINK_CHARS\fR and \fBTCL_LINK_BYTES\fR may be used. .VE "TIP 312" .sp All the above for both functions may be optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR to make the Tcl variable read-only. | | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | In \fBTcl_LinkArray\fR, the additional linked types \fBTCL_LINK_CHARS\fR and \fBTCL_LINK_BYTES\fR may be used. .VE "TIP 312" .sp All the above for both functions may be optionally OR'ed with \fBTCL_LINK_READ_ONLY\fR to make the Tcl variable read-only. .AP int size in .VS "TIP 312" The number of elements in the C array. Must be greater than zero. .VE "TIP 312" .BE .SH DESCRIPTION .PP \fBTcl_LinkVar\fR uses variable traces to keep the Tcl variable |
| ︙ | ︙ | |||
92 93 94 95 96 97 98 | \fBTCL_LINK_INT\fR . The C variable, or each element of the C array, is of type \fBint\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR; attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty | | | | | 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 | \fBTCL_LINK_INT\fR . The C variable, or each element of the C array, is of type \fBint\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR; attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/decimal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_UINT\fR . The C variable, or each element of the C array, is of type \fBunsigned int\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetWideIntFromObj\fR and in the platform's defined range for the \fBunsigned int\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/decimal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_CHAR\fR . The C variable, or each element of the C array, is of type \fBchar\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR and be in the range of the \fBchar\fR datatype; attempts to write non-integer or out-of-range values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/decimal/binary prefix) are accepted as if they are valid too. .RS .PP .VS "TIP 312" If using an array of these, consider using \fBTCL_LINK_CHARS\fR instead. .VE "TIP 312" .RE .TP |
| ︙ | ︙ | |||
137 138 139 140 141 142 143 | . The C variable, or each element of the C array, is of type \fBunsigned char\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetIntFromObj\fR and in the platform's defined range for the \fBunsigned char\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer | | | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 | . The C variable, or each element of the C array, is of type \fBunsigned char\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetIntFromObj\fR and in the platform's defined range for the \fBunsigned char\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/decimal/binary prefix) are accepted as if they are valid too. .RS .PP .VS "TIP 312" If using an array of these, consider using \fBTCL_LINK_BYTES\fR instead. .VE "TIP 312" .RE |
| ︙ | ︙ | |||
162 163 164 165 166 167 168 | . The C variable, or each element of the C array, is of type \fBshort\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR and be in the range of the \fBshort\fR datatype; attempts to write non-integer or out-of-range values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the | | | | | | | | | | | 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 | . The C variable, or each element of the C array, is of type \fBshort\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetIntFromObj\fR and be in the range of the \fBshort\fR datatype; attempts to write non-integer or out-of-range values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/decimal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_USHORT\fR . The C variable, or each element of the C array, is of type \fBunsigned short\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetIntFromObj\fR and in the platform's defined range for the \fBunsigned short\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/decimal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_LONG\fR . The C variable, or each element of the C array, is of type \fBlong\fR. Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetLongFromObj\fR; attempts to write non-integer or out-of-range values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/decimal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_ULONG\fR . The C variable, or each element of the C array, is of type \fBunsigned long\fR. Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetWideIntFromObj\fR and in the platform's defined range for the \fBunsigned long\fR type; attempts to write non-integer values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/decimal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_DOUBLE\fR . The C variable, or each element of the C array, is of type \fBdouble\fR. Any value written into the Tcl variable must have a proper real form acceptable to \fBTcl_GetDoubleFromObj\fR; attempts to write non-real values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer or real representations (like the empty string, '.', '+', '-' or the hex/octal/decimal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_FLOAT\fR . The C variable, or each element of the C array, is of type \fBfloat\fR. Any value written into the Tcl variable must have a proper real form acceptable to \fBTcl_GetDoubleFromObj\fR and must be within the range acceptable for a \fBfloat\fR; attempts to write non-real values (or values outside the range) into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer or real representations (like the empty string, '.', '+', '-' or the hex/octal/decimal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_WIDE_INT\fR . The C variable, or each element of the C array, is of type \fBTcl_WideInt\fR (which is an integer type at least 64-bits wide on all platforms that can support it.) Any value written into the Tcl variable must have a proper integer form acceptable to \fBTcl_GetWideIntFromObj\fR; attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/decimal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_WIDE_UINT\fR . The C variable, or each element of the C array, is of type \fBTcl_WideUInt\fR (which is an unsigned integer type at least 64-bits wide on all platforms that can support it.) Any value written into the Tcl variable must have a proper unsigned integer form acceptable to \fBTcl_GetWideIntFromObj\fR (it will be cast to unsigned); .\" FIXME! Use bignums instead. attempts to write non-integer values into \fIvarName\fR will be rejected with Tcl errors. Incomplete integer representations (like the empty string, '+', '-' or the hex/octal/decimal/binary prefix) are accepted as if they are valid too. .TP \fBTCL_LINK_BOOLEAN\fR . The C variable, or each element of the C array, is of type \fBint\fR. If its value is zero then it will read from Tcl as .QW 0 ; otherwise it will read from Tcl as .QW 1 . Whenever \fIvarName\fR is modified, the C variable will be set to a 0 or 1 value. Any value written into the Tcl variable must have a proper boolean form acceptable to \fBTcl_GetBooleanFromObj\fR; attempts to write non-boolean values into \fIvarName\fR will be rejected with Tcl errors. .TP \fBTCL_LINK_STRING\fR . The C variable is of type \fBchar *\fR. If its value is not NULL then it must be a pointer to a string allocated with \fBTcl_Alloc\fR or \fBckalloc\fR. Whenever the Tcl variable is modified the current C string will be freed and new memory will be allocated to hold a copy of the variable's new value. If the C variable contains a NULL pointer then the Tcl variable will read as .QW NULL . This is only supported by \fBTcl_LinkVar\fR. |
| ︙ | ︙ |
Changes to doc/ListObj.3.
| ︙ | ︙ | |||
134 135 136 137 138 139 140 | the two procedures return \fBTCL_OK\fR after appending the values. .PP \fBTcl_NewListObj\fR and \fBTcl_SetListObj\fR create a new value or modify an existing value to hold the \fIobjc\fR elements of the array referenced by \fIobjv\fR where each element is a pointer to a Tcl value. If \fIobjc\fR is less than or equal to zero, | | > > | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 | the two procedures return \fBTCL_OK\fR after appending the values. .PP \fBTcl_NewListObj\fR and \fBTcl_SetListObj\fR create a new value or modify an existing value to hold the \fIobjc\fR elements of the array referenced by \fIobjv\fR where each element is a pointer to a Tcl value. If \fIobjc\fR is less than or equal to zero, they return an empty value. If \fIobjv\fR is NULL, the resulting list contains 0 elements, with reserved space in an internal representation for \fIobjc\fR more elements (to avoid its reallocation later). The new value's string representation is left invalid. The two procedures increment the reference counts of the elements in \fIobjc\fR since the list value now refers to them. The new list value returned by \fBTcl_NewListObj\fR has reference count zero. .PP \fBTcl_ListObjGetElements\fR returns a count and a pointer to an array of |
| ︙ | ︙ |
Changes to doc/Method.3.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 | .sp Tcl_Object \fBTcl_ObjectContextObject\fR(\fIcontext\fR) .sp int \fBTcl_ObjectContextSkippedArgs\fR(\fIcontext\fR) .SH ARGUMENTS | | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | .sp Tcl_Object \fBTcl_ObjectContextObject\fR(\fIcontext\fR) .sp int \fBTcl_ObjectContextSkippedArgs\fR(\fIcontext\fR) .SH ARGUMENTS .AS ClientData clientData in .AP Tcl_Interp *interp in/out The interpreter holding the object or class to create or update a method in. .AP Tcl_Object object in The object to create the method in. .AP Tcl_Class class in The class to create the method in. .AP Tcl_Obj *nameObj in |
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | compatibility) for a non-exported method, .VS TIP500 and \fBTCL_OO_METHOD_PRIVATE\fR for a private method. .VE TIP500 .AP Tcl_MethodType *methodTypePtr in A description of the type of the method to create, or the type of method to compare against. | | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 | compatibility) for a non-exported method, .VS TIP500 and \fBTCL_OO_METHOD_PRIVATE\fR for a private method. .VE TIP500 .AP Tcl_MethodType *methodTypePtr in A description of the type of the method to create, or the type of method to compare against. .AP ClientData clientData in A piece of data that is passed to the implementation of the method without interpretation. .AP ClientData *clientDataPtr out A pointer to a variable in which to write the \fIclientData\fR value supplied when the method was created. If NULL, the \fIclientData\fR value will not be retrieved. .AP Tcl_Method method in A reference to a method to query. .AP Tcl_ObjectContext context in A reference to a method-call context. Note that client code \fImust not\fR |
| ︙ | ︙ | |||
209 210 211 212 213 214 215 | that the \fIclientData\fR can just be copied directly. .SS "TCL_METHODCALLPROC FUNCTION SIGNATURE" .PP Functions matching this signature are called when the method is invoked. .PP .CS typedef int \fBTcl_MethodCallProc\fR( | | | | | | 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 |
that the \fIclientData\fR can just be copied directly.
.SS "TCL_METHODCALLPROC FUNCTION SIGNATURE"
.PP
Functions matching this signature are called when the method is invoked.
.PP
.CS
typedef int \fBTcl_MethodCallProc\fR(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
Tcl_ObjectContext \fIobjectContext\fR,
int \fIobjc\fR,
Tcl_Obj *const *\fIobjv\fR);
.CE
.PP
The \fIclientData\fR argument to a Tcl_MethodCallProc is the value that was
given when the method was created, the \fIinterp\fR is a place in which to
execute scripts and access variables as well as being where to put the result
of the method, and the \fIobjc\fR and \fIobjv\fR fields give the parameter
objects to the method. The calling context of the method can be discovered
through the \fIobjectContext\fR argument, and the return value from a
Tcl_MethodCallProc is any Tcl return code (e.g. TCL_OK, TCL_ERROR).
.SS "TCL_METHODDELETEPROC FUNCTION SIGNATURE"
.PP
Functions matching this signature are used when a method is deleted, whether
through a new method being created or because the object or class is deleted.
.PP
.CS
typedef void \fBTcl_MethodDeleteProc\fR(
ClientData \fIclientData\fR);
.CE
.PP
The \fIclientData\fR argument to a Tcl_MethodDeleteProc will be the same as
the value passed to the \fIclientData\fR argument to \fBTcl_NewMethod\fR or
\fBTcl_NewInstanceMethod\fR when the method was created.
.SS "TCL_CLONEPROC FUNCTION SIGNATURE"
.PP
Functions matching this signature are used to copy a method when the object or
class is copied using \fBTcl_CopyObjectInstance\fR (or \fBoo::copy\fR).
.PP
.CS
typedef int \fBTcl_CloneProc\fR(
Tcl_Interp *\fIinterp\fR,
ClientData \fIoldClientData\fR,
ClientData *\fInewClientDataPtr\fR);
.CE
.PP
The \fIinterp\fR argument gives a place to write an error message when the
attempt to clone the object is to fail, in which case the clone procedure must
also return TCL_ERROR; it should return TCL_OK otherwise.
The \fIoldClientData\fR field to a Tcl_CloneProc gives the value from the
method being copied from, and the \fInewClientDataPtr\fR field will point to
|
| ︙ | ︙ |
Changes to doc/NRE.3.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 | .AP Tcl_ObjCmdProc *proc in Called in order to evaluate a command. Is often just a small wrapper that uses \fBTcl_NRCallObjProc\fR to call \fInreProc\fR using a new trampoline. Behaves in the same way as the \fIproc\fR argument to \fBTcl_CreateObjCommand\fR(3) (\fIq.v.\fR). .AP Tcl_ObjCmdProc *nreProc in Called instead of \fIproc\fR when a trampoline is already in use. | | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | .AP Tcl_ObjCmdProc *proc in Called in order to evaluate a command. Is often just a small wrapper that uses \fBTcl_NRCallObjProc\fR to call \fInreProc\fR using a new trampoline. Behaves in the same way as the \fIproc\fR argument to \fBTcl_CreateObjCommand\fR(3) (\fIq.v.\fR). .AP Tcl_ObjCmdProc *nreProc in Called instead of \fIproc\fR when a trampoline is already in use. .AP ClientData clientData in Arbitrary one-word value passed to \fIproc\fR, \fInreProc\fR, \fIdeleteProc\fR and \fIobjProc\fR. .AP Tcl_CmdDeleteProc *deleteProc in/out Called before \fIcmdName\fR is deleted from the interpreter, allowing for command-specific cleanup. May be NULL. .AP int objc in Number of items in \fIobjv\fR. |
| ︙ | ︙ | |||
68 69 70 71 72 73 74 | Token to use instead of one derived from the first word of \fIobjv\fR in order to evaluate a command. .AP Tcl_Obj *resultPtr out Pointer to an unshared Tcl_Obj where the result of the evaluation is stored if the return code is TCL_OK. .AP Tcl_NRPostProc *postProcPtr in A function to push. | | | | | | 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 | Token to use instead of one derived from the first word of \fIobjv\fR in order to evaluate a command. .AP Tcl_Obj *resultPtr out Pointer to an unshared Tcl_Obj where the result of the evaluation is stored if the return code is TCL_OK. .AP Tcl_NRPostProc *postProcPtr in A function to push. .AP ClientData data0 in .AP ClientData data1 in .AP ClientData data2 in .AP ClientData data3 in \fIdata0\fR through \fIdata3\fR are four one-word values that will be passed to the function designated by \fIpostProcPtr\fR when it is invoked. .BE .SH DESCRIPTION .PP These functions provide an interface to the function stack that an interpreter iterates through to evaluate commands. The routine behind a command is |
| ︙ | ︙ | |||
126 127 128 129 130 131 132 | .PP \fBTcl_NRAddCallback\fR pushes \fIpostProcPtr\fR. The signature for \fBTcl_NRPostProc\fR is: .PP .CS typedef int \fBTcl_NRPostProc\fR( | | | | 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 |
.PP
\fBTcl_NRAddCallback\fR pushes \fIpostProcPtr\fR. The signature for
\fBTcl_NRPostProc\fR is:
.PP
.CS
typedef int
\fBTcl_NRPostProc\fR(
\fBClientData\fR \fIdata\fR[],
\fBTcl_Interp\fR *\fIinterp\fR,
int \fIresult\fR);
.CE
.PP
\fIdata\fR is a pointer to an array containing \fIdata0\fR through \fIdata3\fR.
\fIresult\fR is the value returned by the previous function implementing part
the routine.
.SH EXAMPLE
.PP
The following command uses \fBTcl_EvalObjEx\fR, which consumes space on the C
stack, to evalute a script:
.PP
.CS
int
\fITheCmdOldObjProc\fR(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int result;
Tcl_Obj *objPtr;
|
| ︙ | ︙ | |||
173 174 175 176 177 178 179 | trampoline instead of consuming space on the C stack. A new version of \fITheCmdOldObjProc\fR is just a a wrapper that uses \fBTcl_NRCallObjProc\fR to call \fITheCmdNRObjProc\fR: .PP .CS int \fITheCmdOldObjProc\fR( | | | | | 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 |
trampoline instead of consuming space on the C stack. A new version of
\fITheCmdOldObjProc\fR is just a a wrapper that uses \fBTcl_NRCallObjProc\fR to
call \fITheCmdNRObjProc\fR:
.PP
.CS
int
\fITheCmdOldObjProc\fR(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
return \fBTcl_NRCallObjProc\fR(interp, \fITheCmdNRObjProc\fR,
clientData, objc, objv);
}
.CE
.PP
.CS
int
\fITheCmdNRObjProc\fR
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *objPtr;
\fI... preparation ...\fR
\fBTcl_NRAddCallback\fR(interp, \fITheCmdPostProc\fR,
data0, data1, data2, data3);
/* \fIdata0 .. data3\fR are up to four one-word items to
* pass to the postprocessing procedure */
return \fBTcl_NREvalObj\fR(interp, objPtr, 0);
}
.CE
.PP
.CS
int
\fITheCmdNRPostProc\fR(
ClientData data[],
Tcl_Interp *interp,
int result)
{
/* \fIdata[0] .. data[3]\fR are the four words of data
* passed to \fBTcl_NRAddCallback\fR */
\fI... postprocessing ...\fR
|
| ︙ | ︙ |
Changes to doc/Namespace.3.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 | .SH ARGUMENTS .AS Tcl_NamespaceDeleteProc allowOverwrite in/out .AP Tcl_Interp *interp in/out The interpreter in which the namespace exists and where name lookups are performed. Also where error result messages are written. .AP "const char" *name in The name of the namespace or command to be created or accessed. | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | .SH ARGUMENTS .AS Tcl_NamespaceDeleteProc allowOverwrite in/out .AP Tcl_Interp *interp in/out The interpreter in which the namespace exists and where name lookups are performed. Also where error result messages are written. .AP "const char" *name in The name of the namespace or command to be created or accessed. .AP ClientData clientData in A context pointer by the creator of the namespace. Not interpreted by Tcl at all. .AP Tcl_NamespaceDeleteProc *deleteProc in A pointer to function to call when the namespace is deleted, or NULL if no such callback is to be performed. .AP Tcl_Namespace *nsPtr in The namespace to be manipulated, or NULL (for other than |
| ︙ | ︙ | |||
113 114 115 116 117 118 119 | the global namespace.) .PP \fBTcl_CreateNamespace\fR creates a new namespace. The \fIdeleteProc\fR will have the following type signature: .PP .CS typedef void \fBTcl_NamespaceDeleteProc\fR( | | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
the global namespace.)
.PP
\fBTcl_CreateNamespace\fR creates a new namespace. The
\fIdeleteProc\fR will have the following type signature:
.PP
.CS
typedef void \fBTcl_NamespaceDeleteProc\fR(
ClientData \fIclientData\fR);
.CE
.PP
\fBTcl_DeleteNamespace\fR deletes a namespace, calling the
\fIdeleteProc\fR defined for the namespace (if any).
.PP
\fBTcl_AppendExportList\fR retrieves the export patterns for a
namespace given namespace and appends them (as list items) to
|
| ︙ | ︙ |
Changes to doc/Notifier.3.
| ︙ | ︙ | |||
34 35 36 37 38 39 40 | .sp Tcl_ThreadId \fBTcl_GetCurrentThread\fR() .sp void \fBTcl_DeleteEvents\fR(\fIdeleteProc, clientData\fR) .sp | | | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | .sp Tcl_ThreadId \fBTcl_GetCurrentThread\fR() .sp void \fBTcl_DeleteEvents\fR(\fIdeleteProc, clientData\fR) .sp ClientData \fBTcl_InitNotifier\fR() .sp void \fBTcl_FinalizeNotifier\fR(\fIclientData\fR) .sp int \fBTcl_WaitForEvent\fR(\fItimePtr\fR) |
| ︙ | ︙ | |||
74 75 76 77 78 79 80 | .AS Tcl_EventDeleteProc *notifierProcPtr .AP Tcl_EventSetupProc *setupProc in Procedure to invoke to prepare for event wait in \fBTcl_DoOneEvent\fR. .AP Tcl_EventCheckProc *checkProc in Procedure for \fBTcl_DoOneEvent\fR to invoke after waiting for events. Checks to see if any events have occurred and, if so, queues them. | | | | 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 | .AS Tcl_EventDeleteProc *notifierProcPtr .AP Tcl_EventSetupProc *setupProc in Procedure to invoke to prepare for event wait in \fBTcl_DoOneEvent\fR. .AP Tcl_EventCheckProc *checkProc in Procedure for \fBTcl_DoOneEvent\fR to invoke after waiting for events. Checks to see if any events have occurred and, if so, queues them. .AP ClientData clientData in Arbitrary one-word value to pass to \fIsetupProc\fR, \fIcheckProc\fR, or \fIdeleteProc\fR. .AP "const Tcl_Time" *timePtr in Indicates the maximum amount of time to wait for an event. This is specified as an interval (how long to wait), not an absolute time (when to wakeup). If the pointer passed to \fBTcl_WaitForEvent\fR is NULL, it means there is no maximum wait time: wait forever if necessary. .AP Tcl_Event *evPtr in An event to add to the event queue. The storage for the event must have been allocated by the caller using \fBTcl_Alloc\fR or \fBckalloc\fR. .AP Tcl_QueuePosition position in Where to add the new event in the queue: \fBTCL_QUEUE_TAIL\fR, \fBTCL_QUEUE_HEAD\fR, or \fBTCL_QUEUE_MARK\fR. .AP Tcl_ThreadId threadId in A unique identifier for a thread. .AP Tcl_EventDeleteProc *deleteProc in Procedure to invoke for each queued event in \fBTcl_DeleteEvents\fR. |
| ︙ | ︙ | |||
128 129 130 131 132 133 134 | source must work with the notifier to detect events at the right times, record them on the event queue, and eventually notify higher-level software that they have occurred. The procedures \fBTcl_CreateEventSource\fR, \fBTcl_DeleteEventSource\fR, and \fBTcl_SetMaxBlockTime\fR, \fBTcl_QueueEvent\fR, and \fBTcl_DeleteEvents\fR are used primarily by event sources. .IP [2] | < | | | | | | | < < | | < < | 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 | source must work with the notifier to detect events at the right times, record them on the event queue, and eventually notify higher-level software that they have occurred. The procedures \fBTcl_CreateEventSource\fR, \fBTcl_DeleteEventSource\fR, and \fBTcl_SetMaxBlockTime\fR, \fBTcl_QueueEvent\fR, and \fBTcl_DeleteEvents\fR are used primarily by event sources. .IP [2] The event queue: there is a single queue for each thread containing a Tcl interpreter, containing events that have been detected but not yet serviced. Event sources place events onto the queue so that they may be processed in order at appropriate times during the event loop. The event queue guarantees a fair discipline of event handling, so that no event source can starve the others. It also allows events to be saved for servicing at a future time. \fBTcl_QueueEvent\fR is used (primarily by event sources) to add events to the current thread's event queue and \fBTcl_DeleteEvents\fR is used to remove events from the queue without processing them. .IP [3] The event loop: in order to detect and process events, the application enters a loop that waits for events to occur, places them on the event queue, and then processes them. Most applications will do this by calling the procedure \fBTcl_DoOneEvent\fR, which is described in a separate manual entry. .PP |
| ︙ | ︙ | |||
226 227 228 229 230 231 232 | The procedure \fBTcl_CreateEventSource\fR creates a new event source. Its arguments specify the setup procedure and check procedure for the event source. \fISetupProc\fR should match the following prototype: .PP .CS typedef void \fBTcl_EventSetupProc\fR( | | | 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 |
The procedure \fBTcl_CreateEventSource\fR creates a new event source.
Its arguments specify the setup procedure and check procedure for
the event source.
\fISetupProc\fR should match the following prototype:
.PP
.CS
typedef void \fBTcl_EventSetupProc\fR(
ClientData \fIclientData\fR,
int \fIflags\fR);
.CE
.PP
The \fIclientData\fR argument will be the same as the \fIclientData\fR
argument to \fBTcl_CreateEventSource\fR; it is typically used to
point to private information managed by the event source.
The \fIflags\fR argument will be the same as the \fIflags\fR
|
| ︙ | ︙ | |||
304 305 306 307 308 309 310 | The second procedure provided by each event source is its check procedure, indicated by the \fIcheckProc\fR argument to \fBTcl_CreateEventSource\fR. \fICheckProc\fR must match the following prototype: .PP .CS typedef void \fBTcl_EventCheckProc\fR( | | | 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 |
The second procedure provided by each event source is its check
procedure, indicated by the \fIcheckProc\fR argument to
\fBTcl_CreateEventSource\fR. \fICheckProc\fR must match the
following prototype:
.PP
.CS
typedef void \fBTcl_EventCheckProc\fR(
ClientData \fIclientData\fR,
int \fIflags\fR);
.CE
.PP
The arguments to this procedure are the same as those for \fIsetupProc\fR.
\fBCheckProc\fR is invoked by \fBTcl_DoOneEvent\fR after it has waited
for events. Presumably at least one event source is now prepared to
queue an event. \fBTcl_DoOneEvent\fR calls each of the event sources
|
| ︙ | ︙ | |||
395 396 397 398 399 400 401 | Another example of deferring events happens in Tk if \fBTk_RestrictEvents\fR has been invoked to defer certain kinds of window events. .PP When \fIproc\fR returns 1, \fBTcl_ServiceEvent\fR will remove the event from the event queue and free its storage. Note that the storage for an event must be allocated by | | < < < < | | | 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 |
Another example of deferring events happens in Tk if
\fBTk_RestrictEvents\fR has been invoked to defer certain kinds
of window events.
.PP
When \fIproc\fR returns 1, \fBTcl_ServiceEvent\fR will remove the
event from the event queue and free its storage.
Note that the storage for an event must be allocated by
the event source (using \fBTcl_Alloc\fR or the Tcl macro \fBckalloc\fR)
before calling \fBTcl_QueueEvent\fR, but it
will be freed by \fBTcl_ServiceEvent\fR, not by the event source.
.PP
Calling \fBTcl_QueueEvent\fR adds an event to the current thread's queue.
To add an event to another thread's queue, use \fBTcl_ThreadQueueEvent\fR.
\fBTcl_ThreadQueueEvent\fR accepts as an argument a Tcl_ThreadId argument,
which uniquely identifies a thread in a Tcl application. To obtain the
Tcl_ThreadId for the current thread, use the \fBTcl_GetCurrentThread\fR
procedure. (A thread would then need to pass this identifier to other
threads for those threads to be able to add events to its queue.)
After adding an event to another thread's queue, you then typically
need to call \fBTcl_ThreadAlert\fR to
.QW "wake up"
that thread's notifier to alert it to the new event.
.PP
\fBTcl_DeleteEvents\fR can be used to explicitly remove one or more
events from the event queue. \fBTcl_DeleteEvents\fR calls \fIproc\fR
for each event in the queue, deleting those for with the procedure
returns 1. Events for which the procedure returns 0 are left in the
queue. \fIProc\fR should match the following prototype:
.PP
.CS
typedef int \fBTcl_EventDeleteProc\fR(
Tcl_Event *\fIevPtr\fR,
ClientData \fIclientData\fR);
.CE
.PP
The \fIclientData\fR argument will be the same as the \fIclientData\fR
argument to \fBTcl_DeleteEvents\fR; it is typically used to point to
private information managed by the event source. The \fIevPtr\fR will
point to the next event in the queue.
.PP
|
| ︙ | ︙ | |||
494 495 496 497 498 499 500 | elapsed). Finally, a return value of \-1 means that the event loop is no longer operational and the application should probably unwind and terminate. Under Windows this happens when a WM_QUIT message is received; under Unix it happens when \fBTcl_WaitForEvent\fR would have waited forever because there were no active event sources and the timeout was infinite. .PP | | < | 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 | elapsed). Finally, a return value of \-1 means that the event loop is no longer operational and the application should probably unwind and terminate. Under Windows this happens when a WM_QUIT message is received; under Unix it happens when \fBTcl_WaitForEvent\fR would have waited forever because there were no active event sources and the timeout was infinite. .PP \fBTcl_AlertNotifier\fR is used to allow any thread to .QW "wake up" the notifier to alert it to new events on its queue. \fBTcl_AlertNotifier\fR requires as an argument the notifier handle returned by \fBTcl_InitNotifier\fR. .PP If the notifier will be used with an external event loop, then it must also support the \fBTcl_SetTimer\fR interface. \fBTcl_SetTimer\fR is |
| ︙ | ︙ |
Changes to doc/Object.3.
| ︙ | ︙ | |||
107 108 109 110 111 112 113 |
.SH "THE TCL_OBJ STRUCTURE"
.PP
Each Tcl value is represented by a \fBTcl_Obj\fR structure
which is defined as follows.
.PP
.CS
typedef struct Tcl_Obj {
| | | | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 |
.SH "THE TCL_OBJ STRUCTURE"
.PP
Each Tcl value is represented by a \fBTcl_Obj\fR structure
which is defined as follows.
.PP
.CS
typedef struct Tcl_Obj {
int \fIrefCount\fR;
char *\fIbytes\fR;
int \fIlength\fR;
const Tcl_ObjType *\fItypePtr\fR;
union {
long \fIlongValue\fR;
double \fIdoubleValue\fR;
void *\fIotherValuePtr\fR;
Tcl_WideInt \fIwideValue\fR;
struct {
|
| ︙ | ︙ |
Changes to doc/ObjectType.3.
| ︙ | ︙ | |||
81 82 83 84 85 86 87 | Any internal representation for \fIobjPtr\fR's old type is freed. If an error occurs during conversion, it returns \fBTCL_ERROR\fR and leaves an error message in the result value for \fIinterp\fR unless \fIinterp\fR is NULL. Otherwise, it returns \fBTCL_OK\fR. Passing a NULL \fIinterp\fR allows this procedure to be used as a test whether the conversion can be done (and in fact was done). | < < | 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 | Any internal representation for \fIobjPtr\fR's old type is freed. If an error occurs during conversion, it returns \fBTCL_ERROR\fR and leaves an error message in the result value for \fIinterp\fR unless \fIinterp\fR is NULL. Otherwise, it returns \fBTCL_OK\fR. Passing a NULL \fIinterp\fR allows this procedure to be used as a test whether the conversion can be done (and in fact was done). .PP In many cases, the \fItypePtr->setFromAnyProc\fR routine will set \fIobjPtr->typePtr\fR to the argument value \fItypePtr\fR, but that is no longer guaranteed. The \fIsetFromAnyProc\fR is free to set the internal representation for \fIobjPtr\fR to make use of another related Tcl_ObjType, if it sees fit. .SH "THE TCL_OBJTYPE STRUCTURE" .PP Extension writers can define new value types by defining four procedures and initializing a Tcl_ObjType structure to describe the type. Extension writers may also pass a pointer to their Tcl_ObjType structure to \fBTcl_RegisterObjType\fR if they wish to permit |
| ︙ | ︙ | |||
182 183 184 185 186 187 188 | We require the string representation's byte array to have a null after the last byte, at offset \fIlength\fR, and to have no null bytes before that; this allows string representations to be treated as conventional null character-terminated C strings. These restrictions are easily met by using Tcl's internal UTF encoding for the string representation, same as one would do for other Tcl routines accepting string values as arguments. | | | | 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 | We require the string representation's byte array to have a null after the last byte, at offset \fIlength\fR, and to have no null bytes before that; this allows string representations to be treated as conventional null character-terminated C strings. These restrictions are easily met by using Tcl's internal UTF encoding for the string representation, same as one would do for other Tcl routines accepting string values as arguments. Storage for the byte array must be allocated in the heap by \fBTcl_Alloc\fR or \fBckalloc\fR. Note that \fIupdateStringProc\fRs must allocate enough storage for the string's bytes and the terminating null byte. .PP The \fIupdateStringProc\fR for Tcl's built-in double type, for example, calls Tcl_PrintDouble to write to a buffer of size TCL_DOUBLE_SPACE, then allocates and copies the string representation to just enough space to hold it. A pointer to the allocated space is stored in the \fIbytes\fR member. |
| ︙ | ︙ |
Changes to doc/OpenFileChnl.3.
| ︙ | ︙ | |||
49 50 51 52 53 54 55 | .sp int \fBTcl_ReadChars\fR(\fIchannel, readObjPtr, charsToRead, appendFlag\fR) .sp int \fBTcl_Read\fR(\fIchannel, readBuf, bytesToRead\fR) .sp | | | | | | | | | | 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 | .sp int \fBTcl_ReadChars\fR(\fIchannel, readObjPtr, charsToRead, appendFlag\fR) .sp int \fBTcl_Read\fR(\fIchannel, readBuf, bytesToRead\fR) .sp int \fBTcl_GetsObj\fR(\fIchannel, lineObjPtr\fR) .sp int \fBTcl_Gets\fR(\fIchannel, lineRead\fR) .sp int \fBTcl_Ungets\fR(\fIchannel, input, inputLen, addAtEnd\fR) .sp int \fBTcl_WriteObj\fR(\fIchannel, writeObjPtr\fR) .sp int \fBTcl_WriteChars\fR(\fIchannel, charBuf, bytesToWrite\fR) .sp int \fBTcl_Write\fR(\fIchannel, byteBuf, bytesToWrite\fR) .sp int \fBTcl_ReadRaw\fR(\fIchannel, readBuf, bytesToRead\fR) .sp int \fBTcl_WriteRaw\fR(\fIchannel, byteBuf, bytesToWrite\fR) .sp int \fBTcl_Eof\fR(\fIchannel\fR) .sp int \fBTcl_Flush\fR(\fIchannel\fR) |
| ︙ | ︙ | |||
130 131 132 133 134 135 136 | \fBTCL_ENFORCE_MODE\fR. If \fBTCL_STDIN\fR is set, stdin for the first child in the pipe is the pipe channel, otherwise it is the same as the standard input of the invoking process; likewise for \fBTCL_STDOUT\fR and \fBTCL_STDERR\fR. If \fBTCL_ENFORCE_MODE\fR is not set, then the pipe can redirect stdio handles to override the stdio handles for which \fBTCL_STDIN\fR, \fBTCL_STDOUT\fR and \fBTCL_STDERR\fR have been set. If it is set, then such redirections cause an error. | | | | | | | 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 | \fBTCL_ENFORCE_MODE\fR. If \fBTCL_STDIN\fR is set, stdin for the first child in the pipe is the pipe channel, otherwise it is the same as the standard input of the invoking process; likewise for \fBTCL_STDOUT\fR and \fBTCL_STDERR\fR. If \fBTCL_ENFORCE_MODE\fR is not set, then the pipe can redirect stdio handles to override the stdio handles for which \fBTCL_STDIN\fR, \fBTCL_STDOUT\fR and \fBTCL_STDERR\fR have been set. If it is set, then such redirections cause an error. .AP ClientData handle in Operating system specific handle for I/O to a file. For Unix this is a file descriptor, for Windows it is a HANDLE. .AP int readOrWrite in OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR to indicate what operations are valid on \fIhandle\fR. .AP "const char" *channelName in The name of the channel. .AP int *modePtr out Points at an integer variable that will receive an OR-ed combination of \fBTCL_READABLE\fR and \fBTCL_WRITABLE\fR denoting whether the channel is open for reading and writing. .AP "const char" *pattern in The pattern to match on, passed to Tcl_StringMatch, or NULL. .AP Tcl_Channel channel in A Tcl channel for input or output. Must have been the return value from a procedure such as \fBTcl_OpenFileChannel\fR. .AP Tcl_Obj *readObjPtr in/out A pointer to a Tcl value in which to store the characters read from the channel. .AP int charsToRead in The number of characters to read from the channel. If the channel's encoding is \fBbinary\fR, this is equivalent to the number of bytes to read from the channel. .AP int appendFlag in If non-zero, data read from the channel will be appended to the value. Otherwise, the data will replace the existing contents of the value. .AP char *readBuf out A buffer in which to store the bytes read from the channel. .AP int bytesToRead in The number of bytes to read from the channel. The buffer \fIreadBuf\fR must be large enough to hold this many bytes. .AP Tcl_Obj *lineObjPtr in/out A pointer to a Tcl value in which to store the line read from the channel. The line read will be appended to the current value of the value. .AP Tcl_DString *lineRead in/out A pointer to a Tcl dynamic string in which to store the line read from the channel. Must have been initialized by the caller. The line read will be appended to any data already in the dynamic string. .AP "const char" *input in The input to add to a channel buffer. .AP int inputLen in Length of the input .AP int addAtEnd in Flag indicating whether the input should be added to the end or beginning of the channel buffer. .AP Tcl_Obj *writeObjPtr in A pointer to a Tcl value whose contents will be output to the channel. .AP "const char" *charBuf in A buffer containing the characters to output to the channel. .AP "const char" *byteBuf in A buffer containing the bytes to output to the channel. .AP int bytesToWrite in The number of bytes to consume from \fIcharBuf\fR or \fIbyteBuf\fR and output to the channel. .AP Tcl_WideInt offset in How far to move the access point in the channel at which the next input or output operation will be applied, measured in bytes from the position given by \fIseekMode\fR. May be either positive or negative. .AP int seekMode in |
| ︙ | ︙ | |||
273 274 275 276 277 278 279 | error for argc and argv to override stdio channels for which \fBTCL_STDIN\fR, \fBTCL_STDOUT\fR, and \fBTCL_STDERR\fR have been set. .PP If an error occurs while opening the channel, \fBTcl_OpenCommandChannel\fR returns NULL and records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. In addition, \fBTcl_OpenCommandChannel\fR leaves an error message in | | | 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 | error for argc and argv to override stdio channels for which \fBTCL_STDIN\fR, \fBTCL_STDOUT\fR, and \fBTCL_STDERR\fR have been set. .PP If an error occurs while opening the channel, \fBTcl_OpenCommandChannel\fR returns NULL and records a POSIX error code that can be retrieved with \fBTcl_GetErrno\fR. In addition, \fBTcl_OpenCommandChannel\fR leaves an error message in the interpreter's result. \fIinterp\fR cannot be NULL. .PP The newly created channel is not registered in the supplied interpreter; to register it, use \fBTcl_RegisterChannel\fR, described below. If one of the standard channels, \fBstdin\fR, \fBstdout\fR or \fBstderr\fR was previously closed, the act of creating the new channel also assigns it as a replacement for the standard channel. .SH TCL_MAKEFILECHANNEL |
| ︙ | ︙ |
Changes to doc/OpenTcp.3.
| ︙ | ︙ | |||
46 47 48 49 50 51 52 | for the local end of the connection. If NULL, a default interface is chosen. .AP int async in If nonzero, the client socket is connected asynchronously to the server. .AP "unsigned int" flags in ORed combination of \fBTCL_TCPSERVER\fR flags that specify additional informations about the socket being created. | | | | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | for the local end of the connection. If NULL, a default interface is chosen. .AP int async in If nonzero, the client socket is connected asynchronously to the server. .AP "unsigned int" flags in ORed combination of \fBTCL_TCPSERVER\fR flags that specify additional informations about the socket being created. .AP ClientData sock in Platform-specific handle for client TCP socket. .AP Tcl_TcpAcceptProc *proc in Pointer to a procedure to invoke each time a new connection is accepted via the socket. .AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .BE .SH DESCRIPTION .PP These functions are convenience procedures for creating channels that communicate over TCP sockets. The operations on a channel |
| ︙ | ︙ | |||
123 124 125 126 127 128 129 | allow connections from any network interface. Each time a client connects to this socket, Tcl creates a channel for the new connection and invokes \fIproc\fR with information about the channel. \fIProc\fR must match the following prototype: .PP .CS typedef void \fBTcl_TcpAcceptProc\fR( | | | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 |
allow connections from any network interface.
Each time a client connects to this socket, Tcl creates a channel
for the new connection and invokes \fIproc\fR with information about
the channel. \fIProc\fR must match the following prototype:
.PP
.CS
typedef void \fBTcl_TcpAcceptProc\fR(
ClientData \fIclientData\fR,
Tcl_Channel \fIchannel\fR,
char *\fIhostName\fR,
int \fIport\fR);
.CE
.PP
The \fIclientData\fR argument will be the same as the \fIclientData\fR
argument to \fBTcl_OpenTcpServer\fR, \fIchannel\fR will be the handle
|
| ︙ | ︙ |
Changes to doc/Panic.3.
1 2 3 4 5 6 7 8 9 | '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_Panic 3 8.4 Tcl "Tcl Library Procedures" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME | | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_Panic 3 8.4 Tcl "Tcl Library Procedures" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME Tcl_Panic, Tcl_PanicVA, Tcl_SetPanicProc, Tcl_ConsolePanic \- report fatal error and abort .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp void \fBTcl_Panic\fR(\fIformat\fR, \fIarg\fR, \fIarg\fR, \fI...\fR) .sp void \fBTcl_PanicVA\fR(\fIformat\fR, \fIargList\fR) .sp void \fBTcl_SetPanicProc\fR(\fIpanicProc\fR) .sp void \fBTcl_ConsolePanic\fR(\fIformat\fR, \fIarg\fR, \fIarg\fR, \fI...\fR) .sp .SH ARGUMENTS |
| ︙ | ︙ | |||
46 47 48 49 50 51 52 | same formatting rules are also used by the built-in Tcl command \fBformat\fR. .PP In a freshly loaded Tcl library, \fBTcl_Panic\fR prints the formatted error message to the standard error file of the process, and then calls \fBabort\fR to terminate the process. \fBTcl_Panic\fR does not return. On Windows, when a debugger is running, the formatted error | | | | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | same formatting rules are also used by the built-in Tcl command \fBformat\fR. .PP In a freshly loaded Tcl library, \fBTcl_Panic\fR prints the formatted error message to the standard error file of the process, and then calls \fBabort\fR to terminate the process. \fBTcl_Panic\fR does not return. On Windows, when a debugger is running, the formatted error message is sent to the debugger instead. If the windows executable does not have a stderr channel (e.g. \fBwish.exe\fR), then a system dialog box is used to display the panic message. .PP If your application doesn't use \fBTcl_Main\fR or \fBTk_Main\fR and you want to implicitly use the stderr channel of your application's C runtime (instead of the stderr channel of the C runtime used by Tcl), you can call \fBTcl_SetPanicProc\fR with \fBTcl_ConsolePanic\fR as its argument. On platforms which only have one C runtime (almost all platforms except Windows) \fBTcl_ConsolePanic\fR is equivalent to NULL. .PP \fBTcl_SetPanicProc\fR may be used to modify the behavior of \fBTcl_Panic\fR. The \fIpanicProc\fR argument should match the |
| ︙ | ︙ | |||
79 80 81 82 83 84 85 86 87 88 89 90 91 | call the Tcl library, since the original call to \fBTcl_Panic\fR indicates the Tcl library is not in a state of reliable operation. .PP The typical use of \fBTcl_SetPanicProc\fR arranges for the error message to be displayed or reported in a manner more suitable for the application or the platform. .PP Although the primary callers of \fBTcl_Panic\fR are the procedures of the Tcl library, \fBTcl_Panic\fR is a public function and may be called by any extension or application that wishes to abort the process and have a panic message displayed the same way that panic messages from Tcl will be displayed. .PP | > > > > > > | | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | call the Tcl library, since the original call to \fBTcl_Panic\fR indicates the Tcl library is not in a state of reliable operation. .PP The typical use of \fBTcl_SetPanicProc\fR arranges for the error message to be displayed or reported in a manner more suitable for the application or the platform. .PP \fBTcl_SetPanicProc\fR can not be used in stub-enabled extensions. Its symbol entry in the stub table is deprecated and it will be removed in Tcl 9.0. .PP Although the primary callers of \fBTcl_Panic\fR are the procedures of the Tcl library, \fBTcl_Panic\fR is a public function and may be called by any extension or application that wishes to abort the process and have a panic message displayed the same way that panic messages from Tcl will be displayed. .PP \fBTcl_PanicVA\fR is the same as \fBTcl_Panic\fR except that instead of taking a variable number of arguments it takes an argument list. Interfaces using argument lists have been found to be nonportable in practice. This function is deprecated and will be removed in Tcl 9.0. .SH "SEE ALSO" abort(3), printf(3), exec(n), format(n) .SH KEYWORDS abort, fatal, error |
Changes to doc/ParseArgs.3.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 | stored in \fIremObjv\fR. .AP "Tcl_Obj *const" *objv in The array of arguments to be parsed. .AP Tcl_Obj ***remObjv out Pointer to a variable that will hold the array of unprocessed arguments. Should be NULL if no return of unprocessed arguments is required. If \fIobjcPtr\fR is updated to a non-zero value, the array returned through this | | | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | stored in \fIremObjv\fR. .AP "Tcl_Obj *const" *objv in The array of arguments to be parsed. .AP Tcl_Obj ***remObjv out Pointer to a variable that will hold the array of unprocessed arguments. Should be NULL if no return of unprocessed arguments is required. If \fIobjcPtr\fR is updated to a non-zero value, the array returned through this must be deallocated using \fBckfree\fR. .BE .SH DESCRIPTION .PP The \fBTcl_ParseArgsObjv\fR function provides a system for parsing argument lists of the form .QW "\fB\-someName \fIsomeValue\fR ..." . Such argument lists are commonly found both in the arguments to a program and |
| ︙ | ︙ | |||
80 81 82 83 84 85 86 |
.CS
typedef struct {
int \fItype\fR;
const char *\fIkeyStr\fR;
void *\fIsrcPtr\fR;
void *\fIdstPtr\fR;
const char *\fIhelpStr\fR;
| | | | 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 |
.CS
typedef struct {
int \fItype\fR;
const char *\fIkeyStr\fR;
void *\fIsrcPtr\fR;
void *\fIdstPtr\fR;
const char *\fIhelpStr\fR;
ClientData \fIclientData\fR;
} \fBTcl_ArgvInfo\fR;
.CE
.PP
The \fIkeyStr\fR field contains the name of the option; by convention, this
will normally begin with a
.QW \fB\-\fR
character. The \fItype\fR, \fIsrcPtr\fR, \fIdstPtr\fR and \fIclientData\fR
fields describe the interpretation of the value of the argument, as described
below. The \fIhelpStr\fR field gives some text that is used to provide help to
users when they request it.
.PP
As noted above, the \fItype\fR field is used to describe the interpretation of
the argument's value. The following values are acceptable values for
\fItype\fR:
.TP
\fBTCL_ARGV_CONSTANT\fR
.
The argument does not take any following value argument. If this argument is
present, the (integer) value of the \fIsrcPtr\fR field is copied to the variable
pointed to by the \fIdstPtr\fR field. The \fIclientData\fR field is ignored.
.TP
\fBTCL_ARGV_END\fR
.
This value marks the end of all option descriptors in the table. All other
fields are ignored.
.TP
|
| ︙ | ︙ | |||
123 124 125 126 127 128 129 | This argument optionally takes a following value argument; it is up to the handler callback function passed in \fIsrcPtr\fR to decide. That function will have the following signature: .RS .PP .CS typedef int (\fBTcl_ArgvFuncProc\fR)( | | | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 |
This argument optionally takes a following value argument; it is up to the
handler callback function passed in \fIsrcPtr\fR to decide. That function will
have the following signature:
.RS
.PP
.CS
typedef int (\fBTcl_ArgvFuncProc\fR)(
ClientData \fIclientData\fR,
Tcl_Obj *\fIobjPtr\fR,
void *\fIdstPtr\fR);
.CE
.PP
The result is a boolean value indicating whether to consume the following
argument. The \fIclientData\fR is the value from the table entry, the
\fIobjPtr\fR is the value that represents the following argument or NULL if
|
| ︙ | ︙ | |||
145 146 147 148 149 150 151 | function passed in \fIsrcPtr\fR returns how many (or a negative number to signal an error, in which case it should also set the interpreter result). The function will have the following signature: .RS .PP .CS typedef int (\fBTcl_ArgvGenFuncProc\fR)( | | | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 |
function passed in \fIsrcPtr\fR returns how many (or a negative number to
signal an error, in which case it should also set the interpreter result). The
function will have the following signature:
.RS
.PP
.CS
typedef int (\fBTcl_ArgvGenFuncProc\fR)(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
int \fIobjc\fR,
Tcl_Obj *const *\fIobjv\fR,
void *\fIdstPtr\fR);
.CE
.PP
The \fIclientData\fR is the value from the table entry, the \fIinterp\fR is
|
| ︙ | ︙ |
Changes to doc/ParseCmd.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" 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_ParseCommand 3 8.3 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" 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_ParseCommand 3 8.3 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_ParseCommand, Tcl_ParseExpr, Tcl_ParseBraces, Tcl_ParseQuotedString, Tcl_ParseVarName, Tcl_ParseVar, Tcl_FreeParse, Tcl_EvalTokens, Tcl_EvalTokensStandard \- parse Tcl scripts and expressions .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp int \fBTcl_ParseCommand\fR(\fIinterp, start, numBytes, nested, parsePtr\fR) .sp |
| ︙ | ︙ | |||
29 30 31 32 33 34 35 36 37 38 39 40 | \fBTcl_ParseVarName\fR(\fIinterp, start, numBytes, parsePtr, append\fR) .sp const char * \fBTcl_ParseVar\fR(\fIinterp, start, termPtr\fR) .sp \fBTcl_FreeParse\fR(\fIusedParsePtr\fR) .sp int \fBTcl_EvalTokensStandard\fR(\fIinterp, tokenPtr, numTokens\fR) .SH ARGUMENTS .AS Tcl_Interp *usedParsePtr out .AP Tcl_Interp *interp out | > > > | | > | | | 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 | \fBTcl_ParseVarName\fR(\fIinterp, start, numBytes, parsePtr, append\fR) .sp const char * \fBTcl_ParseVar\fR(\fIinterp, start, termPtr\fR) .sp \fBTcl_FreeParse\fR(\fIusedParsePtr\fR) .sp Tcl_Obj * \fBTcl_EvalTokens\fR(\fIinterp, tokenPtr, numTokens\fR) .sp int \fBTcl_EvalTokensStandard\fR(\fIinterp, tokenPtr, numTokens\fR) .SH ARGUMENTS .AS Tcl_Interp *usedParsePtr out .AP Tcl_Interp *interp out For procedures other than \fBTcl_FreeParse\fR, \fBTcl_EvalTokens\fR and \fBTcl_EvalTokensStandard\fR, used only for error reporting; if NULL, then no error messages are left after errors. For \fBTcl_EvalTokens\fR and \fBTcl_EvalTokensStandard\fR, determines the context for evaluating the script and also is used for error reporting; must not be NULL. .AP "const char" *start in Pointer to first character in string to parse. .AP int numBytes in Number of bytes in string to parse, not including any terminating null character. If less than 0 then the script consists of all characters following \fIstart\fR up to the first null character. .AP int nested in |
| ︙ | ︙ | |||
183 184 185 186 187 188 189 190 191 192 193 194 195 196 | resulting values. The return value from \fBTcl_EvalTokensStandard\fR is a Tcl completion code with one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR, or possibly some other integer value originating in an extension. In addition, a result value or error message is left in \fIinterp\fR's result; it can be retrieved using \fBTcl_GetObjResult\fR. .SH "TCL_PARSE STRUCTURE" .PP \fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR, \fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR return parse information in two data structures, Tcl_Parse and Tcl_Token: .PP .CS | > > > > > > > > > > | 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 | resulting values. The return value from \fBTcl_EvalTokensStandard\fR is a Tcl completion code with one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR, or possibly some other integer value originating in an extension. In addition, a result value or error message is left in \fIinterp\fR's result; it can be retrieved using \fBTcl_GetObjResult\fR. .PP \fBTcl_EvalTokens\fR differs from \fBTcl_EvalTokensStandard\fR only in the return convention used: it returns the result in a new Tcl_Obj. The reference count of the value returned as result has been incremented, so the caller must invoke \fBTcl_DecrRefCount\fR when it is finished with the value. If an error or other exception occurs while evaluating the tokens (such as a reference to a non-existent variable) then the return value is NULL and an error message is left in \fIinterp\fR's result. The use of \fBTcl_EvalTokens\fR is deprecated. .SH "TCL_PARSE STRUCTURE" .PP \fBTcl_ParseCommand\fR, \fBTcl_ParseExpr\fR, \fBTcl_ParseBraces\fR, \fBTcl_ParseQuotedString\fR, and \fBTcl_ParseVarName\fR return parse information in two data structures, Tcl_Parse and Tcl_Token: .PP .CS |
| ︙ | ︙ | |||
204 205 206 207 208 209 210 |
int \fInumTokens\fR;
...
} \fBTcl_Parse\fR;
typedef struct Tcl_Token {
int \fItype\fR;
const char *\fIstart\fR;
| | | | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 |
int \fInumTokens\fR;
...
} \fBTcl_Parse\fR;
typedef struct Tcl_Token {
int \fItype\fR;
const char *\fIstart\fR;
int \fIsize\fR;
int \fInumComponents\fR;
} \fBTcl_Token\fR;
.CE
.PP
The first five fields of a Tcl_Parse structure
are filled in only by \fBTcl_ParseCommand\fR.
These fields are not used by the other parsing procedures.
.PP
|
| ︙ | ︙ | |||
284 285 286 287 288 289 290 | \fBTCL_TOKEN_TEXT\fR . The token describes a range of literal text that is part of a word. The \fInumComponents\fR field is always 0. .TP \fBTCL_TOKEN_BS\fR . | | | 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 | \fBTCL_TOKEN_TEXT\fR . The token describes a range of literal text that is part of a word. The \fInumComponents\fR field is always 0. .TP \fBTCL_TOKEN_BS\fR . The token describes a backslash sequence such as \fB\en\fR or \fB\e0xA3\fR. The \fInumComponents\fR field is always 0. .TP \fBTCL_TOKEN_COMMAND\fR . The token describes a command whose result must be substituted into the word. The token includes the square brackets that surround the command. The \fInumComponents\fR field is always 0 (the nested command |
| ︙ | ︙ |
Changes to doc/Preserve.3.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 | \fBTcl_Preserve\fR(\fIclientData\fR) .sp \fBTcl_Release\fR(\fIclientData\fR) .sp \fBTcl_EventuallyFree\fR(\fIclientData, freeProc\fR) .SH ARGUMENTS .AS Tcl_FreeProc clientData | | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | \fBTcl_Preserve\fR(\fIclientData\fR) .sp \fBTcl_Release\fR(\fIclientData\fR) .sp \fBTcl_EventuallyFree\fR(\fIclientData, freeProc\fR) .SH ARGUMENTS .AS Tcl_FreeProc clientData .AP ClientData clientData in Token describing structure to be freed or reallocated. Usually a pointer to memory for structure. .AP Tcl_FreeProc *freeProc in Procedure to invoke to free \fIclientData\fR. .BE .SH DESCRIPTION .PP |
| ︙ | ︙ | |||
87 88 89 90 91 92 93 | same as the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR. The type of \fIblockPtr\fR (\fBchar *\fR) is different than the type of the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR for historical reasons, but the value is the same. .PP When the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR refers to storage allocated and returned by a prior call to | | | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 | same as the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR. The type of \fIblockPtr\fR (\fBchar *\fR) is different than the type of the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR for historical reasons, but the value is the same. .PP When the \fIclientData\fR argument to \fBTcl_EventuallyFree\fR refers to storage allocated and returned by a prior call to \fBTcl_Alloc\fR, \fBckalloc\fR, or another function of the Tcl library, then the \fIfreeProc\fR argument should be given the special value of \fBTCL_DYNAMIC\fR. .PP This mechanism can be used to solve the problem described above by placing \fBTcl_Preserve\fR and \fBTcl_Release\fR calls around actions that may cause undesired storage re-allocation. The mechanism is intended only for short-term use (i.e. while procedures |
| ︙ | ︙ |
Changes to doc/PrintDbl.3.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 | .nf \fB#include <tcl.h>\fR .sp \fBTcl_PrintDouble\fR(\fIinterp, value, dst\fR) .SH ARGUMENTS .AS Tcl_Interp *interp out .AP Tcl_Interp *interp in | > | > > > > | | 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 | .nf \fB#include <tcl.h>\fR .sp \fBTcl_PrintDouble\fR(\fIinterp, value, dst\fR) .SH ARGUMENTS .AS Tcl_Interp *interp out .AP Tcl_Interp *interp in Before Tcl 8.0, the \fBtcl_precision\fR variable in this interpreter controlled the conversion. As of Tcl 8.0, this argument is ignored and the conversion is controlled by the \fBtcl_precision\fR variable that is now shared by all interpreters. .AP double value in Floating-point value to be converted. .AP char *dst out Where to store the string representing \fIvalue\fR. Must have at least \fBTCL_DOUBLE_SPACE\fR characters of storage. .BE .SH DESCRIPTION .PP \fBTcl_PrintDouble\fR generates a string that represents the value of \fIvalue\fR and stores it in memory at the location given by \fIdst\fR. It uses \fB%g\fR format to generate the string, with one special twist: the string is guaranteed to contain either a .QW . or an .QW e so that it does not look like an integer. Where \fB%g\fR would generate an integer with no decimal point, \fBTcl_PrintDouble\fR adds .QW .0 . .PP If the \fBtcl_precision\fR value is non-zero, the result will have precisely that many digits of significance. If the value is zero (the default), the result will have the fewest digits needed to represent the number in such a way that \fBTcl_NewDoubleObj\fR will generate the same number when presented with the given string. IEEE semantics of rounding to even apply to the conversion. .SH KEYWORDS conversion, double-precision, floating-point, string |
Changes to doc/RecEvalObj.3.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 | command but do not evaluate it. \fBTCL_EVAL_GLOBAL\fR means evaluate the command at global level instead of the current stack level. .BE .SH DESCRIPTION .PP \fBTcl_RecordAndEvalObj\fR is invoked to record a command as an event | | | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | command but do not evaluate it. \fBTCL_EVAL_GLOBAL\fR means evaluate the command at global level instead of the current stack level. .BE .SH DESCRIPTION .PP \fBTcl_RecordAndEvalObj\fR is invoked to record a command as an event on the history list and then execute it using \fBTcl_EvalObjEx\fR It returns a completion code such as \fBTCL_OK\fR just like \fBTcl_EvalObjEx\fR, as well as a result value containing additional information (a result value or error message) that can be retrieved using \fBTcl_GetObjResult\fR. If you do not want the command recorded on the history list then you should invoke \fBTcl_EvalObjEx\fR instead of \fBTcl_RecordAndEvalObj\fR. Normally \fBTcl_RecordAndEvalObj\fR is only called with top-level |
| ︙ | ︙ |
Changes to doc/RegExp.3.
| ︙ | ︙ | |||
60 61 62 63 64 65 66 | by \fBTcl_GetRegExpFromObj\fR or \fBTcl_RegExpCompile\fR. .AP char *start in If \fItext\fR is just a portion of some other string, this argument identifies the beginning of the larger string. If it is not the same as \fItext\fR, then no .QW \fB^\fR matches will be allowed. | | | | | | 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 | by \fBTcl_GetRegExpFromObj\fR or \fBTcl_RegExpCompile\fR. .AP char *start in If \fItext\fR is just a portion of some other string, this argument identifies the beginning of the larger string. If it is not the same as \fItext\fR, then no .QW \fB^\fR matches will be allowed. .AP int index in Specifies which range is desired: 0 means the range of the entire match, 1 or greater means the range that matched a parenthesized sub-expression. .AP "const char" **startPtr out The address of the first character in the range is stored here, or NULL if there is no such range. .AP "const char" **endPtr out The address of the character just after the last one in the range is stored here, or NULL if there is no such range. .AP int cflags in OR-ed combination of the compilation flags \fBTCL_REG_ADVANCED\fR, \fBTCL_REG_EXTENDED\fR, \fBTCL_REG_BASIC\fR, \fBTCL_REG_EXPANDED\fR, \fBTCL_REG_QUOTE\fR, \fBTCL_REG_NOCASE\fR, \fBTCL_REG_NEWLINE\fR, \fBTCL_REG_NLSTOP\fR, \fBTCL_REG_NLANCH\fR, \fBTCL_REG_NOSUB\fR, and \fBTCL_REG_CANMATCH\fR. See below for more information. .AP int offset in The character offset into the text where matching should begin. The value of the offset has no impact on \fB^\fR matches. This behavior is controlled by \fIeflags\fR. .AP int nmatches in The number of matching subexpressions that should be remembered for later use. If this value is 0, then no subexpression match information will be computed. If the value is \-1, then all of the matching subexpressions will be remembered. Any other value will be taken as the maximum number of subexpressions to remember. .AP int eflags in OR-ed combination of the execution flags \fBTCL_REG_NOTBOL\fR and \fBTCL_REG_NOTEOL\fR. See below for more information. .AP Tcl_RegExpInfo *infoPtr out |
| ︙ | ︙ | |||
333 334 335 336 337 338 339 |
\fBTcl_RegExpGetInfo\fR retrieves information about the last match
performed with a given regular expression \fIregexp\fR. The
\fIinfoPtr\fR argument contains a pointer to a structure that is
defined as follows:
.PP
.CS
typedef struct Tcl_RegExpInfo {
| | | | | | 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 |
\fBTcl_RegExpGetInfo\fR retrieves information about the last match
performed with a given regular expression \fIregexp\fR. The
\fIinfoPtr\fR argument contains a pointer to a structure that is
defined as follows:
.PP
.CS
typedef struct Tcl_RegExpInfo {
int \fInsubs\fR;
Tcl_RegExpIndices *\fImatches\fR;
long \fIextendStart\fR;
} \fBTcl_RegExpInfo\fR;
.CE
.PP
The \fInsubs\fR field contains a count of the number of parenthesized
subexpressions within the regular expression. If the \fBTCL_REG_NOSUB\fR
was used, then this value will be zero. The \fImatches\fR field
points to an array of \fInsubs\fR+1 values that indicate the bounds of each
subexpression matched. The first element in the array refers to the
range matched by the entire regular expression, and subsequent elements
refer to the parenthesized subexpressions in the order that they
appear in the pattern. Each element is a structure that is defined as
follows:
.PP
.CS
typedef struct Tcl_RegExpIndices {
long \fIstart\fR;
long \fIend\fR;
} \fBTcl_RegExpIndices\fR;
.CE
.PP
The \fIstart\fR and \fIend\fR values are Unicode character indices
relative to the offset location within \fIobjPtr\fR where matching began.
The \fIstart\fR index identifies the first character of the matched
subexpression. The \fIend\fR index identifies the first character
|
| ︙ | ︙ |
Changes to doc/SetRecLmt.3.
| ︙ | ︙ | |||
25 26 27 28 29 30 31 | New limit for nested calls to \fBTcl_Eval\fR for \fIinterp\fR. .BE .SH DESCRIPTION .PP At any given time Tcl enforces a limit on the number of recursive calls that may be active for \fBTcl_Eval\fR and related procedures | | | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | New limit for nested calls to \fBTcl_Eval\fR for \fIinterp\fR. .BE .SH DESCRIPTION .PP At any given time Tcl enforces a limit on the number of recursive calls that may be active for \fBTcl_Eval\fR and related procedures such as \fBTcl_GlobalEval\fR. Any call to \fBTcl_Eval\fR that exceeds this depth is aborted with an error. By default the recursion limit is 1000. .PP \fBTcl_SetRecursionLimit\fR may be used to change the maximum allowable nesting depth for an interpreter. The \fIdepth\fR argument specifies a new limit for \fIinterp\fR, |
| ︙ | ︙ |
Changes to doc/SetResult.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | > > < | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_SetResult 3 8.7 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendResultVA, Tcl_AppendElement, Tcl_ResetResult, Tcl_TransferResult, Tcl_FreeResult \- manipulate Tcl result .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp \fBTcl_SetObjResult\fR(\fIinterp, objPtr\fR) .sp Tcl_Obj * \fBTcl_GetObjResult\fR(\fIinterp\fR) .sp \fBTcl_SetResult\fR(\fIinterp, result, freeProc\fR) .sp const char * \fBTcl_GetStringResult\fR(\fIinterp\fR) .sp \fBTcl_AppendResult\fR(\fIinterp, result, result, ... , \fB(char *) NULL\fR) .sp \fBTcl_AppendResultVA\fR(\fIinterp, argList\fR) .sp \fBTcl_ResetResult\fR(\fIinterp\fR) .sp \fBTcl_TransferResult\fR(\fIsourceInterp, code, targetInterp\fR) .sp \fBTcl_AppendElement\fR(\fIinterp, element\fR) .sp \fBTcl_FreeResult\fR(\fIinterp\fR) .SH ARGUMENTS .AS Tcl_FreeProc sourceInterp out .AP Tcl_Interp *interp out |
| ︙ | ︙ | |||
51 52 53 54 55 56 57 | Address of procedure to call to release storage at \fIresult\fR, or \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, or \fBTCL_VOLATILE\fR. .AP va_list argList in An argument list which must have been initialized using \fBva_start\fR, and cleared using \fBva_end\fR. .AP Tcl_Interp *sourceInterp in | < | < < | < | < < < < > | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | Address of procedure to call to release storage at \fIresult\fR, or \fBTCL_STATIC\fR, \fBTCL_DYNAMIC\fR, or \fBTCL_VOLATILE\fR. .AP va_list argList in An argument list which must have been initialized using \fBva_start\fR, and cleared using \fBva_end\fR. .AP Tcl_Interp *sourceInterp in Interpreter that the result and return options should be transferred from. .AP Tcl_Interp *targetInterp in Interpreter that the result and return options should be transferred to. .AP int code in Return code value that controls transfer of return options. .BE .SH DESCRIPTION .PP The procedures described here are utilities for manipulating the result value in a Tcl interpreter. The interpreter result may be either a Tcl value or a string. For example, \fBTcl_SetObjResult\fR and \fBTcl_SetResult\fR |
| ︙ | ︙ | |||
146 147 148 149 150 151 152 | result, such as allocating a larger result area if necessary. It also manages conversion to and from the \fIresult\fR field of the \fIinterp\fR so as to handle backward-compatibility with old-style extensions. Any number of \fIresult\fR arguments may be passed in a single call; the last argument in the list must be a NULL pointer. .PP | > > > > | > > > | < > | < < > > | 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 | result, such as allocating a larger result area if necessary. It also manages conversion to and from the \fIresult\fR field of the \fIinterp\fR so as to handle backward-compatibility with old-style extensions. Any number of \fIresult\fR arguments may be passed in a single call; the last argument in the list must be a NULL pointer. .PP \fBTcl_AppendResultVA\fR is the same as \fBTcl_AppendResult\fR except that instead of taking a variable number of arguments it takes an argument list. Interfaces using argument lists have been found to be nonportable in practice. This function is deprecated and will be removed in Tcl 9.0. .PP \fBTcl_TransferResult\fR transfers interpreter state from \fIsourceInterp\fR to \fItargetInterp\fR. The two interpreters must have been created in the same thread. If \fIsourceInterp\fR and \fItargetInterp\fR are the same, nothing is done. Otherwise, \fBTcl_TransferResult\fR moves the result from \fIsourceInterp\fR to \fItargetInterp\fR, and resets the result in \fIsourceInterp\fR. It also moves the return options dictionary as controlled by the return code value \fIcode\fR in the same manner as \fBTcl_GetReturnOptions\fR. .SH "DEPRECATED INTERFACES" .SS "OLD STRING PROCEDURES" .PP Use of the following procedures is deprecated since they manipulate the Tcl result as a string. Procedures such as \fBTcl_SetObjResult\fR that manipulate the result as a value |
| ︙ | ︙ | |||
188 189 190 191 192 193 194 195 196 197 198 199 200 201 | \fBTcl_FreeResult\fR performs part of the work of \fBTcl_ResetResult\fR. It frees up the memory associated with \fIinterp\fR's result. It also sets \fIinterp->freeProc\fR to zero, but does not change \fIinterp->result\fR or clear error state. \fBTcl_FreeResult\fR is most commonly used when a procedure is about to replace one result value with another. .SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT" .PP \fBTcl_SetResult\fR's \fIfreeProc\fR argument specifies how the Tcl system is to manage the storage for the \fIresult\fR argument. If \fBTcl_SetResult\fR or \fBTcl_SetObjResult\fR are called at a time when \fIinterp\fR holds a string result, they do whatever is necessary to dispose of the old string result | > > > > > > > > | 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 | \fBTcl_FreeResult\fR performs part of the work of \fBTcl_ResetResult\fR. It frees up the memory associated with \fIinterp\fR's result. It also sets \fIinterp->freeProc\fR to zero, but does not change \fIinterp->result\fR or clear error state. \fBTcl_FreeResult\fR is most commonly used when a procedure is about to replace one result value with another. .SS "DIRECT ACCESS TO INTERP->RESULT" .PP It used to be legal for programs to directly read and write \fIinterp->result\fR to manipulate the interpreter result. The Tcl headers no longer permit this access. C code still doing this must be updated to use supported routines \fBTcl_GetObjResult\fR, \fBTcl_GetStringResult\fR, \fBTcl_SetObjResult\fR, and \fBTcl_SetResult\fR. .SH "THE TCL_FREEPROC ARGUMENT TO TCL_SETRESULT" .PP \fBTcl_SetResult\fR's \fIfreeProc\fR argument specifies how the Tcl system is to manage the storage for the \fIresult\fR argument. If \fBTcl_SetResult\fR or \fBTcl_SetObjResult\fR are called at a time when \fIinterp\fR holds a string result, they do whatever is necessary to dispose of the old string result |
| ︙ | ︙ | |||
228 229 230 231 232 233 234 |
typedef void \fBTcl_FreeProc\fR(
char *\fIblockPtr\fR);
.CE
.PP
When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to
the value of \fIresult\fR passed to \fBTcl_SetResult\fR.
.SH "SEE ALSO"
| | > | 236 237 238 239 240 241 242 243 244 245 246 |
typedef void \fBTcl_FreeProc\fR(
char *\fIblockPtr\fR);
.CE
.PP
When \fIfreeProc\fR is called, its \fIblockPtr\fR will be set to
the value of \fIresult\fR passed to \fBTcl_SetResult\fR.
.SH "SEE ALSO"
Tcl_AddErrorInfo, Tcl_CreateObjCommand, Tcl_SetErrorCode, Tcl_Interp,
Tcl_GetReturnOptions
.SH KEYWORDS
append, command, element, list, value, result, return value, interpreter
|
Changes to doc/SplitList.3.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 | .sp int \fBTcl_SplitList\fR(\fIinterp, list, argcPtr, argvPtr\fR) .sp char * \fBTcl_Merge\fR(\fIargc, argv\fR) .sp | | | | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | .sp int \fBTcl_SplitList\fR(\fIinterp, list, argcPtr, argvPtr\fR) .sp char * \fBTcl_Merge\fR(\fIargc, argv\fR) .sp int \fBTcl_ScanElement\fR(\fIsrc, flagsPtr\fR) .sp int \fBTcl_ScanCountedElement\fR(\fIsrc, length, flagsPtr\fR) .sp int \fBTcl_ConvertElement\fR(\fIsrc, dst, flags\fR) .sp int \fBTcl_ConvertCountedElement\fR(\fIsrc, length, dst, flags\fR) .SH ARGUMENTS .AS "const char *const" ***argvPtr out .AP Tcl_Interp *interp out Interpreter to use for error reporting. If NULL, then no error message is left. .AP char *list in |
| ︙ | ︙ | |||
51 52 53 54 55 56 57 | Array of strings to merge together into a single list. Each string will become a separate element of the list. .AP "const char" *src in String that is to become an element of a list. .AP int *flagsPtr in Pointer to word to fill in with information about \fIsrc\fR. The value of *\fIflagsPtr\fR must be passed to \fBTcl_ConvertElement\fR. | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | Array of strings to merge together into a single list. Each string will become a separate element of the list. .AP "const char" *src in String that is to become an element of a list. .AP int *flagsPtr in Pointer to word to fill in with information about \fIsrc\fR. The value of *\fIflagsPtr\fR must be passed to \fBTcl_ConvertElement\fR. .AP int length in Number of bytes in string \fIsrc\fR. .AP char *dst in Place to copy converted list element. Must contain enough characters to hold converted string. .AP int flags in Information about \fIsrc\fR. Must be value returned by previous call to \fBTcl_ScanElement\fR, possibly OR-ed |
| ︙ | ︙ |
Changes to doc/StaticPkg.3.
| ︙ | ︙ | |||
61 62 63 64 65 66 67 | is to be loaded. The initialization procedure must return \fBTCL_OK\fR or \fBTCL_ERROR\fR to indicate whether or not it completed successfully; in the event of an error it should set the interpreter's result to point to an error message. The result or error from the initialization procedure will be returned as the result of the \fBload\fR command that caused the initialization procedure to be invoked. .PP | | > | 61 62 63 64 65 66 67 68 69 70 71 72 73 | is to be loaded. The initialization procedure must return \fBTCL_OK\fR or \fBTCL_ERROR\fR to indicate whether or not it completed successfully; in the event of an error it should set the interpreter's result to point to an error message. The result or error from the initialization procedure will be returned as the result of the \fBload\fR command that caused the initialization procedure to be invoked. .PP \fBTcl_StaticPackage\fR can not be used in stub-enabled extensions. Its symbol entry in the stub table is deprecated and it will be removed in Tcl 9.0. .SH KEYWORDS initialization procedure, package, static linking .SH "SEE ALSO" load(n), package(n), Tcl_PkgRequire(3) |
Changes to doc/StringObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendObjToObj, Tcl_AppendStringsToObj, Tcl_AppendStringsToObjVA, Tcl_AppendLimitedToObj, Tcl_Format, Tcl_AppendFormatToObj, Tcl_ObjPrintf, Tcl_AppendPrintfToObj, Tcl_SetObjLength, Tcl_AttemptSetObjLength, Tcl_ConcatObj \- manipulate Tcl values as strings .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewStringObj\fR(\fIbytes, length\fR) .sp |
| ︙ | ︙ | |||
54 55 56 57 58 59 60 61 62 63 64 65 66 67 | .sp void \fBTcl_AppendObjToObj\fR(\fIobjPtr, appendObjPtr\fR) .sp void \fBTcl_AppendStringsToObj\fR(\fIobjPtr, string, string, ... \fB(char *) NULL\fR) .sp void \fBTcl_AppendLimitedToObj\fR(\fIobjPtr, bytes, length, limit, ellipsis\fR) .sp Tcl_Obj * \fBTcl_Format\fR(\fIinterp, format, objc, objv\fR) .sp int | > > > | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 | .sp void \fBTcl_AppendObjToObj\fR(\fIobjPtr, appendObjPtr\fR) .sp void \fBTcl_AppendStringsToObj\fR(\fIobjPtr, string, string, ... \fB(char *) NULL\fR) .sp void \fBTcl_AppendStringsToObjVA\fR(\fIobjPtr, argList\fR) .sp void \fBTcl_AppendLimitedToObj\fR(\fIobjPtr, bytes, length, limit, ellipsis\fR) .sp Tcl_Obj * \fBTcl_Format\fR(\fIinterp, format, objc, objv\fR) .sp int |
| ︙ | ︙ | |||
83 84 85 86 87 88 89 | \fBTcl_ConcatObj\fR(\fIobjc, objv\fR) .SH ARGUMENTS .AS "const Tcl_UniChar" *appendObjPtr in/out .AP "const char" *bytes in Points to the first byte of an array of UTF-8-encoded bytes used to set or append to a string value. This byte array may contain embedded null characters | | | | | | | | | | | | | 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 | \fBTcl_ConcatObj\fR(\fIobjc, objv\fR) .SH ARGUMENTS .AS "const Tcl_UniChar" *appendObjPtr in/out .AP "const char" *bytes in Points to the first byte of an array of UTF-8-encoded bytes used to set or append to a string value. This byte array may contain embedded null characters unless \fInumChars\fR is negative. (Applications needing null bytes should represent them as the two-byte sequence \fI\e300\e200\fR, use \fBTcl_ExternalToUtf\fR to convert, or \fBTcl_NewByteArrayObj\fR if the string is a collection of uninterpreted bytes.) .AP int length in The number of bytes to copy from \fIbytes\fR when initializing, setting, or appending to a string value. If negative, all bytes up to the first null are used. .AP "const Tcl_UniChar" *unicode in Points to the first byte of an array of Unicode characters used to set or append to a string value. This byte array may contain embedded null characters unless \fInumChars\fR is negative. .AP int numChars in The number of Unicode characters to copy from \fIunicode\fR when initializing, setting, or appending to a string value. If negative, all characters up to the first null character are used. .AP int index in The index of the Unicode character to return. .AP int first in The index of the first Unicode character in the Unicode range to be returned as a new value. .AP int last in The index of the last Unicode character in the Unicode range to be returned as a new value. .AP Tcl_Obj *objPtr in/out Points to a value to manipulate. .AP Tcl_Obj *appendObjPtr in The value to append to \fIobjPtr\fR in \fBTcl_AppendObjToObj\fR. .AP int *lengthPtr out If non-NULL, the location where \fBTcl_GetStringFromObj\fR will store the length of a value's string representation. .AP "const char" *string in Null-terminated string value to append to \fIobjPtr\fR. .AP va_list argList in An argument list which must have been initialized using \fBva_start\fR, and cleared using \fBva_end\fR. .AP int limit in Maximum number of bytes to be appended. .AP "const char" *ellipsis in Suffix to append when the limit leads to string truncation. If NULL is passed then the suffix .QW "..." is used. .AP "const char" *format in Format control string including % conversion specifiers. .AP int objc in The number of elements to format or concatenate. .AP Tcl_Obj *objv[] in The array of values to format or concatenate. .AP int newLength in New length for the string value of \fIobjPtr\fR, not including the final null character. .BE .SH DESCRIPTION .PP The procedures described in this manual entry allow Tcl values to be manipulated as string values. They use the internal representation |
| ︙ | ︙ | |||
239 240 241 242 243 244 245 246 247 248 249 250 251 252 | .PP \fBTcl_AppendStringsToObj\fR is similar to \fBTcl_AppendToObj\fR except that it can be passed more than one value to append and each value must be a null-terminated string (i.e. none of the values may contain internal null characters). Any number of \fIstring\fR arguments may be provided, but the last argument must be a NULL pointer to indicate the end of the list. .PP \fBTcl_AppendLimitedToObj\fR is similar to \fBTcl_AppendToObj\fR except that it imposes a limit on how many bytes are appended. This can be handy when the string to be appended might be very large, but the value being constructed should not be allowed to grow without bound. A common usage is when constructing an error message, where the end result should be kept short enough to be read. | > > > > > > | 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 | .PP \fBTcl_AppendStringsToObj\fR is similar to \fBTcl_AppendToObj\fR except that it can be passed more than one value to append and each value must be a null-terminated string (i.e. none of the values may contain internal null characters). Any number of \fIstring\fR arguments may be provided, but the last argument must be a NULL pointer to indicate the end of the list. .PP \fBTcl_AppendStringsToObjVA\fR is the same as \fBTcl_AppendStringsToObj\fR except that instead of taking a variable number of arguments it takes an argument list. Interfaces using argument lists have been found to be nonportable in practice. This function is deprecated and will be removed in Tcl 9.0. .PP \fBTcl_AppendLimitedToObj\fR is similar to \fBTcl_AppendToObj\fR except that it imposes a limit on how many bytes are appended. This can be handy when the string to be appended might be very large, but the value being constructed should not be allowed to grow without bound. A common usage is when constructing an error message, where the end result should be kept short enough to be read. |
| ︙ | ︙ |
Changes to doc/TCL_MEM_DEBUG.3.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 | .PP Once memory debugging support has been compiled into Tcl, the C functions \fBTcl_ValidateAllMemory\fR, and \fBTcl_DumpActiveMemory\fR, and the Tcl \fBmemory\fR command can be used to validate and examine memory usage. .SH "GUARD ZONES" .PP | | | | | | | | 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 | .PP Once memory debugging support has been compiled into Tcl, the C functions \fBTcl_ValidateAllMemory\fR, and \fBTcl_DumpActiveMemory\fR, and the Tcl \fBmemory\fR command can be used to validate and examine memory usage. .SH "GUARD ZONES" .PP When memory debugging is enabled, whenever a call to \fBckalloc\fR is made, slightly more memory than requested is allocated so the memory debugging code can keep track of the allocated memory, and eight-byte .QW "guard zones" are placed in front of and behind the space that will be returned to the caller. (The sizes of the guard zones are defined by the C #define \fBLOW_GUARD_SIZE\fR and #define \fBHIGH_GUARD_SIZE\fR in the file \fIgeneric/tclCkalloc.c\fR \(em it can be extended if you suspect large overwrite problems, at some cost in performance.) A known pattern is written into the guard zones and, on a call to \fBckfree\fR, the guard zones of the space being freed are checked to see if either zone has been modified in any way. If one has been, the guard bytes and their new contents are identified, and a .QW "low guard failed" or .QW "high guard failed" message is issued. The .QW "guard failed" message includes the address of the memory packet and the file name and line number of the code that called \fBckfree\fR. This allows you to detect the common sorts of one-off problems, where not enough space was allocated to contain the data written, for example. .SH "DEBUGGING DIFFICULT MEMORY CORRUPTION PROBLEMS" .PP Normally, Tcl compiled with memory debugging enabled will make it easy to isolate a corruption problem. Turning on memory validation with the memory command can help isolate difficult problems. If you suspect (or know) that corruption is occurring before the Tcl interpreter comes up far enough for you to issue commands, you can set \fBMEM_VALIDATE\fR define, recompile tclCkalloc.c and rebuild Tcl. This will enable memory validation from the first call to \fBckalloc\fR, again, at a large performance impact. .PP If you are desperate and validating memory on every call to \fBckalloc\fR and \fBckfree\fR is not enough, you can explicitly call \fBTcl_ValidateAllMemory\fR directly at any point. It takes a \fIchar *\fR and an \fIint\fR which are normally the filename and line number of the caller, but they can actually be anything you want. Remember to remove the calls after you find the problem. .SH "SEE ALSO" ckalloc, memory, Tcl_ValidateAllMemory, Tcl_DumpActiveMemory .SH KEYWORDS memory, debug |
Changes to doc/TclZlib.3.
| ︙ | ︙ | |||
84 85 86 87 88 89 90 | section \fBGZIP OPTIONS DICTIONARY\fR for details about the contents of this dictionary. .AP "unsigned int" initValue in The initial value for the checksum algorithm. .AP "unsigned char" *bytes in An array of bytes to run the checksum algorithm over, or NULL to get the recommended initial value for the checksum algorithm. | | | | | | 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 | section \fBGZIP OPTIONS DICTIONARY\fR for details about the contents of this dictionary. .AP "unsigned int" initValue in The initial value for the checksum algorithm. .AP "unsigned char" *bytes in An array of bytes to run the checksum algorithm over, or NULL to get the recommended initial value for the checksum algorithm. .AP int length in The number of bytes in the array. .AP int mode in What mode to operate the stream in. Should be either \fBTCL_ZLIB_STREAM_DEFLATE\fR for a compressing stream or \fBTCL_ZLIB_STREAM_INFLATE\fR for a decompressing stream. .AP Tcl_ZlibStream *zshandlePtr out A pointer to a variable in which to write the abstract token for the stream upon successful creation. .AP Tcl_ZlibStream zshandle in The abstract token for the stream to operate on. .AP int flush in Whether and how to flush the stream after writing the data to it. Must be one of: \fBTCL_ZLIB_NO_FLUSH\fR if no flushing is to be done, \fBTCL_ZLIB_FLUSH\fR if the currently compressed data must be made available for access using \fBTcl_ZlibStreamGet\fR, \fBTCL_ZLIB_FULLFLUSH\fR if the stream must be put into a state where the decompressor can recover from on corruption, or \fBTCL_ZLIB_FINALIZE\fR to ensure that the stream is finished and that any trailer demanded by the format is written. .AP int count in The maximum number of bytes to get from the stream, or -1 to get all remaining bytes from the stream's buffers. .AP Tcl_Obj *compDict in A byte array value that is the compression dictionary to use with the stream. Note that this is \fInot a Tcl dictionary\fR, and it is recommended that this only ever be used with streams that were created with their \fIformat\fR set to \fBTCL_ZLIB_FORMAT_ZLIB\fR because the other formats have no mechanism to indicate whether a compression dictionary was present other than to fail on decompression. |
| ︙ | ︙ |
Changes to doc/Tcl_Main.3.
| ︙ | ︙ | |||
186 187 188 189 190 191 192 | is encountered on the standard input channel, then \fBTcl_Main\fR itself will evaluate the \fBexit\fR command after the main loop procedure (if any) returns. In non-interactive mode, after \fBTcl_Main\fR evaluates the startup script, and the main loop procedure (if any) returns, \fBTcl_Main\fR will also evaluate the \fBexit\fR command. .PP | | | 186 187 188 189 190 191 192 193 194 195 196 197 198 | is encountered on the standard input channel, then \fBTcl_Main\fR itself will evaluate the \fBexit\fR command after the main loop procedure (if any) returns. In non-interactive mode, after \fBTcl_Main\fR evaluates the startup script, and the main loop procedure (if any) returns, \fBTcl_Main\fR will also evaluate the \fBexit\fR command. .PP \fBTcl_Main\fR can not be used in stub-enabled extensions. .SH "SEE ALSO" tclsh(1), Tcl_GetStdChannel(3), Tcl_StandardChannels(3), Tcl_AppInit(3), exit(n), encoding(n) .SH KEYWORDS application-specific initialization, command-line arguments, main program |
Changes to doc/Thread.3.
| ︙ | ︙ | |||
63 64 65 66 67 68 69 | The referred storage will contain the id of the newly created thread as returned by the operating system. .AP Tcl_ThreadId id in Id of the thread waited upon. .AP Tcl_ThreadCreateProc *proc in This procedure will act as the \fBmain()\fR of the newly created thread. The specified \fIclientData\fR will be its sole argument. | | | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | The referred storage will contain the id of the newly created thread as returned by the operating system. .AP Tcl_ThreadId id in Id of the thread waited upon. .AP Tcl_ThreadCreateProc *proc in This procedure will act as the \fBmain()\fR of the newly created thread. The specified \fIclientData\fR will be its sole argument. .AP ClientData clientData in Arbitrary information. Passed as sole argument to the \fIproc\fR. .AP int stackSize in The size of the stack given to the new thread. .AP int flags in Bitmask containing flags allowing the caller to modify behavior of the new thread. .AP int *result out |
| ︙ | ︙ | |||
204 205 206 207 208 209 210 | .PP It should then be defined like this example, which just counts up to a given value and then finishes. .PP .CS static \fBTcl_ThreadCreateType\fR MyThreadImplFunc( | | | | 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 |
.PP
It should then be defined like this example, which just counts up to a given
value and then finishes.
.PP
.CS
static \fBTcl_ThreadCreateType\fR
MyThreadImplFunc(
ClientData clientData)
{
int i, limit = (int) clientData;
for (i=0 ; i<limit ; i++) {
/* doing nothing at all here */
}
\fBTCL_THREAD_CREATE_RETURN\fR;
}
.CE
.PP
To create the above thread, make it execute, and wait for it to finish, we
would do this:
.PP
.CS
int limit = 1000000000;
ClientData limitData = (void*)((intptr_t) limit);
Tcl_ThreadId id; \fI/* holds identity of thread created */\fR
int result;
if (\fBTcl_CreateThread\fR(&id, MyThreadImplFunc, limitData,
\fBTCL_THREAD_STACK_DEFAULT\fR,
\fBTCL_THREAD_JOINABLE\fR) != TCL_OK) {
\fI/* Thread did not create correctly */\fR
|
| ︙ | ︙ |
Changes to doc/TraceCmd.3.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | .BS .SH NAME Tcl_CommandTraceInfo, Tcl_TraceCommand, Tcl_UntraceCommand \- monitor renames and deletes of a command .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp | | | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | .BS .SH NAME Tcl_CommandTraceInfo, Tcl_TraceCommand, Tcl_UntraceCommand \- monitor renames and deletes of a command .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp ClientData \fBTcl_CommandTraceInfo(\fIinterp, cmdName, flags, proc, prevClientData\fB)\fR .sp int \fBTcl_TraceCommand(\fIinterp, cmdName, flags, proc, clientData\fB)\fR .sp void \fBTcl_UntraceCommand(\fIinterp, cmdName, flags, proc, clientData\fB)\fR .SH ARGUMENTS .AS Tcl_CommandTraceProc prevClientData .AP Tcl_Interp *interp in Interpreter containing the command. .AP "const char" *cmdName in Name of command. .AP int flags in OR'ed collection of the values \fBTCL_TRACE_RENAME\fR and \fBTCL_TRACE_DELETE\fR. .AP Tcl_CommandTraceProc *proc in Procedure to call when specified operations occur to \fIcmdName\fR. .AP ClientData clientData in Arbitrary argument to pass to \fIproc\fR. .AP ClientData prevClientData in If non-NULL, gives last value returned by \fBTcl_CommandTraceInfo\fR, so this call will return information about next trace. If NULL, this call will return information about first trace. .BE .SH DESCRIPTION .PP \fBTcl_TraceCommand\fR allows a C procedure to monitor operations |
| ︙ | ︙ | |||
61 62 63 64 65 66 67 | .PP Whenever one of the specified operations occurs to the command, \fIproc\fR will be invoked. It should have arguments and result that match the type \fBTcl_CommandTraceProc\fR: .PP .CS typedef void \fBTcl_CommandTraceProc\fR( | | | | 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 |
.PP
Whenever one of the specified operations occurs to the command,
\fIproc\fR will be invoked. It should have arguments and result that
match the type \fBTcl_CommandTraceProc\fR:
.PP
.CS
typedef void \fBTcl_CommandTraceProc\fR(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
const char *\fIoldName\fR,
const char *\fInewName\fR,
int \fIflags\fR);
.CE
.PP
The \fIclientData\fR and \fIinterp\fR parameters will have the same
values as those passed to \fBTcl_TraceCommand\fR when the trace was
created. \fIClientData\fR typically points to an application-specific
data structure that describes what to do when \fIproc\fR is invoked.
\fIOldName\fR gives the name of the command being renamed, and
\fInewName\fR gives the name that the command is being renamed to (or
NULL when the command is being deleted.)
\fIFlags\fR is an OR'ed combination of bits potentially providing
several pieces of information. One of the bits \fBTCL_TRACE_RENAME\fR and
\fBTCL_TRACE_DELETE\fR will be set in \fIflags\fR to indicate which
|
| ︙ | ︙ |
Changes to doc/TraceVar.3.
1 2 3 4 5 6 7 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" | | | | | | | | 1 2 3 4 5 6 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 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1996 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_TraceVar 3 8.7 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_TraceVar, Tcl_TraceVar2, Tcl_UntraceVar, Tcl_UntraceVar2, Tcl_VarTraceInfo, Tcl_VarTraceInfo2 \- monitor accesses to a variable .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp int \fBTcl_TraceVar(\fIinterp, varName, flags, proc, clientData\fB)\fR .sp int \fBTcl_TraceVar2(\fIinterp, name1, name2, flags, proc, clientData\fB)\fR .sp \fBTcl_UntraceVar(\fIinterp, varName, flags, proc, clientData\fB)\fR .sp \fBTcl_UntraceVar2(\fIinterp, name1, name2, flags, proc, clientData\fB)\fR .sp ClientData \fBTcl_VarTraceInfo(\fIinterp, varName, flags, proc, prevClientData\fB)\fR .sp ClientData \fBTcl_VarTraceInfo2(\fIinterp, name1, name2, flags, proc, prevClientData\fB)\fR .SH ARGUMENTS .AS Tcl_VarTraceProc prevClientData .AP Tcl_Interp *interp in Interpreter containing variable. .AP "const char" *varName in Name of variable. May refer to a scalar variable, to an array variable with no index, or to an array variable with a parenthesized index. .AP int flags in OR-ed combination of the values \fBTCL_TRACE_READS\fR, \fBTCL_TRACE_WRITES\fR, \fBTCL_TRACE_UNSETS\fR, \fBTCL_TRACE_ARRAY\fR, \fBTCL_GLOBAL_ONLY\fR, \fBTCL_NAMESPACE_ONLY\fR, \fBTCL_TRACE_RESULT_DYNAMIC\fR and \fBTCL_TRACE_RESULT_OBJECT\fR. Not all flags are used by all procedures. See below for more information. .AP Tcl_VarTraceProc *proc in Procedure to invoke whenever one of the traced operations occurs. .AP ClientData clientData in Arbitrary one-word value to pass to \fIproc\fR. .AP "const char" *name1 in Name of scalar or array variable (without array index). .AP "const char" *name2 in For a trace on an element of an array, gives the index of the element. For traces on scalar variables or on whole arrays, is NULL. .AP ClientData prevClientData in If non-NULL, gives last value returned by \fBTcl_VarTraceInfo\fR or \fBTcl_VarTraceInfo2\fR, so this call will return information about next trace. If NULL, this call will return information about first trace. .BE .SH DESCRIPTION .PP |
| ︙ | ︙ | |||
91 92 93 94 95 96 97 | \fBTCL_TRACE_WRITES\fR Invoke \fIproc\fR whenever an attempt is made to modify the variable. .TP \fBTCL_TRACE_UNSETS\fR Invoke \fIproc\fR whenever the variable is unset. A variable may be unset either explicitly by an \fBunset\fR command, or implicitly when a procedure returns (its local variables are | | | | | | 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 |
\fBTCL_TRACE_WRITES\fR
Invoke \fIproc\fR whenever an attempt is made to modify the variable.
.TP
\fBTCL_TRACE_UNSETS\fR
Invoke \fIproc\fR whenever the variable is unset.
A variable may be unset either explicitly by an \fBunset\fR command,
or implicitly when a procedure returns (its local variables are
automatically unset) or when the interpreter or namespace is deleted (all
variables are automatically unset).
.TP
\fBTCL_TRACE_ARRAY\fR
Invoke \fIproc\fR whenever the array command is invoked.
This gives the trace procedure a chance to update the array before
array names or array get is called. Note that this is called
before an array set, but that will trigger write traces.
.TP
\fBTCL_TRACE_RESULT_DYNAMIC\fR
The result of invoking the \fIproc\fR is a dynamically allocated
string that will be released by the Tcl library via a call to
\fBckfree\fR. Must not be specified at the same time as
\fBTCL_TRACE_RESULT_OBJECT\fR.
.TP
\fBTCL_TRACE_RESULT_OBJECT\fR
The result of invoking the \fIproc\fR is a Tcl_Obj* (cast to a char*)
with a reference count of at least one. The ownership of that
reference will be transferred to the Tcl core for release (when the
core has finished with it) via a call to \fBTcl_DecrRefCount\fR. Must
not be specified at the same time as \fBTCL_TRACE_RESULT_DYNAMIC\fR.
.PP
Whenever one of the specified operations occurs on the variable,
\fIproc\fR will be invoked.
It should have arguments and result that match the type
\fBTcl_VarTraceProc\fR:
.PP
.CS
typedef char *\fBTcl_VarTraceProc\fR(
ClientData \fIclientData\fR,
Tcl_Interp *\fIinterp\fR,
char *\fIname1\fR,
char *\fIname2\fR,
int \fIflags\fR);
.CE
.PP
The \fIclientData\fR and \fIinterp\fR parameters will
have the same values as those passed to \fBTcl_TraceVar\fR when the
trace was created.
\fIClientData\fR typically points to an application-specific
data structure that describes what to do when \fIproc\fR
is invoked.
\fIName1\fR and \fIname2\fR give the name of the traced variable
in the normal two-part form (see the description of \fBTcl_TraceVar2\fR
below for details).
\fIFlags\fR is an OR-ed combination of bits providing several
pieces of information.
|
| ︙ | ︙ | |||
156 157 158 159 160 161 162 | procedure call: the trace procedure will need to pass this flag back to variable-related procedures like \fBTcl_GetVar\fR if it attempts to access the variable. The bit \fBTCL_TRACE_DESTROYED\fR will be set in \fIflags\fR if the trace is about to be destroyed; this information may be useful to \fIproc\fR so that it can clean up its own internal data structures (see the section \fBTCL_TRACE_DESTROYED\fR below for more details). | < < < < | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 | procedure call: the trace procedure will need to pass this flag back to variable-related procedures like \fBTcl_GetVar\fR if it attempts to access the variable. The bit \fBTCL_TRACE_DESTROYED\fR will be set in \fIflags\fR if the trace is about to be destroyed; this information may be useful to \fIproc\fR so that it can clean up its own internal data structures (see the section \fBTCL_TRACE_DESTROYED\fR below for more details). The trace procedure's return value should normally be NULL; see \fBERROR RETURNS\fR below for information on other possibilities. .PP \fBTcl_UntraceVar\fR may be used to remove a trace. If the variable specified by \fIinterp\fR, \fIvarName\fR, and \fIflags\fR has a trace set with \fIflags\fR, \fIproc\fR, and \fIclientData\fR, then the corresponding trace is removed. |
| ︙ | ︙ | |||
308 309 310 311 312 313 314 | successful completion. If \fIproc\fR returns a non-NULL value it signifies that an error occurred. The return value must be a pointer to a static character string containing an error message, unless (\fIexactly\fR one of) the \fBTCL_TRACE_RESULT_DYNAMIC\fR and \fBTCL_TRACE_RESULT_OBJECT\fR flags is set, which specify that the result is | | > > > > > > > > > | 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 | successful completion. If \fIproc\fR returns a non-NULL value it signifies that an error occurred. The return value must be a pointer to a static character string containing an error message, unless (\fIexactly\fR one of) the \fBTCL_TRACE_RESULT_DYNAMIC\fR and \fBTCL_TRACE_RESULT_OBJECT\fR flags is set, which specify that the result is either a dynamic string (to be released with \fBckfree\fR) or a Tcl_Obj* (cast to char* and to be released with \fBTcl_DecrRefCount\fR) containing the error message. If a trace procedure returns an error, no further traces are invoked for the access and the traced access aborts with the given message. Trace procedures can use this facility to make variables read-only, for example (but note that the value of the variable will already have been modified before the trace procedure is called, so the trace procedure will have to restore the correct value). .PP The return value from \fIproc\fR is only used during read and write tracing. During unset traces, the return value is ignored and all relevant trace procedures will always be invoked. .SH "RESTRICTIONS" .PP Because operations on variables may take place as part of the deletion of the interp that contains them, \fIproc\fR must be careful about checking what the \fIinterp\fR parameter can be used to do. The routine \fBTcl_InterpDeleted\fR is an important tool for this. When \fBTcl_InterpDeleted\fR returns 1, \fIproc\fR will not be able to invoke any scripts in \fIinterp\fR. You may encounter old code using a deprecated flag value \fBTCL_INTERP_DESTROYED\fR to signal this condition, but any supported code should be converted to stop using it. .PP A trace procedure can be called at any time, even when there are partially formed results stored in the interpreter. If the trace procedure does anything that could damage this result (such as calling \fBTcl_Eval\fR) then it must use the \fBTcl_SaveInterpState\fR and related routines to save and restore the original state of the interpreter before it returns. .SH "UNDEFINED VARIABLES" |
| ︙ | ︙ | |||
350 351 352 353 354 355 356 | In an unset callback to \fIproc\fR, the \fBTCL_TRACE_DESTROYED\fR bit is set in \fIflags\fR if the trace is being removed as part of the deletion. Traces on a variable are always removed whenever the variable is deleted; the only time \fBTCL_TRACE_DESTROYED\fR is not set is for a whole-array trace invoked when only a single element of an array is unset. | < < < < < < < < < < < < < < < < | 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 | In an unset callback to \fIproc\fR, the \fBTCL_TRACE_DESTROYED\fR bit is set in \fIflags\fR if the trace is being removed as part of the deletion. Traces on a variable are always removed whenever the variable is deleted; the only time \fBTCL_TRACE_DESTROYED\fR is not set is for a whole-array trace invoked when only a single element of an array is unset. .SH BUGS .PP Array traces are not yet integrated with the Tcl \fBinfo exists\fR command, nor is there Tcl-level access to array traces. .SH "SEE ALSO" trace(n) .SH KEYWORDS clientData, trace, variable |
Changes to doc/Utf.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" 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 Utf 3 "8.1" Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | > > > > > > > > > > > > > > > > > > | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | '\" '\" Copyright (c) 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 Utf 3 "8.1" Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_UniChar, Tcl_UniCharToUtf, Tcl_UtfToUniChar, Tcl_UtfToChar16, Tcl_UtfToWChar, Tcl_UniCharToUtfDString, Tcl_UtfToUniCharDString, Tcl_Char16ToUtfDString, Tcl_UtfToWCharDString, Tcl_UtfToChar16DString, Tcl_UniCharLen, Tcl_UniCharNcmp, Tcl_UniCharNcasecmp, Tcl_UniCharCaseMatch, Tcl_UtfNcmp, Tcl_UtfNcasecmp, Tcl_UtfCharComplete, Tcl_NumUtfChars, Tcl_UtfFindFirst, Tcl_UtfFindLast, Tcl_UtfNext, Tcl_UtfPrev, Tcl_UniCharAtIndex, Tcl_UtfAtIndex, Tcl_UtfBackslash \- routines for manipulating UTF-8 strings .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp typedef ... \fBTcl_UniChar\fR; .sp int \fBTcl_UniCharToUtf\fR(\fIch, buf\fR) .sp int \fBTcl_UtfToUniChar\fR(\fIsrc, chPtr\fR) .sp int \fBTcl_UtfToChar16\fR(\fIsrc, uPtr\fR) .sp int \fBTcl_UtfToWChar\fR(\fIsrc, wPtr\fR) .sp char * \fBTcl_UniCharToUtfDString\fR(\fIuniStr, uniLength, dsPtr\fR) .sp char * \fBTcl_Char16ToUtfDString\fR(\fIuStr, uniLength, dsPtr\fR) .sp char * \fBTcl_WCharToUtfDString\fR(\fIwStr, uniLength, dsPtr\fR) .sp Tcl_UniChar * \fBTcl_UtfToUniCharDString\fR(\fIsrc, length, dsPtr\fR) .sp unsigned short * \fBTcl_UtfToChar16DString\fR(\fIsrc, length, dsPtr\fR) .sp wchar_t * \fBTcl_UtfToWCharDString\fR(\fIsrc, length, dsPtr\fR) .sp int \fBTcl_UniCharLen\fR(\fIuniStr\fR) .sp int \fBTcl_UniCharNcmp\fR(\fIucs, uct, numChars\fR) .sp int \fBTcl_UniCharNcasecmp\fR(\fIucs, uct, numChars\fR) .sp int \fBTcl_UniCharCaseMatch\fR(\fIuniStr, uniPattern, nocase\fR) .sp int \fBTcl_UtfNcmp\fR(\fIcs, ct, numChars\fR) .sp int \fBTcl_UtfNcasecmp\fR(\fIcs, ct, numChars\fR) .sp int \fBTcl_UtfCharComplete\fR(\fIsrc, length\fR) .sp int \fBTcl_NumUtfChars\fR(\fIsrc, length\fR) .sp |
| ︙ | ︙ | |||
65 66 67 68 69 70 71 | .sp int \fBTcl_UniCharAtIndex\fR(\fIsrc, index\fR) .sp const char * \fBTcl_UtfAtIndex\fR(\fIsrc, index\fR) .sp | | | > > > > > > > > > > > > > > | | | > > | | | < | | | | < > | | < | 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 | .sp int \fBTcl_UniCharAtIndex\fR(\fIsrc, index\fR) .sp const char * \fBTcl_UtfAtIndex\fR(\fIsrc, index\fR) .sp int \fBTcl_UtfBackslash\fR(\fIsrc, readPtr, dst\fR) .SH ARGUMENTS .AS "const Tcl_UniChar" *uniPattern in/out .AP char *buf out Buffer in which the UTF-8 representation of the Tcl_UniChar is stored. At most 4 bytes are stored in the buffer. .AP int ch in The Unicode character to be converted or examined. .AP Tcl_UniChar *chPtr out Filled with the Tcl_UniChar represented by the head of the UTF-8 string. .AP unsigned short *uPtr out Filled with the utf-16 represented by the head of the UTF-8 string. .AP wchar_t *wPtr out Filled with the wchar_t represented by the head of the UTF-8 string. .AP "const char" *src in Pointer to a UTF-8 string. .AP "const char" *cs in Pointer to a UTF-8 string. .AP "const char" *ct in Pointer to a UTF-8 string. .AP "const Tcl_UniChar" *uniStr in A null-terminated Unicode string. .AP "const Tcl_UniChar" *ucs in A null-terminated Unicode string. .AP "const Tcl_UniChar" *uct in A null-terminated Unicode string. .AP "const Tcl_UniChar" *uniPattern in A null-terminated Unicode string. .AP "const unsigned short" *uStr in A null-terminated UTF-16 string. .AP "const wchar_t" *wStr in A null-terminated wchar_t string. .AP "const unsigned short" *utf16s in A null-terminated utf-16 string. .AP "const unsigned short" *utf16t in A null-terminated utf-16 string. .AP "const unsigned short" *utf16Pattern in A null-terminated utf-16 string. .AP int length in The length of the UTF-8 string in bytes (not UTF-8 characters). If negative, all bytes up to the first null byte are used. .AP int uniLength in The length of the Unicode string in characters. .AP "Tcl_DString" *dsPtr in/out A pointer to a previously initialized \fBTcl_DString\fR. .AP "unsigned long" numChars in The number of characters to compare. .AP "const char" *start in Pointer to the beginning of a UTF-8 string. .AP int index in The index of a character (not byte) in the UTF-8 string. .AP int *readPtr out If non-NULL, filled with the number of bytes in the backslash sequence, including the backslash character. .AP char *dst out Buffer in which the bytes represented by the backslash sequence are stored. At most 4 bytes are stored in the buffer. .AP int nocase in Specifies whether the match should be done case-sensitive (0) or case-insensitive (1). .BE .SH DESCRIPTION .PP These routines convert between UTF-8 strings and Unicode/Utf-16 characters. A UTF-8 character is a Unicode character represented as a varying-length sequence of up to \fB4\fR bytes. A multibyte UTF-8 sequence consists of a lead byte followed by some number of trail bytes. .PP \fBTCL_UTF_MAX\fR is the maximum number of bytes that \fBTcl_UtfToUniChar\fR can consume in a single call. .PP \fBTcl_UniCharToUtf\fR stores the character \fIch\fR as a UTF-8 string in starting at \fIbuf\fR. The return value is the number of bytes stored in \fIbuf\fR. If ch is a high surrogate (range U+D800 - U+DBFF), then the return value will be 1 and a single byte in the range 0xF0 - 0xF4 will be stored. If you still want to produce UTF-8 output for it (even though knowing it's an illegal code-point on its own), just call \fBTcl_UniCharToUtf\fR again specifying ch = -1. .PP \fBTcl_UtfToUniChar\fR reads one UTF-8 character starting at \fIsrc\fR and stores it as a Tcl_UniChar in \fI*chPtr\fR. The return value is the number of bytes read from \fIsrc\fR. The caller must ensure that the source buffer is long enough such that this routine does not run off the end and dereference non-existent or random memory; if the source buffer is known to be null-terminated, this will not happen. If the input is a byte in the range 0x80 - 0x9F, \fBTcl_UtfToUniChar\fR assumes the cp1252 encoding, stores the corresponding Tcl_UniChar in \fI*chPtr\fR and returns 1. If the input is otherwise not in proper UTF-8 format, \fBTcl_UtfToUniChar\fR will store the first byte of \fIsrc\fR in \fI*chPtr\fR as a Tcl_UniChar between 0x00A0 and 0x00FF and return 1. .PP \fBTcl_UniCharToUtfDString\fR converts the given Unicode string to UTF-8, storing the result in a previously initialized \fBTcl_DString\fR. The return value is a pointer to the UTF-8 representation of the Unicode string. Storage for the return value is appended to the end of the \fBTcl_DString\fR. .PP \fBTcl_UtfToUniCharDString\fR converts the given UTF-8 string to Unicode, storing the result in the previously initialized \fBTcl_DString\fR. In the argument \fIlength\fR, you may either specify the length of |
| ︙ | ︙ | |||
169 170 171 172 173 174 175 | \fBTcl_UniCharLen\fR corresponds to \fBstrlen\fR for Unicode characters. It accepts a null-terminated Unicode string and returns the number of Unicode characters (not bytes) in that string. .PP \fBTcl_UniCharNcmp\fR and \fBTcl_UniCharNcasecmp\fR correspond to \fBstrncmp\fR and \fBstrncasecmp\fR, respectively, for Unicode characters. They accept two null-terminated Unicode strings and the number of characters | | | | 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 | \fBTcl_UniCharLen\fR corresponds to \fBstrlen\fR for Unicode characters. It accepts a null-terminated Unicode string and returns the number of Unicode characters (not bytes) in that string. .PP \fBTcl_UniCharNcmp\fR and \fBTcl_UniCharNcasecmp\fR correspond to \fBstrncmp\fR and \fBstrncasecmp\fR, respectively, for Unicode characters. They accept two null-terminated Unicode strings and the number of characters to compare. Both strings are assumed to be at least \fInumChars\fR characters long. \fBTcl_UniCharNcmp\fR compares the two strings character-by-character according to the Unicode character ordering. It returns an integer greater than, equal to, or less than 0 if the first string is greater than, equal to, or less than the second string respectively. \fBTcl_UniCharNcasecmp\fR is the Unicode case insensitive version. .PP \fBTcl_UniCharCaseMatch\fR is the Unicode equivalent to \fBTcl_StringCaseMatch\fR. It accepts a null-terminated Unicode string, a Unicode pattern, and a boolean value specifying whether the match should be case sensitive and returns whether the string matches the pattern. .PP \fBTcl_UtfNcmp\fR corresponds to \fBstrncmp\fR for UTF-8 strings. It accepts two null-terminated UTF-8 strings and the number of characters to compare. (Both strings are assumed to be at least \fInumChars\fR characters long.) \fBTcl_UtfNcmp\fR compares the two strings character-by-character according to the Unicode character ordering. It returns an integer greater than, equal to, or less than 0 if the first string is greater than, equal to, or less than the second string respectively. .PP \fBTcl_UtfNcasecmp\fR corresponds to \fBstrncasecmp\fR for UTF-8 |
| ︙ | ︙ | |||
223 224 225 226 227 228 229 | .PP Given \fIsrc\fR, a pointer to some location in a UTF-8 string, \fBTcl_UtfNext\fR returns a pointer to the next UTF-8 character in the string. The caller must not ask for the next character after the last character in the string if the string is not terminated by a null character. .PP | > | > > | | | > > | | > > | > > > > > > > | | > | > > > | | | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 | .PP Given \fIsrc\fR, a pointer to some location in a UTF-8 string, \fBTcl_UtfNext\fR returns a pointer to the next UTF-8 character in the string. The caller must not ask for the next character after the last character in the string if the string is not terminated by a null character. .PP \fBTcl_UtfPrev\fR is used to step backward through but not beyond the UTF-8 string that begins at \fIstart\fR. If the UTF-8 string is made up entirely of complete and well-formed characters, and \fIsrc\fR points to the lead byte of one of those characters (or to the location one byte past the end of the string), then repeated calls of \fBTcl_UtfPrev\fR will return pointers to the lead bytes of each character in the string, one character at a time, terminating when it returns \fIstart\fR. .PP When the conditions of completeness and well-formedness may not be satisfied, a more precise description of the function of \fBTcl_UtfPrev\fR is necessary. It always returns a pointer greater than or equal to \fIstart\fR; that is, always a pointer to a location in the string. It always returns a pointer to a byte that begins a character when scanning for characters beginning from \fIstart\fR. When \fIsrc\fR is greater than \fIstart\fR, it always returns a pointer less than \fIsrc\fR and greater than or equal to (\fIsrc\fR - \fBTCL_UTF_MAX\fR). The character that begins at the returned pointer is the first one that either includes the byte \fIsrc[-1]\fR, or might include it if the right trail bytes are present at \fIsrc\fR and greater. \fBTcl_UtfPrev\fR never reads the byte \fIsrc[0]\fR nor the byte \fIstart[-1]\fR nor the byte \fIsrc[-\fBTCL_UTF_MAX\fI-1]\fR. .PP \fBTcl_UniCharAtIndex\fR corresponds to a C string array dereference or the Pascal Ord() function. It returns the Unicode character represented at the specified character (not byte) \fIindex\fR in the UTF-8 string \fIsrc\fR. The source string must contain at least \fIindex\fR characters. If a negative \fIindex\fR is given or \fIindex\fR points to the second half of a surrogate pair, it returns -1. .PP \fBTcl_UtfAtIndex\fR returns a pointer to the specified character (not byte) \fIindex\fR in the UTF-8 string \fIsrc\fR. The source string must contain at least \fIindex\fR characters. This is equivalent to calling \fBTcl_UtfToUniChar\fR \fIindex\fR times, except if that would return a pointer to the second byte of a valid 4-byte UTF-8 sequence, in which case, \fBTcl_UtfToUniChar\fR will be called once more to find the end of the sequence. If a negative \fIindex\fR is given, the returned pointer points to the first character in the source string. .PP \fBTcl_UtfBackslash\fR is a utility procedure used by several of the Tcl commands. It parses a backslash sequence and stores the properly formed UTF-8 character represented by the backslash sequence in the output buffer \fIdst\fR. At most 4 bytes are stored in the buffer. \fBTcl_UtfBackslash\fR modifies \fI*readPtr\fR to contain the number of bytes in the backslash sequence, including the backslash character. The return value is the number of bytes stored in the output buffer. .PP See the \fBTcl\fR manual entry for information on the valid backslash sequences. All of the sequences described in the Tcl manual entry are supported by \fBTcl_UtfBackslash\fR. .SH KEYWORDS utf, unicode, backslash |
Changes to doc/binary.n.
| ︙ | ︙ | |||
69 70 71 72 73 74 75 | newline character, .QW \en . .PP During decoding, the following options are supported: .TP \fB\-strict\fR . | | > > | > | | | | | > > > | < | > > | | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 |
newline character,
.QW \en .
.PP
During decoding, the following options are supported:
.TP
\fB\-strict\fR
.
Instructs the decoder to throw an error if it encounters any characters
that are not strictly part of the encoding itself. Otherwise it ignores them.
RFC 2045 calls for base64 decoders to be non-strict.
.RE
.TP
\fBhex\fR
.
The \fBhex\fR binary encoding converts each byte to a pair of hexadecimal
digits in big-endian form.
.RS
.PP
No options are supported during encoding. During decoding, the following
options are supported:
.TP
\fB\-strict\fR
.
Instructs the decoder to throw an error if it encounters whitespace characters.
Otherwise it ignores them.
.RE
.TP
\fBuuencode\fR
.
The \fBuuencode\fR binary encoding used to be common for transfer of data
between Unix systems and on USENET, but is less common these days, having been
largely superseded by the \fBbase64\fR binary encoding.
.RS
.PP
During encoding, the following options are supported (though changing them may
produce files that other implementations of decoders cannot process):
.TP
\fB\-maxlen \fIlength\fR
.
Indicates the maximum number of characters to produce for each encoded line.
The valid range is 5 to 85. Line lengths outside that range cannot be
accommodated by the encoding format. The default value is 61.
.TP
\fB\-wrapchar \fIcharacter\fR
.
Indicates the character(s) to use to mark the end of each encoded line.
Acceptable values are a sequence of zero or more characters from the
set { \\x09 (TAB), \\x0B (VT), \\x0C (FF), \\x0D (CR) } followed
by zero or one newline \\x0A (LF). Any other values are rejected because
they would generate encoded text that could not be decoded. The default value
is a single newline.
.PP
During decoding, the following options are supported:
.TP
\fB\-strict\fR
.
Instructs the decoder to throw an error if it encounters anything
outside of the standard encoding format. Without this option, the
decoder tolerates some deviations, mostly to forgive reflows of lines
between the encoder and decoder.
.PP
Note that neither the encoder nor the decoder handle the header and footer of
the uuencode format.
.RE
.SH "BINARY FORMAT"
.PP
The \fBbinary format\fR command generates a binary string whose layout
|
| ︙ | ︙ |
Added doc/case.n.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH case n 7.0 Tcl "Tcl Built-In Commands"
.so man.macros
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
case \- Evaluate one of several scripts, depending on a given value
.SH SYNOPSIS
\fBcase\fI string \fR?\fBin\fR? \fIpatList body \fR?\fIpatList body \fR...?
.sp
\fBcase\fI string \fR?\fBin\fR? {\fIpatList body \fR?\fIpatList body \fR...?}
.BE
.SH DESCRIPTION
.PP
\fINote: the \fBcase\fI command is obsolete and is supported only
for backward compatibility. At some point in the future it may be
removed entirely. You should use the \fBswitch\fI command instead.\fR
.PP
The \fBcase\fR command matches \fIstring\fR against each of
the \fIpatList\fR arguments in order.
Each \fIpatList\fR argument is a list of one or
more patterns. If any of these patterns matches \fIstring\fR then
\fBcase\fR evaluates the following \fIbody\fR argument
by passing it recursively to the Tcl interpreter and returns the result
of that evaluation.
Each \fIpatList\fR argument consists of a single
pattern or list of patterns. Each pattern may contain any of the wild-cards
described under \fBstring match\fR. If a \fIpatList\fR
argument is \fBdefault\fR, the corresponding body will be evaluated
if no \fIpatList\fR matches \fIstring\fR. If no \fIpatList\fR argument
matches \fIstring\fR and no default is given, then the \fBcase\fR
command returns an empty string.
.PP
Two syntaxes are provided for the \fIpatList\fR and \fIbody\fR arguments.
The first uses a separate argument for each of the patterns and commands;
this form is convenient if substitutions are desired on some of the
patterns or commands.
The second form places all of the patterns and commands together into
a single argument; the argument must have proper list structure, with
the elements of the list being the patterns and commands.
The second form makes it easy to construct multi-line case commands,
since the braces around the whole list make it unnecessary to include a
backslash at the end of each line.
Since the \fIpatList\fR arguments are in braces in the second form,
no command or variable substitutions are performed on them; this makes
the behavior of the second form different than the first form in some
cases.
.SH "SEE ALSO"
switch(n)
.SH KEYWORDS
case, match, regular expression
|
Changes to doc/catch.n.
| ︙ | ︙ | |||
52 53 54 55 56 57 58 | the \fB\-level\fR and \fB\-code\fR entries be something else, as further described in the documentation for the \fBreturn\fR command. .PP When the return code from evaluation of \fIscript\fR is \fBTCL_ERROR\fR, four additional entries are defined in the dictionary of return options stored in \fIoptionsVarName\fR: \fB\-errorinfo\fR, \fB\-errorcode\fR, \fB\-errorline\fR, and | < < < < < < | 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 |
the \fB\-level\fR and \fB\-code\fR entries be something else, as
further described in the documentation for the \fBreturn\fR command.
.PP
When the return code from evaluation of \fIscript\fR is
\fBTCL_ERROR\fR, four additional entries are defined in the dictionary
of return options stored in \fIoptionsVarName\fR: \fB\-errorinfo\fR,
\fB\-errorcode\fR, \fB\-errorline\fR, and
\fB\-errorstack\fR.
The value of the \fB\-errorinfo\fR entry is a formatted stack trace containing
more information about the context in which the error happened. The formatted
stack trace is meant to be read by a person. The value of the
\fB\-errorcode\fR entry is additional information about the error stored as a
list. The \fB\-errorcode\fR value is meant to be further processed by
programs, and may not be particularly readable by people. The value of the
\fB\-errorline\fR entry is an integer indicating which line of \fIscript\fR
was being evaluated when the error occurred.
The value of the \fB\-errorstack\fR entry is an
even-sized list made of token-parameter pairs accumulated while
unwinding the stack. The token may be
.QW \fBCALL\fR ,
in which case the parameter is a list made of the proc name and arguments at
the corresponding level; or it may be
.QW \fBUP\fR ,
in which case the parameter is
the relative level (as in \fBuplevel\fR) of the previous \fBCALL\fR. The
salient differences with respect to \fB\-errorinfo\fR are that:
.IP [1]
it is a machine-readable form that is amenable to processing with
[\fBforeach\fR {tok prm} ...],
.IP [2]
it contains the true (substituted) values passed to the functions, instead of
the static text of the calling sites, and
.IP [3]
it is coarser-grained, with only one element per stack frame (like procs; no
separate elements for \fBforeach\fR constructs for example).
.PP
The values of the \fB\-errorinfo\fR and \fB\-errorcode\fR entries of
the most recent error are also available as values of the global
variables \fB::errorInfo\fR and \fB::errorCode\fR respectively.
The value of the \fB\-errorstack\fR entry surfaces as \fBinfo errorstack\fR.
.PP
Tcl packages may provide commands that set other entries in the
dictionary of return options, and the \fBreturn\fR command may be
used by scripts to set return options in addition to those defined
above.
.SH EXAMPLES
.PP
|
| ︙ | ︙ |
Changes to doc/cd.n.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 | .PP Change the current working directory to \fIdirName\fR, or to the home directory (as specified in the HOME environment variable) if \fIdirName\fR is not given. Returns an empty string. Note that the current working directory is a per-process resource; the \fBcd\fR command changes the working directory for all interpreters | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | .PP Change the current working directory to \fIdirName\fR, or to the home directory (as specified in the HOME environment variable) if \fIdirName\fR is not given. Returns an empty string. Note that the current working directory is a per-process resource; the \fBcd\fR command changes the working directory for all interpreters and all threads. .SH EXAMPLES .PP Change to the home directory of the user \fBfred\fR: .PP .CS \fBcd\fR ~fred .CE |
| ︙ | ︙ |
Changes to doc/chan.n.
| ︙ | ︙ | |||
31 32 33 34 35 36 37 | been configured to be non-blocking; all Tcl channels have blocking turned on by default. .TP \fBchan close \fIchannelId\fR ?\fIdirection\fR? . Close and destroy the channel called \fIchannelId\fR. Note that this deletes all existing file-events registered on the channel. | < < | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | been configured to be non-blocking; all Tcl channels have blocking turned on by default. .TP \fBchan close \fIchannelId\fR ?\fIdirection\fR? . Close and destroy the channel called \fIchannelId\fR. Note that this deletes all existing file-events registered on the channel. If the \fIdirection\fR argument (which must be \fBread\fR or \fBwrite\fR or any unique abbreviation of them) is present, the channel will only be half-closed, so that it can go from being read-write to write-only or read-only respectively. If a read-only channel is closed for reading, it is the same as if the channel is fully closed, and respectively similar for write-only channels. Without the \fIdirection\fR argument, the channel is closed for both reading and writing (but only if those directions are currently open). It is an error to close a read-only channel for writing, or a write-only channel for reading. .RS .PP As part of closing the channel, all buffered output is flushed to the channel's output device (only if the channel is ceasing to be writable), any buffered input is discarded (only if the channel is ceasing to be readable), the underlying operating system resource is closed and \fIchannelId\fR becomes unavailable for future use (both only if the channel is being completely |
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | ensure that all output is correctly flushed before the process exits. .PP The command returns an empty string, and may generate an error if an error occurs while flushing output. If a command in a command pipeline created with \fBopen\fR returns an error, \fBchan close\fR generates an error (similar to the \fBexec\fR command.) .PP | < < | 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 | ensure that all output is correctly flushed before the process exits. .PP The command returns an empty string, and may generate an error if an error occurs while flushing output. If a command in a command pipeline created with \fBopen\fR returns an error, \fBchan close\fR generates an error (similar to the \fBexec\fR command.) .PP Note that half-closes of sockets and command pipelines can have important side effects because they result in a shutdown() or close() of the underlying system resource, which can change how other processes or systems respond to the Tcl program. .RE .TP \fBchan configure \fIchannelId\fR ?\fIoptionName\fR? ?\fIvalue\fR? ?\fIoptionName value\fR?... . Query or set the configuration options of the channel named \fIchannelId\fR. .RS |
| ︙ | ︙ | |||
536 537 538 539 540 541 542 | internally for \fIchannelId\fR (especially useful in a readable event callback to impose application-specific limits on input line lengths to avoid a potential denial-of-service attack where a hostile user crafts an extremely long line that exceeds the available memory to buffer it). Returns -1 if the channel was not opened for the mode in question. .TP \fBchan pipe\fR | < < < < | 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 | internally for \fIchannelId\fR (especially useful in a readable event callback to impose application-specific limits on input line lengths to avoid a potential denial-of-service attack where a hostile user crafts an extremely long line that exceeds the available memory to buffer it). Returns -1 if the channel was not opened for the mode in question. .TP \fBchan pipe\fR Creates a standalone pipe whose read- and write-side channels are returned as a 2-element list, the first element being the read side and the second the write side. Can be useful e.g. to redirect separately \fBstderr\fR and \fBstdout\fR from a subprocess. To do this, spawn with "2>@" or ">@" redirection operators onto the write side of a pipe, and then immediately close it in the parent. This is necessary to get an EOF on the read side once the child has exited or otherwise closed its output. .RS .PP Note that the pipe buffering semantics can vary at the operating system level substantially; it is not safe to assume that a write performed on the output side of the pipe will appear instantly to the input side. This is a fundamental difference and Tcl cannot conceal it. The overall stream semantics \fIare\fR compatible, so blocking reads and writes will not see most of the differences, but the details of what exactly gets written when are not. This is most likely to show up when using pipelines for testing; care should be taken to ensure that deadlocks do not occur and that potential short reads are allowed for. .RE .TP \fBchan pop \fIchannelId\fR Removes the topmost transformation from the channel \fIchannelId\fR, if there is any. If there are no transformations added to \fIchannelId\fR, this is equivalent to \fBchan close\fR of that channel. The result is normally the empty string, but can be an error in some situations (i.e. where the underlying system stream is closed and that results in an error). .TP \fBchan postevent \fIchannelId eventSpec\fR . This subcommand is used by command handlers specified with \fBchan create\fR. It notifies the channel represented by the handle \fIchannelId\fR that the event(s) listed in the \fIeventSpec\fR have occurred. The argument has to be a list containing any of the strings |
| ︙ | ︙ | |||
605 606 607 608 609 610 611 | current interpreter or in other interpreters or other threads, even where the event is posted from a safe interpreter and listened for by a trusted interpreter. \fBChan event\fR handlers are \fIalways\fR executed in the interpreter that set them up. .RE .TP \fBchan push \fIchannelId cmdPrefix\fR | < < | 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 | current interpreter or in other interpreters or other threads, even where the event is posted from a safe interpreter and listened for by a trusted interpreter. \fBChan event\fR handlers are \fIalways\fR executed in the interpreter that set them up. .RE .TP \fBchan push \fIchannelId cmdPrefix\fR Adds a new transformation on top of the channel \fIchannelId\fR. The \fIcmdPrefix\fR argument describes a list of one or more words which represent a handler that will be used to implement the transformation. The command prefix must provide the API described in the \fBtranschan\fR manual page. The result of this subcommand is a handle to the transformation. Note that it is important to make sure that the transformation is capable of supporting the channel mode that it is used with or this can make the channel neither readable nor writable. .TP \fBchan puts\fR ?\fB\-nonewline\fR? ?\fIchannelId\fR? \fIstring\fR . Writes \fIstring\fR to the channel named \fIchannelId\fR followed by a newline character. A trailing newline character is written unless the optional flag \fB\-nonewline\fR is given. If \fIchannelId\fR is omitted, the string is written to the standard output channel, |
| ︙ | ︙ |
Changes to doc/close.n.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 | channel. When the last interpreter in which the channel is registered invokes \fBclose\fR, the cleanup actions described above occur. See the \fBinterp\fR command for a description of channel sharing. .PP Channels are automatically closed when an interpreter is destroyed and when the process exits. | < < < | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | channel. When the last interpreter in which the channel is registered invokes \fBclose\fR, the cleanup actions described above occur. See the \fBinterp\fR command for a description of channel sharing. .PP Channels are automatically closed when an interpreter is destroyed and when the process exits. From 8.6 on (TIP#398), nonblocking channels are no longer switched to blocking mode when exiting; this guarantees a timely exit even when the peer or a communication channel is stalled. To ensure proper flushing of stalled nonblocking channels on exit, one must now either (a) actively switch them back to blocking or (b) use the environment variable TCL_FLUSH_NONBLOCKING_ON_EXIT, which when set and not equal to "0" restores the previous behavior. .PP The command returns an empty string, and may generate an error if an error occurs while flushing output. If a command in a command pipeline created with \fBopen\fR returns an error, \fBclose\fR generates an error (similar to the \fBexec\fR command.) .PP The two-argument form is a .QW "half-close" : given a bidirectional channel like a socket or command pipeline and a (possibly abbreviated) direction, it closes only the sub-stream going in that direction. This means a shutdown() on a socket, and a close() of one end of a pipe for a command pipeline. Then, the Tcl-level channel data structure is either kept or freed depending on whether |
| ︙ | ︙ | |||
76 77 78 79 80 81 82 | .PP In the case of a command pipeline, the child-reaping duty falls upon the shoulders of the last close or half-close, which is thus allowed to report an abnormal exit error. .PP Currently only sockets and command pipelines support half-close. A future extension will allow reflected and stacked channels to do so. | < | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 | .PP In the case of a command pipeline, the child-reaping duty falls upon the shoulders of the last close or half-close, which is thus allowed to report an abnormal exit error. .PP Currently only sockets and command pipelines support half-close. A future extension will allow reflected and stacked channels to do so. .SH EXAMPLE .PP This illustrates how you can use Tcl to ensure that files get closed even when errors happen by combining \fBcatch\fR, \fBclose\fR and \fBreturn\fR: .PP .CS |
| ︙ | ︙ |
Changes to doc/coroutine.n.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 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. '\" .TH coroutine n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | '\" '\" Copyright (c) 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. '\" .TH coroutine n 8.6 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME coroutine, yield, yieldto, coroinject, coroprobe \- Create and produce values from coroutines .SH SYNOPSIS .nf \fBcoroutine \fIname command\fR ?\fIarg...\fR? \fByield\fR ?\fIvalue\fR? \fByieldto\fR \fIcommand\fR ?\fIarg...\fR? \fIname\fR ?\fIvalue...\fR? .sp |
| ︙ | ︙ |
Changes to doc/dde.n.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | dde \- Execute a Dynamic Data Exchange command .SH SYNOPSIS .sp \fBpackage require dde 1.4\fR .sp \fBdde servername\fR ?\fB\-force\fR? ?\fB\-handler \fIproc\fR? ?\fB\-\|\-\fR? ?\fItopic\fR? .sp | < < | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | dde \- Execute a Dynamic Data Exchange command .SH SYNOPSIS .sp \fBpackage require dde 1.4\fR .sp \fBdde servername\fR ?\fB\-force\fR? ?\fB\-handler \fIproc\fR? ?\fB\-\|\-\fR? ?\fItopic\fR? .sp \fBdde execute\fR ?\fB\-async\fR? ?\fB\-binary\fR? \fIservice topic data\fR .sp \fBdde poke\fR ?\fB\-binary\fR? \fIservice topic item data\fR .sp \fBdde request\fR ?\fB\-binary\fR? \fIservice topic item\fR .sp \fBdde services \fIservice topic\fR .sp \fBdde eval\fR ?\fB\-async\fR? \fItopic cmd \fR?\fIarg arg ...\fR? .BE |
| ︙ | ︙ | |||
78 79 80 81 82 83 84 | \fIservice\fR is the name of an application, and \fItopic\fR is a file to work on. The \fIdata\fR field is given to the remote application. Typically, the application treats the \fIdata\fR field as a script, and the script is run in the application. The \fB\-async\fR option requests asynchronous invocation. The command returns an error message if the script did not run, unless the \fB\-async\fR flag was used, in which case the command returns immediately with no error. | < < < < | 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 | \fIservice\fR is the name of an application, and \fItopic\fR is a file to work on. The \fIdata\fR field is given to the remote application. Typically, the application treats the \fIdata\fR field as a script, and the script is run in the application. The \fB\-async\fR option requests asynchronous invocation. The command returns an error message if the script did not run, unless the \fB\-async\fR flag was used, in which case the command returns immediately with no error. Without the \fB\-binary\fR option all data will be sent in unicode. For dde clients which don't implement the CF_UNICODE clipboard format, this will automatically be translated to the system encoding. You can use the \fB\-binary\fR option in combination with the result of \fBencoding convertto\fR to send data in any other encoding. .TP \fBdde poke\fR ?\fB\-binary\fR? \fIservice topic item data\fR . \fBdde poke\fR passes the \fIdata\fR to the server indicated by \fIservice\fR using the \fItopic\fR and \fIitem\fR specified. Typically, \fIservice\fR is the name of an application. \fItopic\fR is application specific but can be a command to the server or the name of a file to work on. The \fIitem\fR is also application specific and is often not used, but it must always be non-null. The \fIdata\fR field is given to the remote application. Without the \fB\-binary\fR option all data will be sent in unicode. For dde clients which don't implement the CF_UNICODE clipboard format, this will automatically be translated to the system encoding. You can use the \fB\-binary\fR option in combination with the result of \fBencoding convertto\fR to send data in any other encoding. .TP \fBdde request\fR ?\fB\-binary\fR? \fIservice topic item\fR . \fBdde request\fR is typically used to get the value of something; the value of a cell in Microsoft Excel or the text of a selection in Microsoft Word. \fIservice\fR is typically the name of an application, \fItopic\fR is typically the name of the file, and \fIitem\fR is |
| ︙ | ︙ |
Changes to doc/define.n.
| ︙ | ︙ | |||
584 585 586 587 588 589 590 | Some operations omit one or both of the first two steps; omitting the third would result in an idempotent read-only operation (but the standard mechanism for reading from slots is via \fBinfo class\fR and \fBinfo object\fR). .VE TIP516 .SH EXAMPLES This example demonstrates how to use both forms of the \fBoo::define\fR and \fBoo::objdefine\fR commands (they work in the same way), as well as | | | 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 |
Some operations omit one or both of the first two steps; omitting the third
would result in an idempotent read-only operation (but the standard mechanism
for reading from slots is via \fBinfo class\fR and \fBinfo object\fR).
.VE TIP516
.SH EXAMPLES
This example demonstrates how to use both forms of the \fBoo::define\fR and
\fBoo::objdefine\fR commands (they work in the same way), as well as
illustrating four of the subcommands of them.
.PP
.CS
oo::class create c
c create o
\fBoo::define\fR c \fBmethod\fR foo {} {
puts "world"
}
|
| ︙ | ︙ |
Changes to doc/dict.n.
| ︙ | ︙ | |||
50 51 52 53 54 55 56 | . This takes a dictionary value and returns a new dictionary that contains just those key/value pairs that match the specified filter type (which may be abbreviated.) Supported filter types are: .RS .TP \fBdict filter \fIdictionaryValue \fBkey\fR ?\fIglobPattern ...\fR? | < < < < | 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 |
.
This takes a dictionary value and returns a new dictionary that
contains just those key/value pairs that match the specified filter
type (which may be abbreviated.) Supported filter types are:
.RS
.TP
\fBdict filter \fIdictionaryValue \fBkey\fR ?\fIglobPattern ...\fR?
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 return 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
were inserted into the dictionary.
.TP
\fBdict filter \fIdictionaryValue \fBvalue \fR?\fIglobPattern ...\fR?
The value rule only matches those key/value pairs whose values match any
of the given patterns (in the style of \fBstring match\fR.)
.RE
.TP
\fBdict for {\fIkeyVariable valueVariable\fB} \fIdictionaryValue body\fR
.
This command takes three arguments, the first a two-element list of
variable names (for the key and value respectively of each mapping in
the dictionary), the second the dictionary value to iterate across,
|
| ︙ | ︙ |
Changes to doc/exec.n.
| ︙ | ︙ | |||
334 335 336 337 338 339 340 |
set status [lindex $details 2]
} else {
# Some other error; regenerate it to let caller handle
return -options $options -level 0 $results
}
}
.CE
| < < | 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 |
set status [lindex $details 2]
} else {
# Some other error; regenerate it to let caller handle
return -options $options -level 0 $results
}
}
.CE
.PP
This is more easily written using the \fBtry\fR command, as that makes
it simpler to trap specific types of errors. This is
done using code like this:
.PP
.CS
try {
set results [\fBexec\fR grep foo bar.txt]
set status 0
} trap CHILDSTATUS {results options} {
set status [lindex [dict get $options -errorcode] 2]
}
.CE
.SS "WORKING WITH QUOTED ARGUMENTS"
.PP
When translating a command from a Unix shell invocation, care should
be taken over the fact that single quote characters have no special
significance to Tcl. Thus:
.PP
.CS
|
| ︙ | ︙ |
Changes to doc/expr.n.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | .SH NAME expr \- Evaluate an expression .SH SYNOPSIS \fBexpr \fIarg \fR?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | .SH NAME expr \- Evaluate an expression .SH SYNOPSIS \fBexpr \fIarg \fR?\fIarg arg ...\fR? .BE .SH DESCRIPTION .PP The \fIexpr\fR command concatenates \fIarg\fRs, separated by a space, into an expression, and evaluates that expression, returning its value. The operators permitted in an expression include a subset of the operators permitted in C expressions. For those operators common to both Tcl and C, Tcl applies the same meaning and precedence as the corresponding C operators. The value of an expression is often a numeric result, either an integer or a floating-point value, but may also be a non-numeric value. |
| ︙ | ︙ | |||
42 43 44 45 46 47 48 | 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. | < < < < < < < < < < < < < < | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | 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: .IP [1] As a numeric value, either integer or floating-point. .IP [2] As a boolean value, using any form understood by \fBstring is\fR \fBboolean\fR. |
| ︙ | ︙ | |||
97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
.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
.SS OPERATORS
.PP
For operators having both a numeric mode and a string mode, the numeric mode is
chosen when all operands have a numeric interpretation. The integer
interpretation of an operand is preferred over the floating-point
interpretation. To ensure string operations on arbitrary values it is generally a
good idea to use \fBeq\fR, \fBne\fR, or the \fBstring\fR command instead of
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
.CS
.ta 9c
\fBexpr\fR 3.1 + $a \fI6.1\fR
\fBexpr\fR 2 + "$a.$b" \fI5.6\fR
\fBexpr\fR 4*[llength "6 2"] \fI8\fR
\fBexpr\fR {{word one} < "word $a"} \fI0\fR
.CE
.PP
\fBInteger value\fR
.PP
An integer operand may be specified in decimal (the normal case, the optional
first two characters are \fB0d\fR), binary
(the first two characters are \fB0b\fR), octal
(the first two characters are \fB0o\fR), or hexadecimal
(the first two characters are \fB0x\fR) form. For
compatibility with older Tcl releases, an operand that begins with \fB0\fR is
interpreted as an octal integer even if the second character is not \fBo\fR.
.PP
\fBFloating-point value\fR
.PP
A floating-point number may be specified in any of several
common decimal formats, and may use the decimal point \fB.\fR,
\fBe\fR or \fBE\fR for scientific notation, and
the sign characters \fB+\fR and \fB\-\fR. The
following are all valid floating-point numbers: 2.1, 3., 6e4, 7.91e+16.
The strings \fBInf\fR
and \fBNaN\fR, in any combination of case, are also recognized as floating point
values. An operand that doesn't have a numeric interpretation must be quoted
with either braces or with double quotes.
.PP
\fBBoolean value\fR
.PP
A boolean value may be represented by any of the values \fB0\fR, \fBfalse\fR, \fBno\fR,
or \fBoff\fR and any of the values \fB1\fR, \fBtrue\fR, \fByes\fR, or \fBon\fR.
.PP
\fBDigit Separator\fR
.PP
Digits in any numeric value may be separated with one or more underscore
characters, "\fB_\fR", to improve readability. These separators may only
appear between digits. The separator may not appear at the start of a
numeric value, between the leading 0 and radix specifier, or at the
end of a numeric value. Here are some examples:
.PP
.CS
.ta 9c
\fBexpr\fR 100_000_000 \fI100000000\fR
\fBexpr\fR 0xffff_ffff \fI4294967295\fR
\fBformat\fR 0x%x 0b1111_1110_1101_1011 \fI0xfedb\fR
.CE
.PP
.SS OPERATORS
.PP
For operators having both a numeric mode and a string mode, the numeric mode is
chosen when all operands have a numeric interpretation. The integer
interpretation of an operand is preferred over the floating-point
interpretation. To ensure string operations on arbitrary values it is generally a
good idea to use \fBeq\fR, \fBne\fR, or the \fBstring\fR command instead of
|
| ︙ | ︙ | |||
468 469 470 471 472 473 474 |
.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
| | | 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 |
.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 by Kevin B. Kenny <kennykb@acm.org>. All rights reserved.
.fi
'\" Local Variables:
'\" mode: nroff
'\" End:
|
Changes to doc/file.n.
| ︙ | ︙ | |||
461 462 463 464 465 466 467 | /var/tmp/myapp_0ihS0n .CE .RE .VE "8.7, TIP 431" .TP \fBfile tempfile\fR ?\fInameVar\fR? ?\fItemplate\fR? '\" TIP #210 | < < | 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 | /var/tmp/myapp_0ihS0n .CE .RE .VE "8.7, TIP 431" .TP \fBfile tempfile\fR ?\fInameVar\fR? ?\fItemplate\fR? '\" TIP #210 Creates a temporary file and returns a read-write channel opened on that file. If the \fInameVar\fR is given, it specifies a variable that the name of the temporary file will be written into; if absent, Tcl will attempt to arrange for the temporary file to be deleted once it is no longer required. If the \fItemplate\fR is present, it specifies parts of the template of the filename to use when creating it (such as the directory, base-name or extension) though some platforms may ignore some or all of these parts and use a built-in default instead. .RS .PP Note that temporary files are \fIonly\fR ever created on the native filesystem. As such, they can be relied upon to be used with operating-system native APIs and external programs that require a filename. .RE .TP \fBfile type \fIname\fR . Returns a string giving the type of file \fIname\fR, which will be one of \fBfile\fR, \fBdirectory\fR, \fBcharacterSpecial\fR, \fBblockSpecial\fR, \fBfifo\fR, \fBlink\fR, or \fBsocket\fR. .TP |
| ︙ | ︙ |
Changes to doc/http.n.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | .TH "http" n 2.9 http "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME http \- Client-side implementation of the HTTP/1.1 protocol .SH SYNOPSIS | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | .TH "http" n 2.9 http "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME http \- Client-side implementation of the HTTP/1.1 protocol .SH SYNOPSIS \fBpackage require http\fI ?\fB2.9\fR? .\" See Also -useragent option documentation in body! .sp \fB::http::config\fR ?\fI\-option value\fR ...? .sp \fB::http::geturl \fIurl\fR ?\fI\-option value\fR ...? .sp \fB::http::formatQuery\fR \fIkey value\fR ?\fIkey value\fR ...? |
| ︙ | ︙ | |||
166 167 168 169 170 171 172 | throwing an error processing non-latin-1 characters. .TP \fB\-useragent\fR \fIstring\fR . The value of the User-Agent header in the HTTP request. In an unsafe interpreter, the default value depends upon the operating system, and the version numbers of \fBhttp\fR and \fBTcl\fR, and is (for example) | | | 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 | throwing an error processing non-latin-1 characters. .TP \fB\-useragent\fR \fIstring\fR . The value of the User-Agent header in the HTTP request. In an unsafe interpreter, the default value depends upon the operating system, and the version numbers of \fBhttp\fR and \fBTcl\fR, and is (for example) .QW "\fBMozilla/5.0 (Windows; U; Windows NT 10.0) http/2.9.0 Tcl/8.6.9\fR" . A safe interpreter cannot determine its operating system, and so the default in a safe interpreter is to use a Windows 10 value with the current version numbers of \fBhttp\fR and \fBTcl\fR. .TP \fB\-zip\fR \fIboolean\fR . If the value is boolean \fBtrue\fR, then by default requests will send a header |
| ︙ | ︙ |
Changes to doc/interp.n.
| ︙ | ︙ | |||
150 151 152 153 154 155 156 | for the interpreter identified by \fIpath\fR. 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 \fBinterp\fR \fBcancel \fR?\fB\-unwind\fR? ?\fB\-\|\-\fR? ?\fIpath\fR? ?\fIresult\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 175 | for the interpreter identified by \fIpath\fR. 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 \fBinterp\fR \fBcancel \fR?\fB\-unwind\fR? ?\fB\-\|\-\fR? ?\fIpath\fR? ?\fIresult\fR? Cancels the script being evaluated in the interpreter identified by \fIpath\fR. Without the \fB\-unwind\fR switch the evaluation stack for the interpreter is unwound until an enclosing catch command is found or there are no further invocations of the interpreter left on the call stack. With the \fB\-unwind\fR switch the evaluation stack for the interpreter is unwound without regard to any intervening catch command until there are no further invocations of the interpreter left on the call stack. 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. 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 slave interpreter identified by \fIpath\fR and a new command, called a \fIslave command\fR. The name of the slave command is the last component of \fIpath\fR. The new slave interpreter and the slave command are created in the interpreter identified by the path obtained by removing |
| ︙ | ︙ |
Changes to doc/lappend.n.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 | 1 % \fBlappend\fR var 2 1 2 % \fBlappend\fR var 3 4 5 1 2 3 4 5 .CE .SH "SEE ALSO" | | > | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 | 1 % \fBlappend\fR var 2 1 2 % \fBlappend\fR var 3 4 5 1 2 3 4 5 .CE .SH "SEE ALSO" list(n), lassign(n), lindex(n), linsert(n), llength(n), lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), lreverse(n), lsearch(n), lset(n), lsort(n) .SH KEYWORDS append, element, list, variable .\" Local variables: .\" mode: nroff .\" fill-column: 78 .\" End: |
Changes to doc/lassign.n.
| ︙ | ︙ | |||
48 49 50 51 52 53 54 | .QW shift command in many shell languages like this: .PP .CS set ::argv [\fBlassign\fR $::argv argumentToReadOff] .CE .SH "SEE ALSO" | > > | | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 | .QW shift command in many shell languages like this: .PP .CS set ::argv [\fBlassign\fR $::argv argumentToReadOff] .CE .SH "SEE ALSO" list(n), lappend(n), lindex(n), linsert(n), llength(n), lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n), lreverse(n), lsearch(n), lset(n), lsort(n) .SH KEYWORDS assign, element, list, multiple, set, variable '\"Local Variables: '\"mode: nroff '\"End: |
Changes to doc/library.n.
| ︙ | ︙ | |||
295 296 297 298 299 300 301 | \fBtcl_startOfNextWord\fR, \fBtcl_startOfPreviousWord\fR, \fBtcl_wordBreakAfter\fR, and \fBtcl_wordBreakBefore\fR commands. .TP \fBtcl_nonwordchars\fR This variable contains a regular expression that is used by routines like \fBtcl_endOfWord\fR to identify whether a character is part of a word or not. If the pattern matches a character, the character is | | < < < | < < | 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 | \fBtcl_startOfNextWord\fR, \fBtcl_startOfPreviousWord\fR, \fBtcl_wordBreakAfter\fR, and \fBtcl_wordBreakBefore\fR commands. .TP \fBtcl_nonwordchars\fR This variable contains a regular expression that is used by routines like \fBtcl_endOfWord\fR to identify whether a character is part of a word or not. If the pattern matches a character, the character is considered to be a non-word character. The default is "\\W". .TP \fBtcl_wordchars\fR This variable contains a regular expression that is used by routines like \fBtcl_endOfWord\fR to identify whether a character is part of a word or not. If the pattern matches a character, the character is considered to be a word character. The default is "\\w". .SH "SEE ALSO" env(n), info(n), re_syntax(n) .SH KEYWORDS auto-exec, auto-load, library, unknown, word, whitespace '\"Local Variables: '\"mode: nroff '\"End: |
Changes to doc/lindex.n.
| ︙ | ︙ | |||
111 112 113 114 115 116 117 |
\fBlindex\fR {a b c d e f} $idx+2
\fI\(-> d\fR
set idx 3
\fBlindex\fR {a b c d e f} $idx+2
\fI\(-> f\fR
.CE
.SH "SEE ALSO"
| | > | | 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 |
\fBlindex\fR {a b c d e f} $idx+2
\fI\(-> d\fR
set idx 3
\fBlindex\fR {a b c d e f} $idx+2
\fI\(-> f\fR
.CE
.SH "SEE ALSO"
list(n), lappend(n), lassign(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
lreverse(n), lsearch(n), lset(n), lsort(n),
string(n)
.SH KEYWORDS
element, index, list
'\"Local Variables:
'\"mode: nroff
'\"End:
|
Changes to doc/linsert.n.
| ︙ | ︙ | |||
41 42 43 44 45 46 47 |
set oldList {the fox jumps over the dog}
set midList [\fBlinsert\fR $oldList 1 quick]
set newList [\fBlinsert\fR $midList end-1 lazy]
# The old lists still exist though...
set newerList [\fBlinsert\fR [\fBlinsert\fR $oldList end-1 quick] 1 lazy]
.CE
.SH "SEE ALSO"
| | > | | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 |
set oldList {the fox jumps over the dog}
set midList [\fBlinsert\fR $oldList 1 quick]
set newList [\fBlinsert\fR $midList end-1 lazy]
# The old lists still exist though...
set newerList [\fBlinsert\fR [\fBlinsert\fR $oldList end-1 quick] 1 lazy]
.CE
.SH "SEE ALSO"
list(n), lappend(n), lassign(n), lindex(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
lreverse(n), lsearch(n), lset(n), lsort(n),
string(n)
.SH KEYWORDS
element, insert, list
'\" Local Variables:
'\" mode: nroff
'\" End:
|
Changes to doc/list.n.
| ︙ | ︙ | |||
42 43 44 45 46 47 48 |
.PP
while \fBconcat\fR with the same arguments will return
.PP
.CS
\fBa b c d e f {g h}\fR
.CE
.SH "SEE ALSO"
| | | | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 |
.PP
while \fBconcat\fR with the same arguments will return
.PP
.CS
\fBa b c d e f {g h}\fR
.CE
.SH "SEE ALSO"
lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
lreverse(n), lsearch(n), lset(n), lsort(n)
.SH KEYWORDS
element, list, quoting
'\"Local Variables:
'\"mode: nroff
'\"End:
|
Changes to doc/llength.n.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 |
An empty list is not necessarily an empty string:
.PP
.CS
% set var { }; puts "[string length $var],[\fBllength\fR $var]"
1,0
.CE
.SH "SEE ALSO"
| | > | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
An empty list is not necessarily an empty string:
.PP
.CS
% set var { }; puts "[string length $var],[\fBllength\fR $var]"
1,0
.CE
.SH "SEE ALSO"
list(n), lappend(n), lassign(n), lindex(n), linsert(n),
lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
lreverse(n), lsearch(n), lset(n), lsort(n)
.SH KEYWORDS
element, list, length
'\" Local Variables:
'\" mode: nroff
'\" fill-column: 78
'\" End:
|
Changes to doc/lmap.n.
| ︙ | ︙ | |||
73 74 75 76 77 78 79 |
proc isGood {counter} {expr {$n > 3}}
set prefix [\fBlmap\fR x $values {expr {
[isGood $x] ? $x : [break]
}}]
# The value of prefix is "8 7 6 5 4"
.CE
.SH "SEE ALSO"
| | > > > | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 |
proc isGood {counter} {expr {$n > 3}}
set prefix [\fBlmap\fR x $values {expr {
[isGood $x] ? $x : [break]
}}]
# The value of prefix is "8 7 6 5 4"
.CE
.SH "SEE ALSO"
break(n), continue(n), for(n), foreach(n), while(n),
list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
lreverse(n), lsearch(n), lset(n), lsort(n)
.SH KEYWORDS
foreach, iteration, list, loop, map
'\" Local Variables:
'\" mode: nroff
'\" End:
|
Changes to doc/load.n.
| ︙ | ︙ | |||
150 151 152 153 154 155 156 | .SH EXAMPLE .PP The following is a minimal extension: .PP .CS #include <tcl.h> #include <stdio.h> | | | 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 |
.SH EXAMPLE
.PP
The following is a minimal extension:
.PP
.CS
#include <tcl.h>
#include <stdio.h>
static int fooCmd(ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
printf("called with %d arguments\en", objc);
return TCL_OK;
}
int Foo_Init(Tcl_Interp *interp) {
if (Tcl_InitStubs(interp, "8.1", 0) == NULL) {
return TCL_ERROR;
|
| ︙ | ︙ |
Changes to doc/lpop.n.
| ︙ | ︙ | |||
82 83 84 85 86 87 88 |
The indicated value becomes the new value of \fIx\fR.
.PP
.CS
\fBlpop\fR x 1 1 0
\fI\(-> {{a b} {c d}} {{e f} h}\fR
.CE
.SH "SEE ALSO"
| | | > | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 |
The indicated value becomes the new value of \fIx\fR.
.PP
.CS
\fBlpop\fR x 1 1 0
\fI\(-> {{a b} {c d}} {{e f} h}\fR
.CE
.SH "SEE ALSO"
list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
lmap(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
lreverse(n), lsearch(n), lset(n), lsort(n),
string(n)
.SH KEYWORDS
element, index, list, remove, pop, stack, queue
'\"Local Variables:
'\"mode: nroff
'\"End:
|
Changes to doc/lrange.n.
| ︙ | ︙ | |||
67 68 69 70 71 72 73 |
some {elements to} select
% lindex $var 1
elements to
% \fBlrange\fR $var 1 1
{elements to}
.CE
.SH "SEE ALSO"
| | | > | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 |
some {elements to} select
% lindex $var 1
elements to
% \fBlrange\fR $var 1 1
{elements to}
.CE
.SH "SEE ALSO"
list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lremove(n), lrepeat(n), lreplace(n),
lreverse(n), lsearch(n), lset(n), lsort(n),
string(n)
.SH KEYWORDS
element, list, range, sublist
'\" Local Variables:
'\" mode: nroff
'\" fill-column: 78
'\" End:
|
Changes to doc/lremove.n.
| ︙ | ︙ | |||
42 43 44 45 46 47 48 |
Removing the same element indicated in two different ways:
.PP
.CS
% \fBlremove\fR {a b c d e} 2 end-2
a b d e
.CE
.SH "SEE ALSO"
| > > | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
Removing the same element indicated in two different ways:
.PP
.CS
% \fBlremove\fR {a b c d e} 2 end-2
a b d e
.CE
.SH "SEE ALSO"
list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lrepeat(n), lreplace(n),
lreverse(n), lsearch(n), lset(n), lsort(n)
.SH KEYWORDS
element, list, remove
.\" Local variables:
.\" mode: nroff
.\" fill-column: 78
.\" End:
|
Changes to doc/lrepeat.n.
| ︙ | ︙ | |||
28 29 30 31 32 33 34 |
\fI\(-> {0 0 0} {0 0 0} {0 0 0}\fR
\fBlrepeat\fR 3 a b c
\fI\(-> a b c a b c a b c\fR
\fBlrepeat\fR 3 [\fBlrepeat\fR 2 a] b c
\fI\(-> {a a} b c {a a} b c {a a} b c\fR
.CE
.SH "SEE ALSO"
| | > > | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
\fI\(-> {0 0 0} {0 0 0} {0 0 0}\fR
\fBlrepeat\fR 3 a b c
\fI\(-> a b c a b c a b c\fR
\fBlrepeat\fR 3 [\fBlrepeat\fR 2 a] b c
\fI\(-> {a a} b c {a a} b c {a a} b c\fR
.CE
.SH "SEE ALSO"
list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lreplace(n),
lreverse(n), lsearch(n), lset(n), lsort(n)
.SH KEYWORDS
element, index, list
'\" Local Variables:
'\" mode: nroff
'\" fill-column: 78
'\" End:
|
Changes to doc/lreplace.n.
| ︙ | ︙ | |||
91 92 93 94 95 96 97 |
% set var {a b c d e}
a b c d e
% set var [\fBlreplace\fR $var 12345 end+2 f g h i]
a b c d e f g h i
.CE
.VE TIP505
.SH "SEE ALSO"
| | | > | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 |
% set var {a b c d e}
a b c d e
% set var [\fBlreplace\fR $var 12345 end+2 f g h i]
a b c d e f g h i
.CE
.VE TIP505
.SH "SEE ALSO"
list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n),
lreverse(n), lsearch(n), lset(n), lsort(n),
string(n)
.SH KEYWORDS
element, list, replace
.\" Local variables:
.\" mode: nroff
.\" fill-column: 78
.\" End:
|
Changes to doc/lreverse.n.
| ︙ | ︙ | |||
21 22 23 24 25 26 27 |
.CS
\fBlreverse\fR {a a b c}
\fI\(-> c b a a\fR
\fBlreverse\fR {a b {c d} e f}
\fI\(-> f e {c d} b a\fR
.CE
.SH "SEE ALSO"
| | | > | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
.CS
\fBlreverse\fR {a a b c}
\fI\(-> c b a a\fR
\fBlreverse\fR {a b {c d} e f}
\fI\(-> f e {c d} b a\fR
.CE
.SH "SEE ALSO"
list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
lsearch(n), lset(n), lsort(n)
.SH KEYWORDS
element, list, reverse
'\" Local Variables:
'\" mode: nroff
'\" End:
|
Changes to doc/lsearch.n.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 | .BE .SH DESCRIPTION .PP This command searches the elements of \fIlist\fR to see if one of them matches \fIpattern\fR. If so, the command returns the index of the first matching element (unless the options \fB\-all\fR or \fB\-inline\fR are specified.) | | > | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | .BE .SH DESCRIPTION .PP This command searches the elements of \fIlist\fR to see if one of them matches \fIpattern\fR. If so, the command returns the index of the first matching element (unless the options \fB\-all\fR or \fB\-inline\fR are specified.) If not, the command returns \fB\-1\fR or (if options \fB\-all\fR or \fB\-inline\fR are specified) the empty string. The \fIoption\fR arguments indicates how the elements of the list are to be matched against \fIpattern\fR and must have one of the values below: .SS "MATCHING STYLE OPTIONS" .PP If all matching style options are omitted, the default matching style is \fB\-glob\fR. If more than one matching style is specified, the last matching style given takes precedence. |
| ︙ | ︙ | |||
130 131 132 133 134 135 136 | .TP \fB\-increasing\fR . The list elements are sorted in increasing order. This option is only meaningful when used with \fB\-sorted\fR. .TP \fB\-bisect\fR | < < | 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 | .TP \fB\-increasing\fR . The list elements are sorted in increasing order. This option is only meaningful when used with \fB\-sorted\fR. .TP \fB\-bisect\fR Inexact search when the list elements are in sorted order. For an increasing list the last index where the element is less than or equal to the pattern is returned. For a decreasing list the last index where the element is greater than or equal to the pattern is returned. If the pattern is before the first element or the list is empty, -1 is returned. This option implies \fB\-sorted\fR and cannot be used with either \fB\-all\fR or \fB\-not\fR. .SS "NESTED LIST OPTIONS" .PP These options are used to search lists of lists. They may be used with any other options. .TP \fB\-stride\0\fIstrideLength\fR . |
| ︙ | ︙ | |||
225 226 227 228 229 230 231 |
The same thing for a flattened list:
.PP
.CS
\fBlsearch\fR -stride 2 -index 1 -all -inline {a abc b bcd c cde} *bc*
\fI\(-> {a abc b bcd}\fR
.CE
.SH "SEE ALSO"
| > | > | | 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 |
The same thing for a flattened list:
.PP
.CS
\fBlsearch\fR -stride 2 -index 1 -all -inline {a abc b bcd c cde} *bc*
\fI\(-> {a abc b bcd}\fR
.CE
.SH "SEE ALSO"
foreach(n),
list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
lreverse(n), lset(n), lsort(n),
string(n)
.SH KEYWORDS
binary search, linear search,
list, match, pattern, regular expression, search, string
'\" Local Variables:
'\" mode: nroff
'\" End:
|
Changes to doc/lset.n.
| ︙ | ︙ | |||
132 133 134 135 136 137 138 |
.CS
\fBlset\fR x 1 1 0 j
\fI\(-> {{a b} {c d}} {{e f} {j h}}\fR
\fBlset\fR x {1 1 0} j
\fI\(-> {{a b} {c d}} {{e f} {j h}}\fR
.CE
.SH "SEE ALSO"
| | | > | 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 |
.CS
\fBlset\fR x 1 1 0 j
\fI\(-> {{a b} {c d}} {{e f} {j h}}\fR
\fBlset\fR x {1 1 0} j
\fI\(-> {{a b} {c d}} {{e f} {j h}}\fR
.CE
.SH "SEE ALSO"
list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
lreverse(n), lsearch(n), lsort(n)
string(n)
.SH KEYWORDS
element, index, list, replace, set
'\"Local Variables:
'\"mode: nroff
'\"End:
|
Changes to doc/lsort.n.
| ︙ | ︙ | |||
217 218 219 220 221 222 223 |
{ c 3} {a 5} {b 4} {d 2} {e 1}
\fI%\fR \fBlsort\fR -index 0 {{a 5} { c 3} {b 4} {e 1} {d 2}}
{a 5} {b 4} { c 3} {d 2} {e 1}
\fI%\fR \fBlsort\fR -index 1 {{a 5} { c 3} {b 4} {e 1} {d 2}}
{e 1} {d 2} { c 3} {b 4} {a 5}
.CE
.PP
| < < | 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 |
{ c 3} {a 5} {b 4} {d 2} {e 1}
\fI%\fR \fBlsort\fR -index 0 {{a 5} { c 3} {b 4} {e 1} {d 2}}
{a 5} {b 4} { c 3} {d 2} {e 1}
\fI%\fR \fBlsort\fR -index 1 {{a 5} { c 3} {b 4} {e 1} {d 2}}
{e 1} {d 2} { c 3} {b 4} {a 5}
.CE
.PP
Sorting a dictionary:
.PP
.CS
\fI%\fR set d [dict create c d a b h i f g c e]
c e a b h i f g
\fI%\fR \fBlsort\fR -stride 2 $d
a b c e f g h i
.CE
.PP
Sorting using striding and multiple indices:
.PP
.CS
\fI%\fR # Note the first index value is relative to the group
\fI%\fR \fBlsort\fR \-stride 3 \-index {0 1} \e
{{Bob Smith} 25 Audi {Jane Doe} 40 Ford}
{{Jane Doe} 40 Ford {Bob Smith} 25 Audi}
.CE
.PP
Stripping duplicate values using sorting:
.PP
.CS
\fI%\fR \fBlsort\fR -unique {a b c a b c a b c}
a b c
.CE
|
| ︙ | ︙ | |||
262 263 264 265 266 267 268 |
return [string compare [lindex $a 1] [lindex $b 1]]
}
\fI%\fR \fBlsort\fR -command compare \e
{{3 apple} {0x2 carrot} {1 dingo} {2 banana}}
{1 dingo} {2 banana} {0x2 carrot} {3 apple}
.CE
.SH "SEE ALSO"
| | | > | 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 |
return [string compare [lindex $a 1] [lindex $b 1]]
}
\fI%\fR \fBlsort\fR -command compare \e
{{3 apple} {0x2 carrot} {1 dingo} {2 banana}}
{1 dingo} {2 banana} {0x2 carrot} {3 apple}
.CE
.SH "SEE ALSO"
list(n), lappend(n), lassign(n), lindex(n), linsert(n), llength(n),
lmap(n), lpop(n), lrange(n), lremove(n), lrepeat(n), lreplace(n),
lreverse(n), lsearch(n), lset(n)
.SH KEYWORDS
element, list, order, sort
'\" Local Variables:
'\" mode: nroff
'\" End:
|
Changes to doc/mathfunc.n.
| ︙ | ︙ | |||
120 121 122 123 124 125 126 | \fBsqrt\fR \fBsrand\fR \fBtan\fR \fBtanh\fR \fBwide\fR .DE .PP In addition to these predefined functions, applications may define additional functions by using \fBproc\fR (or any other method, such as \fBinterp alias\fR or \fBTcl_CreateObjCommand\fR) to define | | > > > | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 | \fBsqrt\fR \fBsrand\fR \fBtan\fR \fBtanh\fR \fBwide\fR .DE .PP In addition to these predefined functions, applications may define additional functions by using \fBproc\fR (or any other method, such as \fBinterp alias\fR or \fBTcl_CreateObjCommand\fR) to define new commands in the \fBtcl::mathfunc\fR namespace. In addition, an obsolete interface named \fBTcl_CreateMathFunc\fR() is available to extensions that are written in C. The latter interface is not recommended for new implementations. .SS "DETAILED DEFINITIONS" .TP \fBabs \fIarg\fR . Returns the absolute value of \fIarg\fR. \fIArg\fR may be either integer or floating-point, and the result is returned in the same form. .TP |
| ︙ | ︙ |
Changes to doc/memory.n.
| ︙ | ︙ | |||
21 22 23 24 25 26 27 | .TP \fBmemory active\fR \fIfile\fR . Write a list of all currently allocated memory to the specified \fIfile\fR. .TP \fBmemory break_on_malloc\fR \fIcount\fR . | | | | | 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 | .TP \fBmemory active\fR \fIfile\fR . Write a list of all currently allocated memory to the specified \fIfile\fR. .TP \fBmemory break_on_malloc\fR \fIcount\fR . After the \fIcount\fR allocations have been performed, \fBckalloc\fR outputs a message to this effect and that it is now attempting to enter the C debugger. Tcl will then issue a \fISIGINT\fR signal against itself. If you are running Tcl under a C debugger, it should then enter the debugger command mode. .TP \fBmemory info\fR . Returns a report containing the total allocations and frees since Tcl began, the current packets allocated (the current number of calls to \fBckalloc\fR not met by a corresponding call to \fBckfree\fR), the current bytes allocated, and the maximum number of packets and bytes allocated. .TP \fBmemory init \fR[\fBon\fR|\fBoff\fR] . Turn on or off the pre-initialization of all allocated memory with bogus bytes. Useful for detecting the use of uninitialized values. |
| ︙ | ︙ | |||
55 56 57 58 59 60 61 | . Causes a list of all allocated memory to be written to the specified \fIfile\fR during the finalization of Tcl's memory subsystem. Useful for checking that memory is properly cleaned up during process exit. .TP \fBmemory tag\fR \fIstring\fR . | | | | | | | | | | | | | | | 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 | . Causes a list of all allocated memory to be written to the specified \fIfile\fR during the finalization of Tcl's memory subsystem. Useful for checking that memory is properly cleaned up during process exit. .TP \fBmemory tag\fR \fIstring\fR . Each packet of memory allocated by \fBckalloc\fR can have associated with it a string-valued tag. In the lists of allocated memory generated by \fBmemory active\fR and \fBmemory onexit\fR, the tag for each packet is printed along with other information about the packet. The \fBmemory tag\fR command sets the tag value for subsequent calls to \fBckalloc\fR to be \fIstring\fR. .TP \fBmemory trace \fR[\fBon\fR|\fBoff\fR] . Turns memory tracing on or off. When memory tracing is on, every call to \fBckalloc\fR causes a line of trace information to be written to \fIstderr\fR, consisting of the word \fIckalloc\fR, followed by the address returned, the amount of memory allocated, and the C filename and line number of the code performing the allocation. For example: .RS .PP .CS ckalloc 40e478 98 tclProc.c 1406 .CE .PP Calls to \fBckfree\fR are traced in the same manner. .RE .TP \fBmemory trace_on_at_malloc\fR \fIcount\fR . Enable memory tracing after \fIcount\fR \fBckalloc\fRs have been performed. For example, if you enter \fBmemory trace_on_at_malloc 100\fR, after the 100th call to \fBckalloc\fR, memory trace information will begin being displayed for all allocations and frees. Since there can be a lot of memory activity before a problem occurs, judicious use of this option can reduce the slowdown caused by tracing (and the amount of trace information produced), if you can identify a number of allocations that occur before the problem sets in. The current number of memory allocations that have occurred since Tcl started is printed on a guard zone failure. .TP \fBmemory validate \fR[\fBon\fR|\fBoff\fR] . Turns memory validation on or off. When memory validation is enabled, on every call to \fBckalloc\fR or \fBckfree\fR, the guard zones are checked for every piece of memory currently in existence that was allocated by \fBckalloc\fR. This has a large performance impact and should only be used when overwrite problems are strongly suspected. The advantage of enabling memory validation is that a guard zone overwrite can be detected on the first call to \fBckalloc\fR or \fBckfree\fR after the overwrite occurred, rather than when the specific memory with the overwritten guard zone(s) is freed, which may occur long after the overwrite occurred. .SH "SEE ALSO" ckalloc, ckfree, Tcl_ValidateAllMemory, Tcl_DumpActiveMemory, TCL_MEM_DEBUG .SH KEYWORDS memory, debug '\"Local Variables: '\"mode: nroff '\"End: |
Changes to doc/my.n.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 | .fi .BE .SH DESCRIPTION .PP The \fBmy\fR command is used to allow methods of objects to invoke methods of the object (or its class), .VS TIP478 | | | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | .fi .BE .SH DESCRIPTION .PP The \fBmy\fR command is used to allow methods of objects to invoke methods of the object (or its class), .VS TIP478 and the \fBmyclass\fR command is used to allow methods of objects to invoke methods of the current class of the object \fIas an object\fR. .VE TIP478 In particular, the set of valid values for \fImethodName\fR is the set of all methods supported by an object and its superclasses, including those that are not exported .VS TIP500 and private methods of the object or class when used within another method |
| ︙ | ︙ |
Changes to doc/namespace.n.
| ︙ | ︙ | |||
784 785 786 787 788 789 790 | always fully qualified when read). When this option is empty, the mapping will be from the local name of the subcommand to its fully-qualified name. Note that when this option is non-empty and the \fB\-subcommands\fR option is empty, the ensemble subcommand names will be exactly those words that have mappings in the dictionary. .TP \fB\-parameters\fR | < < | 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 | always fully qualified when read). When this option is empty, the mapping will be from the local name of the subcommand to its fully-qualified name. Note that when this option is non-empty and the \fB\-subcommands\fR option is empty, the ensemble subcommand names will be exactly those words that have mappings in the dictionary. .TP \fB\-parameters\fR This option gives a list of named arguments (the names being used during generation of error messages) that are passed by the caller of the ensemble between the name of the ensemble and the subcommand argument. By default, it is the empty list. .TP \fB\-prefixes\fR . This option (which is enabled by default) controls whether the ensemble command recognizes unambiguous prefixes of its subcommands. When turned off, the ensemble command requires exact matching of subcommand names. |
| ︙ | ︙ | |||
939 940 941 942 943 944 945 |
.PP
Remove all imported commands from the current namespace:
.PP
.CS
namespace forget {*}[namespace import]
.CE
.PP
| < < | 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 |
.PP
Remove all imported commands from the current namespace:
.PP
.CS
namespace forget {*}[namespace import]
.CE
.PP
Create an ensemble for simple working with numbers, using the
\fB\-parameters\fR option to allow the operator to be put between the first
and second arguments.
.PP
.CS
\fBnamespace eval\fR do {
\fBnamespace export\fR *
\fBnamespace ensemble\fR create -parameters x
proc plus {x y} {expr { $x + $y }}
proc minus {x y} {expr { $x - $y }}
}
# In use, the ensemble works like this:
puts [do 1 plus [do 9 minus 7]]
.CE
.SH "SEE ALSO"
interp(n), upvar(n), variable(n)
.SH KEYWORDS
command, ensemble, exported, internal, variable
'\" Local Variables:
'\" mode: nroff
'\" End:
|
Changes to doc/re_syntax.n.
| ︙ | ︙ | |||
371 372 373 374 375 376 377 | for a Unicode extension up to 21 bits. The digits are parsed until the first non-hexadecimal character is encountered, the maximun of eight hexadecimal digits are reached, or an overflow would occur in the maximum value of \fBU+\fI10ffff\fR. .TP \fB\ev\fR . | | | 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 | for a Unicode extension up to 21 bits. The digits are parsed until the first non-hexadecimal character is encountered, the maximun of eight hexadecimal digits are reached, or an overflow would occur in the maximum value of \fBU+\fI10ffff\fR. .TP \fB\ev\fR . vertical tab, as in C are all available. .TP \fB\ex\fIhh\fR . (where \fIhh\fR is one or two hexadecimal digits) the character whose hexadecimal value is \fB0x\fIhh\fR. .TP \fB\e0\fR |
| ︙ | ︙ |
Changes to doc/registry.n.
| ︙ | ︙ | |||
40 41 42 43 44 45 46 | host that exports its registry. The \fIrootname\fR component must be one of \fBHKEY_LOCAL_MACHINE\fR, \fBHKEY_USERS\fR, \fBHKEY_CLASSES_ROOT\fR, \fBHKEY_CURRENT_USER\fR, \fBHKEY_CURRENT_CONFIG\fR, \fBHKEY_PERFORMANCE_DATA\fR, or \fBHKEY_DYN_DATA\fR. The \fIkeypath\fR can be one or more registry key names separated by backslash (\fB\e\fR) characters. .PP | < < | 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 | host that exports its registry. The \fIrootname\fR component must be one of \fBHKEY_LOCAL_MACHINE\fR, \fBHKEY_USERS\fR, \fBHKEY_CLASSES_ROOT\fR, \fBHKEY_CURRENT_USER\fR, \fBHKEY_CURRENT_CONFIG\fR, \fBHKEY_PERFORMANCE_DATA\fR, or \fBHKEY_DYN_DATA\fR. The \fIkeypath\fR can be one or more registry key names separated by backslash (\fB\e\fR) characters. .PP The optional \fI\-mode\fR argument indicates which registry to work with; when it is \fB\-32bit\fR the 32-bit registry will be used, and when it is \fB\-64bit\fR the 64-bit registry will be used. If this argument is omitted, the system's default registry will be the subject of the requested operation. .PP \fIOption\fR indicates what to do with the registry key name. Any unique abbreviation for \fIoption\fR is acceptable. The valid options are: .TP \fBregistry broadcast \fIkeyName\fR ?\fB\-timeout \fImilliseconds\fR? . |
| ︙ | ︙ |
Changes to doc/return.n.
| ︙ | ︙ | |||
133 134 135 136 137 138 139 | there will be no information about the context of the error within the procedure. Typically the \fIinfo\fR value is supplied from the value of \fB\-errorinfo\fR in a return options dictionary captured by the \fBcatch\fR command (or from the copy of that information stored in the global variable \fBerrorInfo\fR). .TP \fB\-errorstack \fIlist\fR | < < | 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 | there will be no information about the context of the error within the procedure. Typically the \fIinfo\fR value is supplied from the value of \fB\-errorinfo\fR in a return options dictionary captured by the \fBcatch\fR command (or from the copy of that information stored in the global variable \fBerrorInfo\fR). .TP \fB\-errorstack \fIlist\fR The \fB\-errorstack\fR option receives special treatment only when the value of the \fB\-code\fR option is \fBTCL_ERROR\fR. Then \fIlist\fR is the initial error stack, recording actual argument values passed to each proc level. The error stack will also be reachable through \fBinfo errorstack\fR. If no \fB\-errorstack\fR option is provided to \fBreturn\fR when the \fB\-code error\fR option is provided, Tcl will provide its own initial error stack in the entry for \fB\-errorstack\fR. Tcl's initial error stack will include only the call to the procedure, and stack unwinding will append information about higher stack levels, but there will be no information about the context of the error within the procedure. Typically the \fIlist\fR value is supplied from the value of \fB\-errorstack\fR in a return options dictionary captured by the \fBcatch\fR command (or from the copy of that information from \fBinfo errorstack\fR). .TP \fB\-level \fIlevel\fR . The \fB\-level\fR and \fB\-code\fR options work together to set the return code to be returned by one of the commands currently being evaluated. The \fIlevel\fR value must be a non-negative integer representing a number of levels on the call stack. It defines the number of levels up the stack |
| ︙ | ︙ |
Changes to doc/scan.n.
| ︙ | ︙ | |||
220 221 222 223 224 225 226 | hexadecimal conversions with substring sizes: .PP .CS set string "#08D03F" \fBscan\fR $string "#%2x%2x%2x" r g b .CE .PP | | > > | | 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 |
hexadecimal conversions with substring sizes:
.PP
.CS
set string "#08D03F"
\fBscan\fR $string "#%2x%2x%2x" r g b
.CE
.PP
Parse a \fIHH:MM\fR time string, noting that this avoids problems with
octal numbers by forcing interpretation as decimals (if we did not
care, we would use the \fB%i\fR conversion instead):
.PP
.CS
set string "08:08" ;# *Not* octal!
if {[\fBscan\fR $string "%d:%d" hours minutes] != 2} {
error "not a valid time string"
}
# We have to understand numeric ranges ourselves...
if {$minutes < 0 || $minutes > 59} {
error "invalid number of minutes"
}
|
| ︙ | ︙ |
Changes to doc/source.n.
| ︙ | ︙ | |||
39 40 41 42 43 44 45 | 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 . .PP | | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | 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 . .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 system encoding is assumed. .SH EXAMPLE .PP Run the script in the file \fBfoo.tcl\fR and then the script in the |
| ︙ | ︙ |
Changes to doc/string.n.
| ︙ | ︙ | |||
358 359 360 361 362 363 364 | specified using the forms described in \fBSTRING INDICES\fR. .TP \fBstring trim \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any leading or trailing characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character | | | | | 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 | specified using the forms described in \fBSTRING INDICES\fR. .TP \fBstring trim \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any leading or trailing characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character for which \fBstring is space\fR returns 1, and "\e0"). .TP \fBstring trimleft \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any leading characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character for which \fBstring is space\fR returns 1, and "\e0"). .TP \fBstring trimright \fIstring\fR ?\fIchars\fR? . Returns a value equal to \fIstring\fR except that any trailing characters present in the string given by \fIchars\fR are removed. If \fIchars\fR is not specified then white space is removed (any character for which \fBstring is space\fR returns 1, and "\e0"). .SS "OBSOLETE SUBCOMMANDS" .PP These subcommands are currently supported, but are likely to go away in a future release as their functionality is either virtually never used or highly misleading. .TP \fBstring bytelength \fIstring\fR |
| ︙ | ︙ | |||
501 502 503 504 505 506 507 |
} else {
set isPrefix [\fBstring equal\fR \-length $length $string "foobar"]
}
.CE
.SH "SEE ALSO"
expr(n), list(n)
.SH KEYWORDS
| | | 501 502 503 504 505 506 507 508 509 510 511 512 |
} else {
set isPrefix [\fBstring equal\fR \-length $length $string "foobar"]
}
.CE
.SH "SEE ALSO"
expr(n), list(n)
.SH KEYWORDS
case conversion, compare, index, integer value, match, pattern, string, word, equal,
ctype, character, reverse
.\" Local Variables:
.\" mode: nroff
.\" End:
|
Changes to doc/tclvars.n.
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH tclvars n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH tclvars n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME argc, argv, argv0, auto_path, env, errorCode, errorInfo, tcl_interactive, tcl_library, tcl_nonwordchars, tcl_patchLevel, tcl_pkgPath, tcl_platform, tcl_precision, tcl_rcFileName, tcl_traceCompile, tcl_traceExec, tcl_wordchars, tcl_version \- Variables used by Tcl .BE .SH DESCRIPTION .PP The following global variables are created and managed automatically by the Tcl library. Except where noted below, these variables should normally be treated as read-only by application-specific code and by users. .TP |
| ︙ | ︙ | |||
318 319 320 321 322 323 324 | .TP \fBosVersion\fR . The version number for the operating system running on this machine. On UNIX machines, this is the value returned by \fBuname -r\fR. .TP \fBpathSeparator\fR | < < | 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 | .TP \fBosVersion\fR . The version number for the operating system running on this machine. On UNIX machines, this is the value returned by \fBuname -r\fR. .TP \fBpathSeparator\fR '\" Defined by TIP #315 The character that should be used to \fBsplit\fR PATH-like environment variables into their corresponding list of directory names. .TP \fBplatform\fR . Either \fBwindows\fR, or \fBunix\fR. This identifies the general operating environment of the machine. .TP \fBpointerSize\fR |
| ︙ | ︙ | |||
351 352 353 354 355 356 357 358 359 360 361 362 363 364 | and the value from the GetUserName() system call on Windows. .TP \fBwordSize\fR . This gives the size of the native-machine word in bytes (strictly, it is same as the result of evaluating \fIsizeof(long)\fR in C.) .RE .TP \fBtcl_traceCompile\fR . The value of this variable can be set to control how much tracing information is displayed during bytecode compilation. By default, \fBtcl_traceCompile\fR is zero and no information is displayed. | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | and the value from the GetUserName() system call on Windows. .TP \fBwordSize\fR . This gives the size of the native-machine word in bytes (strictly, it is same as the result of evaluating \fIsizeof(long)\fR in C.) .RE .TP \fBtcl_precision\fR . This variable controls the number of digits to generate when converting floating-point values to strings. It defaults to 0. \fIApplications should not change this value;\fR it is provided for compatibility with legacy code. .PP .RS The default value of 0 is special, meaning that Tcl should convert numbers using as few digits as possible while still distinguishing any floating point number from its nearest neighbours. It differs from using an arbitrarily high value for \fItcl_precision\fR in that an inexact number like \fI1.4\fR will convert as \fI1.4\fR rather than \fI1.3999999999999999\fR even though the latter is nearer to the exact value of the binary number. .RE .PP .RS If \fBtcl_precision\fR is not zero, then when Tcl converts a floating point number, it creates a decimal representation of at most \fBtcl_precision\fR significant digits; the result may be shorter if the shorter result represents the original number exactly. If no result of at most \fBtcl_precision\fR digits is an exact representation of the original number, the one that is closest to the original number is chosen. If the original number lies precisely between two equally accurate decimal representations, then the one with an even value for the least significant digit is chosen; for instance, if \fBtcl_precision\fR is 3, then 0.3125 will convert to 0.312, not 0.313, while 0.6875 will convert to 0.688, not 0.687. Any string of trailing zeroes that remains is trimmed. .RE .PP .RS a \fBtcl_precision\fR value of 17 digits is .QW perfect for IEEE floating-point in that it allows double-precision values to be converted to strings and back to binary with no loss of information. For this reason, you will often see it as a value in legacy code that must run on Tcl versions before 8.5. It is no longer recommended; as noted above, a zero value is the preferred method. .RE .PP .RS All interpreters in a thread share a single \fBtcl_precision\fR value: changing it in one interpreter will affect all other interpreters as well. Safe interpreters are not allowed to modify the variable. .RE .PP .RS Valid values for \fBtcl_precision\fR range from 0 to 17. .RE .TP \fBtcl_rcFileName\fR . This variable is used during initialization to indicate the name of a user-specific startup file. If it is set by application-specific initialization, then the Tcl startup code will check for the existence of this file and \fBsource\fR it if it exists. For example, for \fBwish\fR the variable is set to \fB~/.wishrc\fR for Unix and \fB~/wishrc.tcl\fR for Windows. .TP \fBtcl_traceCompile\fR . The value of this variable can be set to control how much tracing information is displayed during bytecode compilation. By default, \fBtcl_traceCompile\fR is zero and no information is displayed. |
| ︙ | ︙ |
Changes to doc/zipfs.3.
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | application dynamic library, or as a zip archive named \fBlibtcl_\fImajor\fB_\fIminor\fB_\fIpatchlevel\fB.zip\fR either in the present working directory or in the standard Tcl install location. (For example, the Tcl 8.7.2 release would be searched for in a file \fBlibtcl_8_7_2.zip\fR.) That archive, if located, is also mounted read-only. .PP On Windows, \fBTclZipfs_AppHook\fR has a slightly different signature, since | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 | application dynamic library, or as a zip archive named \fBlibtcl_\fImajor\fB_\fIminor\fB_\fIpatchlevel\fB.zip\fR either in the present working directory or in the standard Tcl install location. (For example, the Tcl 8.7.2 release would be searched for in a file \fBlibtcl_8_7_2.zip\fR.) That archive, if located, is also mounted read-only. .PP On Windows, \fBTclZipfs_AppHook\fR has a slightly different signature, since it uses WCHAR instead of char. As a result, it requires your application to be compiled with the UNICODE preprocessor symbol defined (e.g., via the \fB-DUNICODE\fR compiler flag). .PP The result of \fBTclZipfs_AppHook\fR is a Tcl result code (e.g., \fBTCL_OK\fR when the function is successful). The function \fImay\fR modify the variables pointed to by \fIargcPtr\fR and \fIargvPtr\fR to remove arguments; the current implementation does not do so, but callers \fIshould not\fR assume |
| ︙ | ︙ |
Changes to generic/regc_lex.c.
| ︙ | ︙ | |||
255 256 257 258 259 260 261 |
CHR('['), CHR(':'),
CHR('s'), CHR('p'), CHR('a'), CHR('c'), CHR('e'),
CHR(':'), CHR(']')
};
#define PUNCT_CONN \
CHR('_'), \
| | | | | | | | | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 |
CHR('['), CHR(':'),
CHR('s'), CHR('p'), CHR('a'), CHR('c'), CHR('e'),
CHR(':'), CHR(']')
};
#define PUNCT_CONN \
CHR('_'), \
0x203F /* UNDERTIE */, \
0x2040 /* CHARACTER TIE */,\
0x2054 /* INVERTED UNDERTIE */,\
0xFE33 /* PRESENTATION FORM FOR VERTICAL LOW LINE */, \
0xFE34 /* PRESENTATION FORM FOR VERTICAL WAVY LOW LINE */, \
0xFE4D /* DASHED LOW LINE */, \
0xFE4E /* CENTRELINE LOW LINE */, \
0xFE4F /* WAVY LOW LINE */, \
0xFF3F /* FULLWIDTH LOW LINE */
static const chr backw[] = { /* \w */
CHR('['), CHR('['), CHR(':'),
CHR('a'), CHR('l'), CHR('n'), CHR('u'), CHR('m'),
CHR(':'), CHR(']'), PUNCT_CONN, CHR(']')
};
static const chr backW[] = { /* \W */
|
| ︙ | ︙ | |||
901 902 903 904 905 906 907 | /* * Oops, doesn't look like it's a backref after all... */ v->now = save; | | < < | | 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 |
/*
* Oops, doesn't look like it's a backref after all...
*/
v->now = save;
/* FALLTHRU */
case CHR('0'):
NOTE(REG_UUNPORT);
v->now--; /* put first digit back */
c = (uchr) lexdigits(v, 8, 1, 3);
if (ISERR()) {
FAILW(REG_EESCAPE);
}
if (c > 0xFF) {
/* out of range, so we handled one digit too much */
v->now--;
c >>= 3;
}
RETV(PLAIN, c);
break;
default:
|
| ︙ | ︙ | |||
946 947 948 949 950 951 952 |
int len;
chr c;
int d;
const uchr ub = (uchr) base;
n = 0;
for (len = 0; len < maxlen && !ATEOS(); len++) {
| | | 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 |
int len;
chr c;
int d;
const uchr ub = (uchr) base;
n = 0;
for (len = 0; len < maxlen && !ATEOS(); len++) {
if (n > 0x10FFF) {
/* Stop when continuing would otherwise overflow */
break;
}
c = *v->now++;
switch (c) {
case CHR('0'): case CHR('1'): case CHR('2'): case CHR('3'):
case CHR('4'): case CHR('5'): case CHR('6'): case CHR('7'):
|
| ︙ | ︙ |
Changes to generic/regc_locale.c.
| ︙ | ︙ | |||
130 131 132 133 134 135 136 |
*/
/*
* Unicode: alphabetic characters.
*/
static const crange alphaRangeTable[] = {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | < | | | | | | | | | > > | | | | | | | < | | > | | < | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | > | > > | 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 |
*/
/*
* Unicode: alphabetic characters.
*/
static const crange alphaRangeTable[] = {
{0x41, 0x5A}, {0x61, 0x7A}, {0xC0, 0xD6}, {0xD8, 0xF6},
{0xF8, 0x2C1}, {0x2C6, 0x2D1}, {0x2E0, 0x2E4}, {0x370, 0x374},
{0x37A, 0x37D}, {0x388, 0x38A}, {0x38E, 0x3A1}, {0x3A3, 0x3F5},
{0x3F7, 0x481}, {0x48A, 0x52F}, {0x531, 0x556}, {0x560, 0x588},
{0x5D0, 0x5EA}, {0x5EF, 0x5F2}, {0x620, 0x64A}, {0x671, 0x6D3},
{0x6FA, 0x6FC}, {0x712, 0x72F}, {0x74D, 0x7A5}, {0x7CA, 0x7EA},
{0x800, 0x815}, {0x840, 0x858}, {0x860, 0x86A}, {0x8A0, 0x8B4},
{0x8B6, 0x8C7}, {0x904, 0x939}, {0x958, 0x961}, {0x971, 0x980},
{0x985, 0x98C}, {0x993, 0x9A8}, {0x9AA, 0x9B0}, {0x9B6, 0x9B9},
{0x9DF, 0x9E1}, {0xA05, 0xA0A}, {0xA13, 0xA28}, {0xA2A, 0xA30},
{0xA59, 0xA5C}, {0xA72, 0xA74}, {0xA85, 0xA8D}, {0xA8F, 0xA91},
{0xA93, 0xAA8}, {0xAAA, 0xAB0}, {0xAB5, 0xAB9}, {0xB05, 0xB0C},
{0xB13, 0xB28}, {0xB2A, 0xB30}, {0xB35, 0xB39}, {0xB5F, 0xB61},
{0xB85, 0xB8A}, {0xB8E, 0xB90}, {0xB92, 0xB95}, {0xBA8, 0xBAA},
{0xBAE, 0xBB9}, {0xC05, 0xC0C}, {0xC0E, 0xC10}, {0xC12, 0xC28},
{0xC2A, 0xC39}, {0xC58, 0xC5A}, {0xC85, 0xC8C}, {0xC8E, 0xC90},
{0xC92, 0xCA8}, {0xCAA, 0xCB3}, {0xCB5, 0xCB9}, {0xD04, 0xD0C},
{0xD0E, 0xD10}, {0xD12, 0xD3A}, {0xD54, 0xD56}, {0xD5F, 0xD61},
{0xD7A, 0xD7F}, {0xD85, 0xD96}, {0xD9A, 0xDB1}, {0xDB3, 0xDBB},
{0xDC0, 0xDC6}, {0xE01, 0xE30}, {0xE40, 0xE46}, {0xE86, 0xE8A},
{0xE8C, 0xEA3}, {0xEA7, 0xEB0}, {0xEC0, 0xEC4}, {0xEDC, 0xEDF},
{0xF40, 0xF47}, {0xF49, 0xF6C}, {0xF88, 0xF8C}, {0x1000, 0x102A},
{0x1050, 0x1055}, {0x105A, 0x105D}, {0x106E, 0x1070}, {0x1075, 0x1081},
{0x10A0, 0x10C5}, {0x10D0, 0x10FA}, {0x10FC, 0x1248}, {0x124A, 0x124D},
{0x1250, 0x1256}, {0x125A, 0x125D}, {0x1260, 0x1288}, {0x128A, 0x128D},
{0x1290, 0x12B0}, {0x12B2, 0x12B5}, {0x12B8, 0x12BE}, {0x12C2, 0x12C5},
{0x12C8, 0x12D6}, {0x12D8, 0x1310}, {0x1312, 0x1315}, {0x1318, 0x135A},
{0x1380, 0x138F}, {0x13A0, 0x13F5}, {0x13F8, 0x13FD}, {0x1401, 0x166C},
{0x166F, 0x167F}, {0x1681, 0x169A}, {0x16A0, 0x16EA}, {0x16F1, 0x16F8},
{0x1700, 0x170C}, {0x170E, 0x1711}, {0x1720, 0x1731}, {0x1740, 0x1751},
{0x1760, 0x176C}, {0x176E, 0x1770}, {0x1780, 0x17B3}, {0x1820, 0x1878},
{0x1880, 0x1884}, {0x1887, 0x18A8}, {0x18B0, 0x18F5}, {0x1900, 0x191E},
{0x1950, 0x196D}, {0x1970, 0x1974}, {0x1980, 0x19AB}, {0x19B0, 0x19C9},
{0x1A00, 0x1A16}, {0x1A20, 0x1A54}, {0x1B05, 0x1B33}, {0x1B45, 0x1B4B},
{0x1B83, 0x1BA0}, {0x1BBA, 0x1BE5}, {0x1C00, 0x1C23}, {0x1C4D, 0x1C4F},
{0x1C5A, 0x1C7D}, {0x1C80, 0x1C88}, {0x1C90, 0x1CBA}, {0x1CBD, 0x1CBF},
{0x1CE9, 0x1CEC}, {0x1CEE, 0x1CF3}, {0x1D00, 0x1DBF}, {0x1E00, 0x1F15},
{0x1F18, 0x1F1D}, {0x1F20, 0x1F45}, {0x1F48, 0x1F4D}, {0x1F50, 0x1F57},
{0x1F5F, 0x1F7D}, {0x1F80, 0x1FB4}, {0x1FB6, 0x1FBC}, {0x1FC2, 0x1FC4},
{0x1FC6, 0x1FCC}, {0x1FD0, 0x1FD3}, {0x1FD6, 0x1FDB}, {0x1FE0, 0x1FEC},
{0x1FF2, 0x1FF4}, {0x1FF6, 0x1FFC}, {0x2090, 0x209C}, {0x210A, 0x2113},
{0x2119, 0x211D}, {0x212A, 0x212D}, {0x212F, 0x2139}, {0x213C, 0x213F},
{0x2145, 0x2149}, {0x2C00, 0x2C2E}, {0x2C30, 0x2C5E}, {0x2C60, 0x2CE4},
{0x2CEB, 0x2CEE}, {0x2D00, 0x2D25}, {0x2D30, 0x2D67}, {0x2D80, 0x2D96},
{0x2DA0, 0x2DA6}, {0x2DA8, 0x2DAE}, {0x2DB0, 0x2DB6}, {0x2DB8, 0x2DBE},
{0x2DC0, 0x2DC6}, {0x2DC8, 0x2DCE}, {0x2DD0, 0x2DD6}, {0x2DD8, 0x2DDE},
{0x3031, 0x3035}, {0x3041, 0x3096}, {0x309D, 0x309F}, {0x30A1, 0x30FA},
{0x30FC, 0x30FF}, {0x3105, 0x312F}, {0x3131, 0x318E}, {0x31A0, 0x31BF},
{0x31F0, 0x31FF}, {0x3400, 0x4DBF}, {0x4E00, 0x9FFC}, {0xA000, 0xA48C},
{0xA4D0, 0xA4FD}, {0xA500, 0xA60C}, {0xA610, 0xA61F}, {0xA640, 0xA66E},
{0xA67F, 0xA69D}, {0xA6A0, 0xA6E5}, {0xA717, 0xA71F}, {0xA722, 0xA788},
{0xA78B, 0xA7BF}, {0xA7C2, 0xA7CA}, {0xA7F5, 0xA801}, {0xA803, 0xA805},
{0xA807, 0xA80A}, {0xA80C, 0xA822}, {0xA840, 0xA873}, {0xA882, 0xA8B3},
{0xA8F2, 0xA8F7}, {0xA90A, 0xA925}, {0xA930, 0xA946}, {0xA960, 0xA97C},
{0xA984, 0xA9B2}, {0xA9E0, 0xA9E4}, {0xA9E6, 0xA9EF}, {0xA9FA, 0xA9FE},
{0xAA00, 0xAA28}, {0xAA40, 0xAA42}, {0xAA44, 0xAA4B}, {0xAA60, 0xAA76},
{0xAA7E, 0xAAAF}, {0xAAB9, 0xAABD}, {0xAADB, 0xAADD}, {0xAAE0, 0xAAEA},
{0xAAF2, 0xAAF4}, {0xAB01, 0xAB06}, {0xAB09, 0xAB0E}, {0xAB11, 0xAB16},
{0xAB20, 0xAB26}, {0xAB28, 0xAB2E}, {0xAB30, 0xAB5A}, {0xAB5C, 0xAB69},
{0xAB70, 0xABE2}, {0xAC00, 0xD7A3}, {0xD7B0, 0xD7C6}, {0xD7CB, 0xD7FB},
{0xF900, 0xFA6D}, {0xFA70, 0xFAD9}, {0xFB00, 0xFB06}, {0xFB13, 0xFB17},
{0xFB1F, 0xFB28}, {0xFB2A, 0xFB36}, {0xFB38, 0xFB3C}, {0xFB46, 0xFBB1},
{0xFBD3, 0xFD3D}, {0xFD50, 0xFD8F}, {0xFD92, 0xFDC7}, {0xFDF0, 0xFDFB},
{0xFE70, 0xFE74}, {0xFE76, 0xFEFC}, {0xFF21, 0xFF3A}, {0xFF41, 0xFF5A},
{0xFF66, 0xFFBE}, {0xFFC2, 0xFFC7}, {0xFFCA, 0xFFCF}, {0xFFD2, 0xFFD7},
{0xFFDA, 0xFFDC}
#if CHRBITS > 16
,{0x10000, 0x1000B}, {0x1000D, 0x10026}, {0x10028, 0x1003A}, {0x1003F, 0x1004D},
{0x10050, 0x1005D}, {0x10080, 0x100FA}, {0x10280, 0x1029C}, {0x102A0, 0x102D0},
{0x10300, 0x1031F}, {0x1032D, 0x10340}, {0x10342, 0x10349}, {0x10350, 0x10375},
{0x10380, 0x1039D}, {0x103A0, 0x103C3}, {0x103C8, 0x103CF}, {0x10400, 0x1049D},
{0x104B0, 0x104D3}, {0x104D8, 0x104FB}, {0x10500, 0x10527}, {0x10530, 0x10563},
{0x10600, 0x10736}, {0x10740, 0x10755}, {0x10760, 0x10767}, {0x10800, 0x10805},
{0x1080A, 0x10835}, {0x1083F, 0x10855}, {0x10860, 0x10876}, {0x10880, 0x1089E},
{0x108E0, 0x108F2}, {0x10900, 0x10915}, {0x10920, 0x10939}, {0x10980, 0x109B7},
{0x10A10, 0x10A13}, {0x10A15, 0x10A17}, {0x10A19, 0x10A35}, {0x10A60, 0x10A7C},
{0x10A80, 0x10A9C}, {0x10AC0, 0x10AC7}, {0x10AC9, 0x10AE4}, {0x10B00, 0x10B35},
{0x10B40, 0x10B55}, {0x10B60, 0x10B72}, {0x10B80, 0x10B91}, {0x10C00, 0x10C48},
{0x10C80, 0x10CB2}, {0x10CC0, 0x10CF2}, {0x10D00, 0x10D23}, {0x10E80, 0x10EA9},
{0x10F00, 0x10F1C}, {0x10F30, 0x10F45}, {0x10FB0, 0x10FC4}, {0x10FE0, 0x10FF6},
{0x11003, 0x11037}, {0x11083, 0x110AF}, {0x110D0, 0x110E8}, {0x11103, 0x11126},
{0x11150, 0x11172}, {0x11183, 0x111B2}, {0x111C1, 0x111C4}, {0x11200, 0x11211},
{0x11213, 0x1122B}, {0x11280, 0x11286}, {0x1128A, 0x1128D}, {0x1128F, 0x1129D},
{0x1129F, 0x112A8}, {0x112B0, 0x112DE}, {0x11305, 0x1130C}, {0x11313, 0x11328},
{0x1132A, 0x11330}, {0x11335, 0x11339}, {0x1135D, 0x11361}, {0x11400, 0x11434},
{0x11447, 0x1144A}, {0x1145F, 0x11461}, {0x11480, 0x114AF}, {0x11580, 0x115AE},
{0x115D8, 0x115DB}, {0x11600, 0x1162F}, {0x11680, 0x116AA}, {0x11700, 0x1171A},
{0x11800, 0x1182B}, {0x118A0, 0x118DF}, {0x118FF, 0x11906}, {0x1190C, 0x11913},
{0x11918, 0x1192F}, {0x119A0, 0x119A7}, {0x119AA, 0x119D0}, {0x11A0B, 0x11A32},
{0x11A5C, 0x11A89}, {0x11AC0, 0x11AF8}, {0x11C00, 0x11C08}, {0x11C0A, 0x11C2E},
{0x11C72, 0x11C8F}, {0x11D00, 0x11D06}, {0x11D0B, 0x11D30}, {0x11D60, 0x11D65},
{0x11D6A, 0x11D89}, {0x11EE0, 0x11EF2}, {0x12000, 0x12399}, {0x12480, 0x12543},
{0x13000, 0x1342E}, {0x14400, 0x14646}, {0x16800, 0x16A38}, {0x16A40, 0x16A5E},
{0x16AD0, 0x16AED}, {0x16B00, 0x16B2F}, {0x16B40, 0x16B43}, {0x16B63, 0x16B77},
{0x16B7D, 0x16B8F}, {0x16E40, 0x16E7F}, {0x16F00, 0x16F4A}, {0x16F93, 0x16F9F},
{0x17000, 0x187F7}, {0x18800, 0x18CD5}, {0x18D00, 0x18D08}, {0x1B000, 0x1B11E},
{0x1B150, 0x1B152}, {0x1B164, 0x1B167}, {0x1B170, 0x1B2FB}, {0x1BC00, 0x1BC6A},
{0x1BC70, 0x1BC7C}, {0x1BC80, 0x1BC88}, {0x1BC90, 0x1BC99}, {0x1D400, 0x1D454},
{0x1D456, 0x1D49C}, {0x1D4A9, 0x1D4AC}, {0x1D4AE, 0x1D4B9}, {0x1D4BD, 0x1D4C3},
{0x1D4C5, 0x1D505}, {0x1D507, 0x1D50A}, {0x1D50D, 0x1D514}, {0x1D516, 0x1D51C},
{0x1D51E, 0x1D539}, {0x1D53B, 0x1D53E}, {0x1D540, 0x1D544}, {0x1D54A, 0x1D550},
{0x1D552, 0x1D6A5}, {0x1D6A8, 0x1D6C0}, {0x1D6C2, 0x1D6DA}, {0x1D6DC, 0x1D6FA},
{0x1D6FC, 0x1D714}, {0x1D716, 0x1D734}, {0x1D736, 0x1D74E}, {0x1D750, 0x1D76E},
{0x1D770, 0x1D788}, {0x1D78A, 0x1D7A8}, {0x1D7AA, 0x1D7C2}, {0x1D7C4, 0x1D7CB},
{0x1E100, 0x1E12C}, {0x1E137, 0x1E13D}, {0x1E2C0, 0x1E2EB}, {0x1E800, 0x1E8C4},
{0x1E900, 0x1E943}, {0x1EE00, 0x1EE03}, {0x1EE05, 0x1EE1F}, {0x1EE29, 0x1EE32},
{0x1EE34, 0x1EE37}, {0x1EE4D, 0x1EE4F}, {0x1EE67, 0x1EE6A}, {0x1EE6C, 0x1EE72},
{0x1EE74, 0x1EE77}, {0x1EE79, 0x1EE7C}, {0x1EE80, 0x1EE89}, {0x1EE8B, 0x1EE9B},
{0x1EEA1, 0x1EEA3}, {0x1EEA5, 0x1EEA9}, {0x1EEAB, 0x1EEBB}, {0x20000, 0x2A6DD},
{0x2A700, 0x2B734}, {0x2B740, 0x2B81D}, {0x2B820, 0x2CEA1}, {0x2CEB0, 0x2EBE0},
{0x2F800, 0x2FA1D}, {0x30000, 0x3134A}
#endif
};
#define NUM_ALPHA_RANGE (sizeof(alphaRangeTable)/sizeof(crange))
static const chr alphaCharTable[] = {
0xAA, 0xB5, 0xBA, 0x2EC, 0x2EE, 0x376, 0x377, 0x37F, 0x386,
0x38C, 0x559, 0x66E, 0x66F, 0x6D5, 0x6E5, 0x6E6, 0x6EE, 0x6EF,
0x6FF, 0x710, 0x7B1, 0x7F4, 0x7F5, 0x7FA, 0x81A, 0x824, 0x828,
0x93D, 0x950, 0x98F, 0x990, 0x9B2, 0x9BD, 0x9CE, 0x9DC, 0x9DD,
0x9F0, 0x9F1, 0x9FC, 0xA0F, 0xA10, 0xA32, 0xA33, 0xA35, 0xA36,
0xA38, 0xA39, 0xA5E, 0xAB2, 0xAB3, 0xABD, 0xAD0, 0xAE0, 0xAE1,
0xAF9, 0xB0F, 0xB10, 0xB32, 0xB33, 0xB3D, 0xB5C, 0xB5D, 0xB71,
0xB83, 0xB99, 0xB9A, 0xB9C, 0xB9E, 0xB9F, 0xBA3, 0xBA4, 0xBD0,
0xC3D, 0xC60, 0xC61, 0xC80, 0xCBD, 0xCDE, 0xCE0, 0xCE1, 0xCF1,
0xCF2, 0xD3D, 0xD4E, 0xDBD, 0xE32, 0xE33, 0xE81, 0xE82, 0xE84,
0xEA5, 0xEB2, 0xEB3, 0xEBD, 0xEC6, 0xF00, 0x103F, 0x1061, 0x1065,
0x1066, 0x108E, 0x10C7, 0x10CD, 0x1258, 0x12C0, 0x17D7, 0x17DC, 0x18AA,
0x1AA7, 0x1BAE, 0x1BAF, 0x1CF5, 0x1CF6, 0x1CFA, 0x1F59, 0x1F5B, 0x1F5D,
0x1FBE, 0x2071, 0x207F, 0x2102, 0x2107, 0x2115, 0x2124, 0x2126, 0x2128,
0x214E, 0x2183, 0x2184, 0x2CF2, 0x2CF3, 0x2D27, 0x2D2D, 0x2D6F, 0x2E2F,
0x3005, 0x3006, 0x303B, 0x303C, 0xA62A, 0xA62B, 0xA8FB, 0xA8FD, 0xA8FE,
0xA9CF, 0xAA7A, 0xAAB1, 0xAAB5, 0xAAB6, 0xAAC0, 0xAAC2, 0xFB1D, 0xFB3E,
0xFB40, 0xFB41, 0xFB43, 0xFB44
#if CHRBITS > 16
,0x1003C, 0x1003D, 0x10808, 0x10837, 0x10838, 0x1083C, 0x108F4, 0x108F5, 0x109BE,
0x109BF, 0x10A00, 0x10EB0, 0x10EB1, 0x10F27, 0x11144, 0x11147, 0x11176, 0x111DA,
0x111DC, 0x11288, 0x1130F, 0x11310, 0x11332, 0x11333, 0x1133D, 0x11350, 0x114C4,
0x114C5, 0x114C7, 0x11644, 0x116B8, 0x11909, 0x11915, 0x11916, 0x1193F, 0x11941,
0x119E1, 0x119E3, 0x11A00, 0x11A3A, 0x11A50, 0x11A9D, 0x11C40, 0x11D08, 0x11D09,
0x11D46, 0x11D67, 0x11D68, 0x11D98, 0x11FB0, 0x16F50, 0x16FE0, 0x16FE1, 0x16FE3,
0x1D49E, 0x1D49F, 0x1D4A2, 0x1D4A5, 0x1D4A6, 0x1D4BB, 0x1D546, 0x1E14E, 0x1E94B,
0x1EE21, 0x1EE22, 0x1EE24, 0x1EE27, 0x1EE39, 0x1EE3B, 0x1EE42, 0x1EE47, 0x1EE49,
0x1EE4B, 0x1EE51, 0x1EE52, 0x1EE54, 0x1EE57, 0x1EE59, 0x1EE5B, 0x1EE5D, 0x1EE5F,
0x1EE61, 0x1EE62, 0x1EE64, 0x1EE7E
#endif
};
#define NUM_ALPHA_CHAR (sizeof(alphaCharTable)/sizeof(chr))
/*
* Unicode: control characters.
*/
static const crange controlRangeTable[] = {
{0x0, 0x1F}, {0x7F, 0x9F}, {0x600, 0x605}, {0x200B, 0x200F},
{0x202A, 0x202E}, {0x2060, 0x2064}, {0x2066, 0x206F}, {0xE000, 0xF8FF},
{0xFFF9, 0xFFFB}
#if CHRBITS > 16
,{0x13430, 0x13438}, {0x1BCA0, 0x1BCA3}, {0x1D173, 0x1D17A}, {0xE0020, 0xE007F},
{0xF0000, 0xFFFFD}, {0x100000, 0x10FFFD}
#endif
};
#define NUM_CONTROL_RANGE (sizeof(controlRangeTable)/sizeof(crange))
static const chr controlCharTable[] = {
0xAD, 0x61C, 0x6DD, 0x70F, 0x8E2, 0x180E, 0xFEFF
#if CHRBITS > 16
,0x110BD, 0x110CD, 0xE0001
#endif
};
#define NUM_CONTROL_CHAR (sizeof(controlCharTable)/sizeof(chr))
/*
* Unicode: decimal digit characters.
*/
static const crange digitRangeTable[] = {
{0x30, 0x39}, {0x660, 0x669}, {0x6F0, 0x6F9}, {0x7C0, 0x7C9},
{0x966, 0x96F}, {0x9E6, 0x9EF}, {0xA66, 0xA6F}, {0xAE6, 0xAEF},
{0xB66, 0xB6F}, {0xBE6, 0xBEF}, {0xC66, 0xC6F}, {0xCE6, 0xCEF},
{0xD66, 0xD6F}, {0xDE6, 0xDEF}, {0xE50, 0xE59}, {0xED0, 0xED9},
{0xF20, 0xF29}, {0x1040, 0x1049}, {0x1090, 0x1099}, {0x17E0, 0x17E9},
{0x1810, 0x1819}, {0x1946, 0x194F}, {0x19D0, 0x19D9}, {0x1A80, 0x1A89},
{0x1A90, 0x1A99}, {0x1B50, 0x1B59}, {0x1BB0, 0x1BB9}, {0x1C40, 0x1C49},
{0x1C50, 0x1C59}, {0xA620, 0xA629}, {0xA8D0, 0xA8D9}, {0xA900, 0xA909},
{0xA9D0, 0xA9D9}, {0xA9F0, 0xA9F9}, {0xAA50, 0xAA59}, {0xABF0, 0xABF9},
{0xFF10, 0xFF19}
#if CHRBITS > 16
,{0x104A0, 0x104A9}, {0x10D30, 0x10D39}, {0x11066, 0x1106F}, {0x110F0, 0x110F9},
{0x11136, 0x1113F}, {0x111D0, 0x111D9}, {0x112F0, 0x112F9}, {0x11450, 0x11459},
{0x114D0, 0x114D9}, {0x11650, 0x11659}, {0x116C0, 0x116C9}, {0x11730, 0x11739},
{0x118E0, 0x118E9}, {0x11950, 0x11959}, {0x11C50, 0x11C59}, {0x11D50, 0x11D59},
{0x11DA0, 0x11DA9}, {0x16A60, 0x16A69}, {0x16B50, 0x16B59}, {0x1D7CE, 0x1D7FF},
{0x1E140, 0x1E149}, {0x1E2F0, 0x1E2F9}, {0x1E950, 0x1E959}, {0x1FBF0, 0x1FBF9}
#endif
};
#define NUM_DIGIT_RANGE (sizeof(digitRangeTable)/sizeof(crange))
/*
* no singletons of digit characters.
*/
/*
* Unicode: punctuation characters.
*/
static const crange punctRangeTable[] = {
{0x21, 0x23}, {0x25, 0x2A}, {0x2C, 0x2F}, {0x5B, 0x5D},
{0x55A, 0x55F}, {0x66A, 0x66D}, {0x700, 0x70D}, {0x7F7, 0x7F9},
{0x830, 0x83E}, {0xF04, 0xF12}, {0xF3A, 0xF3D}, {0xFD0, 0xFD4},
{0x104A, 0x104F}, {0x1360, 0x1368}, {0x16EB, 0x16ED}, {0x17D4, 0x17D6},
{0x17D8, 0x17DA}, {0x1800, 0x180A}, {0x1AA0, 0x1AA6}, {0x1AA8, 0x1AAD},
{0x1B5A, 0x1B60}, {0x1BFC, 0x1BFF}, {0x1C3B, 0x1C3F}, {0x1CC0, 0x1CC7},
{0x2010, 0x2027}, {0x2030, 0x2043}, {0x2045, 0x2051}, {0x2053, 0x205E},
{0x2308, 0x230B}, {0x2768, 0x2775}, {0x27E6, 0x27EF}, {0x2983, 0x2998},
{0x29D8, 0x29DB}, {0x2CF9, 0x2CFC}, {0x2E00, 0x2E2E}, {0x2E30, 0x2E4F},
{0x3001, 0x3003}, {0x3008, 0x3011}, {0x3014, 0x301F}, {0xA60D, 0xA60F},
{0xA6F2, 0xA6F7}, {0xA874, 0xA877}, {0xA8F8, 0xA8FA}, {0xA9C1, 0xA9CD},
{0xAA5C, 0xAA5F}, {0xFE10, 0xFE19}, {0xFE30, 0xFE52}, {0xFE54, 0xFE61},
{0xFF01, 0xFF03}, {0xFF05, 0xFF0A}, {0xFF0C, 0xFF0F}, {0xFF3B, 0xFF3D},
{0xFF5F, 0xFF65}
#if CHRBITS > 16
,{0x10100, 0x10102}, {0x10A50, 0x10A58}, {0x10AF0, 0x10AF6}, {0x10B39, 0x10B3F},
{0x10B99, 0x10B9C}, {0x10F55, 0x10F59}, {0x11047, 0x1104D}, {0x110BE, 0x110C1},
{0x11140, 0x11143}, {0x111C5, 0x111C8}, {0x111DD, 0x111DF}, {0x11238, 0x1123D},
{0x1144B, 0x1144F}, {0x115C1, 0x115D7}, {0x11641, 0x11643}, {0x11660, 0x1166C},
{0x1173C, 0x1173E}, {0x11944, 0x11946}, {0x11A3F, 0x11A46}, {0x11A9A, 0x11A9C},
{0x11A9E, 0x11AA2}, {0x11C41, 0x11C45}, {0x12470, 0x12474}, {0x16B37, 0x16B3B},
{0x16E97, 0x16E9A}, {0x1DA87, 0x1DA8B}
#endif
};
#define NUM_PUNCT_RANGE (sizeof(punctRangeTable)/sizeof(crange))
static const chr punctCharTable[] = {
0x3A, 0x3B, 0x3F, 0x40, 0x5F, 0x7B, 0x7D, 0xA1, 0xA7,
0xAB, 0xB6, 0xB7, 0xBB, 0xBF, 0x37E, 0x387, 0x589, 0x58A,
0x5BE, 0x5C0, 0x5C3, 0x5C6, 0x5F3, 0x5F4, 0x609, 0x60A, 0x60C,
0x60D, 0x61B, 0x61E, 0x61F, 0x6D4, 0x85E, 0x964, 0x965, 0x970,
0x9FD, 0xA76, 0xAF0, 0xC77, 0xC84, 0xDF4, 0xE4F, 0xE5A, 0xE5B,
0xF14, 0xF85, 0xFD9, 0xFDA, 0x10FB, 0x1400, 0x166E, 0x169B, 0x169C,
0x1735, 0x1736, 0x1944, 0x1945, 0x1A1E, 0x1A1F, 0x1C7E, 0x1C7F, 0x1CD3,
0x207D, 0x207E, 0x208D, 0x208E, 0x2329, 0x232A, 0x27C5, 0x27C6, 0x29FC,
0x29FD, 0x2CFE, 0x2CFF, 0x2D70, 0x2E52, 0x3030, 0x303D, 0x30A0, 0x30FB,
0xA4FE, 0xA4FF, 0xA673, 0xA67E, 0xA8CE, 0xA8CF, 0xA8FC, 0xA92E, 0xA92F,
0xA95F, 0xA9DE, 0xA9DF, 0xAADE, 0xAADF, 0xAAF0, 0xAAF1, 0xABEB, 0xFD3E,
0xFD3F, 0xFE63, 0xFE68, 0xFE6A, 0xFE6B, 0xFF1A, 0xFF1B, 0xFF1F, 0xFF20,
0xFF3F, 0xFF5B, 0xFF5D
#if CHRBITS > 16
,0x1039F, 0x103D0, 0x1056F, 0x10857, 0x1091F, 0x1093F, 0x10A7F, 0x10EAD, 0x110BB,
0x110BC, 0x11174, 0x11175, 0x111CD, 0x111DB, 0x112A9, 0x1145A, 0x1145B, 0x1145D,
0x114C6, 0x1183B, 0x119E2, 0x11C70, 0x11C71, 0x11EF7, 0x11EF8, 0x11FFF, 0x16A6E,
0x16A6F, 0x16AF5, 0x16B44, 0x16FE2, 0x1BC9F, 0x1E95E, 0x1E95F
#endif
};
#define NUM_PUNCT_CHAR (sizeof(punctCharTable)/sizeof(chr))
/*
* Unicode: white space characters.
*/
static const crange spaceRangeTable[] = {
{0x9, 0xD}, {0x2000, 0x200B}
};
#define NUM_SPACE_RANGE (sizeof(spaceRangeTable)/sizeof(crange))
static const chr spaceCharTable[] = {
0x20, 0x85, 0xA0, 0x1680, 0x180E, 0x2028, 0x2029, 0x202F, 0x205F,
0x2060, 0x3000, 0xFEFF
};
#define NUM_SPACE_CHAR (sizeof(spaceCharTable)/sizeof(chr))
/*
* Unicode: lowercase characters.
*/
static const crange lowerRangeTable[] = {
{0x61, 0x7A}, {0xDF, 0xF6}, {0xF8, 0xFF}, {0x17E, 0x180},
{0x199, 0x19B}, {0x1BD, 0x1BF}, {0x233, 0x239}, {0x24F, 0x293},
{0x295, 0x2AF}, {0x37B, 0x37D}, {0x3AC, 0x3CE}, {0x3D5, 0x3D7},
{0x3EF, 0x3F3}, {0x430, 0x45F}, {0x560, 0x588}, {0x10D0, 0x10FA},
{0x10FD, 0x10FF}, {0x13F8, 0x13FD}, {0x1C80, 0x1C88}, {0x1D00, 0x1D2B},
{0x1D6B, 0x1D77}, {0x1D79, 0x1D9A}, {0x1E95, 0x1E9D}, {0x1EFF, 0x1F07},
{0x1F10, 0x1F15}, {0x1F20, 0x1F27}, {0x1F30, 0x1F37}, {0x1F40, 0x1F45},
{0x1F50, 0x1F57}, {0x1F60, 0x1F67}, {0x1F70, 0x1F7D}, {0x1F80, 0x1F87},
{0x1F90, 0x1F97}, {0x1FA0, 0x1FA7}, {0x1FB0, 0x1FB4}, {0x1FC2, 0x1FC4},
{0x1FD0, 0x1FD3}, {0x1FE0, 0x1FE7}, {0x1FF2, 0x1FF4}, {0x2146, 0x2149},
{0x2C30, 0x2C5E}, {0x2C76, 0x2C7B}, {0x2D00, 0x2D25}, {0xA72F, 0xA731},
{0xA771, 0xA778}, {0xA793, 0xA795}, {0xAB30, 0xAB5A}, {0xAB60, 0xAB68},
{0xAB70, 0xABBF}, {0xFB00, 0xFB06}, {0xFB13, 0xFB17}, {0xFF41, 0xFF5A}
#if CHRBITS > 16
,{0x10428, 0x1044F}, {0x104D8, 0x104FB}, {0x10CC0, 0x10CF2}, {0x118C0, 0x118DF},
{0x16E60, 0x16E7F}, {0x1D41A, 0x1D433}, {0x1D44E, 0x1D454}, {0x1D456, 0x1D467},
{0x1D482, 0x1D49B}, {0x1D4B6, 0x1D4B9}, {0x1D4BD, 0x1D4C3}, {0x1D4C5, 0x1D4CF},
{0x1D4EA, 0x1D503}, {0x1D51E, 0x1D537}, {0x1D552, 0x1D56B}, {0x1D586, 0x1D59F},
{0x1D5BA, 0x1D5D3}, {0x1D5EE, 0x1D607}, {0x1D622, 0x1D63B}, {0x1D656, 0x1D66F},
{0x1D68A, 0x1D6A5}, {0x1D6C2, 0x1D6DA}, {0x1D6DC, 0x1D6E1}, {0x1D6FC, 0x1D714},
{0x1D716, 0x1D71B}, {0x1D736, 0x1D74E}, {0x1D750, 0x1D755}, {0x1D770, 0x1D788},
{0x1D78A, 0x1D78F}, {0x1D7AA, 0x1D7C2}, {0x1D7C4, 0x1D7C9}, {0x1E922, 0x1E943}
#endif
};
#define NUM_LOWER_RANGE (sizeof(lowerRangeTable)/sizeof(crange))
static const chr lowerCharTable[] = {
0xB5, 0x101, 0x103, 0x105, 0x107, 0x109, 0x10B, 0x10D, 0x10F,
0x111, 0x113, 0x115, 0x117, 0x119, 0x11B, 0x11D, 0x11F, 0x121,
0x123, 0x125, 0x127, 0x129, 0x12B, 0x12D, 0x12F, 0x131, 0x133,
0x135, 0x137, 0x138, 0x13A, 0x13C, 0x13E, 0x140, 0x142, 0x144,
0x146, 0x148, 0x149, 0x14B, 0x14D, 0x14F, 0x151, 0x153, 0x155,
0x157, 0x159, 0x15B, 0x15D, 0x15F, 0x161, 0x163, 0x165, 0x167,
0x169, 0x16B, 0x16D, 0x16F, 0x171, 0x173, 0x175, 0x177, 0x17A,
0x17C, 0x183, 0x185, 0x188, 0x18C, 0x18D, 0x192, 0x195, 0x19E,
0x1A1, 0x1A3, 0x1A5, 0x1A8, 0x1AA, 0x1AB, 0x1AD, 0x1B0, 0x1B4,
0x1B6, 0x1B9, 0x1BA, 0x1C6, 0x1C9, 0x1CC, 0x1CE, 0x1D0, 0x1D2,
0x1D4, 0x1D6, 0x1D8, 0x1DA, 0x1DC, 0x1DD, 0x1DF, 0x1E1, 0x1E3,
0x1E5, 0x1E7, 0x1E9, 0x1EB, 0x1ED, 0x1EF, 0x1F0, 0x1F3, 0x1F5,
0x1F9, 0x1FB, 0x1FD, 0x1FF, 0x201, 0x203, 0x205, 0x207, 0x209,
0x20B, 0x20D, 0x20F, 0x211, 0x213, 0x215, 0x217, 0x219, 0x21B,
0x21D, 0x21F, 0x221, 0x223, 0x225, 0x227, 0x229, 0x22B, 0x22D,
0x22F, 0x231, 0x23C, 0x23F, 0x240, 0x242, 0x247, 0x249, 0x24B,
0x24D, 0x371, 0x373, 0x377, 0x390, 0x3D0, 0x3D1, 0x3D9, 0x3DB,
0x3DD, 0x3DF, 0x3E1, 0x3E3, 0x3E5, 0x3E7, 0x3E9, 0x3EB, 0x3ED,
0x3F5, 0x3F8, 0x3FB, 0x3FC, 0x461, 0x463, 0x465, 0x467, 0x469,
0x46B, 0x46D, 0x46F, 0x471, 0x473, 0x475, 0x477, 0x479, 0x47B,
0x47D, 0x47F, 0x481, 0x48B, 0x48D, 0x48F, 0x491, 0x493, 0x495,
0x497, 0x499, 0x49B, 0x49D, 0x49F, 0x4A1, 0x4A3, 0x4A5, 0x4A7,
0x4A9, 0x4AB, 0x4AD, 0x4AF, 0x4B1, 0x4B3, 0x4B5, 0x4B7, 0x4B9,
0x4BB, 0x4BD, 0x4BF, 0x4C2, 0x4C4, 0x4C6, 0x4C8, 0x4CA, 0x4CC,
0x4CE, 0x4CF, 0x4D1, 0x4D3, 0x4D5, 0x4D7, 0x4D9, 0x4DB, 0x4DD,
0x4DF, 0x4E1, 0x4E3, 0x4E5, 0x4E7, 0x4E9, 0x4EB, 0x4ED, 0x4EF,
0x4F1, 0x4F3, 0x4F5, 0x4F7, 0x4F9, 0x4FB, 0x4FD, 0x4FF, 0x501,
0x503, 0x505, 0x507, 0x509, 0x50B, 0x50D, 0x50F, 0x511, 0x513,
0x515, 0x517, 0x519, 0x51B, 0x51D, 0x51F, 0x521, 0x523, 0x525,
0x527, 0x529, 0x52B, 0x52D, 0x52F, 0x1E01, 0x1E03, 0x1E05, 0x1E07,
0x1E09, 0x1E0B, 0x1E0D, 0x1E0F, 0x1E11, 0x1E13, 0x1E15, 0x1E17, 0x1E19,
0x1E1B, 0x1E1D, 0x1E1F, 0x1E21, 0x1E23, 0x1E25, 0x1E27, 0x1E29, 0x1E2B,
0x1E2D, 0x1E2F, 0x1E31, 0x1E33, 0x1E35, 0x1E37, 0x1E39, 0x1E3B, 0x1E3D,
0x1E3F, 0x1E41, 0x1E43, 0x1E45, 0x1E47, 0x1E49, 0x1E4B, 0x1E4D, 0x1E4F,
0x1E51, 0x1E53, 0x1E55, 0x1E57, 0x1E59, 0x1E5B, 0x1E5D, 0x1E5F, 0x1E61,
0x1E63, 0x1E65, 0x1E67, 0x1E69, 0x1E6B, 0x1E6D, 0x1E6F, 0x1E71, 0x1E73,
0x1E75, 0x1E77, 0x1E79, 0x1E7B, 0x1E7D, 0x1E7F, 0x1E81, 0x1E83, 0x1E85,
0x1E87, 0x1E89, 0x1E8B, 0x1E8D, 0x1E8F, 0x1E91, 0x1E93, 0x1E9F, 0x1EA1,
0x1EA3, 0x1EA5, 0x1EA7, 0x1EA9, 0x1EAB, 0x1EAD, 0x1EAF, 0x1EB1, 0x1EB3,
0x1EB5, 0x1EB7, 0x1EB9, 0x1EBB, 0x1EBD, 0x1EBF, 0x1EC1, 0x1EC3, 0x1EC5,
0x1EC7, 0x1EC9, 0x1ECB, 0x1ECD, 0x1ECF, 0x1ED1, 0x1ED3, 0x1ED5, 0x1ED7,
0x1ED9, 0x1EDB, 0x1EDD, 0x1EDF, 0x1EE1, 0x1EE3, 0x1EE5, 0x1EE7, 0x1EE9,
0x1EEB, 0x1EED, 0x1EEF, 0x1EF1, 0x1EF3, 0x1EF5, 0x1EF7, 0x1EF9, 0x1EFB,
0x1EFD, 0x1FB6, 0x1FB7, 0x1FBE, 0x1FC6, 0x1FC7, 0x1FD6, 0x1FD7, 0x1FF6,
0x1FF7, 0x210A, 0x210E, 0x210F, 0x2113, 0x212F, 0x2134, 0x2139, 0x213C,
0x213D, 0x214E, 0x2184, 0x2C61, 0x2C65, 0x2C66, 0x2C68, 0x2C6A, 0x2C6C,
0x2C71, 0x2C73, 0x2C74, 0x2C81, 0x2C83, 0x2C85, 0x2C87, 0x2C89, 0x2C8B,
0x2C8D, 0x2C8F, 0x2C91, 0x2C93, 0x2C95, 0x2C97, 0x2C99, 0x2C9B, 0x2C9D,
0x2C9F, 0x2CA1, 0x2CA3, 0x2CA5, 0x2CA7, 0x2CA9, 0x2CAB, 0x2CAD, 0x2CAF,
0x2CB1, 0x2CB3, 0x2CB5, 0x2CB7, 0x2CB9, 0x2CBB, 0x2CBD, 0x2CBF, 0x2CC1,
0x2CC3, 0x2CC5, 0x2CC7, 0x2CC9, 0x2CCB, 0x2CCD, 0x2CCF, 0x2CD1, 0x2CD3,
0x2CD5, 0x2CD7, 0x2CD9, 0x2CDB, 0x2CDD, 0x2CDF, 0x2CE1, 0x2CE3, 0x2CE4,
0x2CEC, 0x2CEE, 0x2CF3, 0x2D27, 0x2D2D, 0xA641, 0xA643, 0xA645, 0xA647,
0xA649, 0xA64B, 0xA64D, 0xA64F, 0xA651, 0xA653, 0xA655, 0xA657, 0xA659,
0xA65B, 0xA65D, 0xA65F, 0xA661, 0xA663, 0xA665, 0xA667, 0xA669, 0xA66B,
0xA66D, 0xA681, 0xA683, 0xA685, 0xA687, 0xA689, 0xA68B, 0xA68D, 0xA68F,
0xA691, 0xA693, 0xA695, 0xA697, 0xA699, 0xA69B, 0xA723, 0xA725, 0xA727,
0xA729, 0xA72B, 0xA72D, 0xA733, 0xA735, 0xA737, 0xA739, 0xA73B, 0xA73D,
0xA73F, 0xA741, 0xA743, 0xA745, 0xA747, 0xA749, 0xA74B, 0xA74D, 0xA74F,
0xA751, 0xA753, 0xA755, 0xA757, 0xA759, 0xA75B, 0xA75D, 0xA75F, 0xA761,
0xA763, 0xA765, 0xA767, 0xA769, 0xA76B, 0xA76D, 0xA76F, 0xA77A, 0xA77C,
0xA77F, 0xA781, 0xA783, 0xA785, 0xA787, 0xA78C, 0xA78E, 0xA791, 0xA797,
0xA799, 0xA79B, 0xA79D, 0xA79F, 0xA7A1, 0xA7A3, 0xA7A5, 0xA7A7, 0xA7A9,
0xA7AF, 0xA7B5, 0xA7B7, 0xA7B9, 0xA7BB, 0xA7BD, 0xA7BF, 0xA7C3, 0xA7C8,
0xA7CA, 0xA7F6, 0xA7FA
#if CHRBITS > 16
,0x1D4BB, 0x1D7CB
#endif
};
#define NUM_LOWER_CHAR (sizeof(lowerCharTable)/sizeof(chr))
/*
* Unicode: uppercase characters.
*/
static const crange upperRangeTable[] = {
{0x41, 0x5A}, {0xC0, 0xD6}, {0xD8, 0xDE}, {0x189, 0x18B},
{0x18E, 0x191}, {0x196, 0x198}, {0x1B1, 0x1B3}, {0x1F6, 0x1F8},
{0x243, 0x246}, {0x388, 0x38A}, {0x391, 0x3A1}, {0x3A3, 0x3AB},
{0x3D2, 0x3D4}, {0x3FD, 0x42F}, {0x531, 0x556}, {0x10A0, 0x10C5},
{0x13A0, 0x13F5}, {0x1C90, 0x1CBA}, {0x1CBD, 0x1CBF}, {0x1F08, 0x1F0F},
{0x1F18, 0x1F1D}, {0x1F28, 0x1F2F}, {0x1F38, 0x1F3F}, {0x1F48, 0x1F4D},
{0x1F68, 0x1F6F}, {0x1FB8, 0x1FBB}, {0x1FC8, 0x1FCB}, {0x1FD8, 0x1FDB},
{0x1FE8, 0x1FEC}, {0x1FF8, 0x1FFB}, {0x210B, 0x210D}, {0x2110, 0x2112},
{0x2119, 0x211D}, {0x212A, 0x212D}, {0x2130, 0x2133}, {0x2C00, 0x2C2E},
{0x2C62, 0x2C64}, {0x2C6D, 0x2C70}, {0x2C7E, 0x2C80}, {0xA7AA, 0xA7AE},
{0xA7B0, 0xA7B4}, {0xA7C4, 0xA7C7}, {0xFF21, 0xFF3A}
#if CHRBITS > 16
,{0x10400, 0x10427}, {0x104B0, 0x104D3}, {0x10C80, 0x10CB2}, {0x118A0, 0x118BF},
{0x16E40, 0x16E5F}, {0x1D400, 0x1D419}, {0x1D434, 0x1D44D}, {0x1D468, 0x1D481},
{0x1D4A9, 0x1D4AC}, {0x1D4AE, 0x1D4B5}, {0x1D4D0, 0x1D4E9}, {0x1D507, 0x1D50A},
{0x1D50D, 0x1D514}, {0x1D516, 0x1D51C}, {0x1D53B, 0x1D53E}, {0x1D540, 0x1D544},
{0x1D54A, 0x1D550}, {0x1D56C, 0x1D585}, {0x1D5A0, 0x1D5B9}, {0x1D5D4, 0x1D5ED},
{0x1D608, 0x1D621}, {0x1D63C, 0x1D655}, {0x1D670, 0x1D689}, {0x1D6A8, 0x1D6C0},
{0x1D6E2, 0x1D6FA}, {0x1D71C, 0x1D734}, {0x1D756, 0x1D76E}, {0x1D790, 0x1D7A8},
{0x1E900, 0x1E921}
#endif
};
#define NUM_UPPER_RANGE (sizeof(upperRangeTable)/sizeof(crange))
static const chr upperCharTable[] = {
0x100, 0x102, 0x104, 0x106, 0x108, 0x10A, 0x10C, 0x10E, 0x110,
0x112, 0x114, 0x116, 0x118, 0x11A, 0x11C, 0x11E, 0x120, 0x122,
0x124, 0x126, 0x128, 0x12A, 0x12C, 0x12E, 0x130, 0x132, 0x134,
0x136, 0x139, 0x13B, 0x13D, 0x13F, 0x141, 0x143, 0x145, 0x147,
0x14A, 0x14C, 0x14E, 0x150, 0x152, 0x154, 0x156, 0x158, 0x15A,
0x15C, 0x15E, 0x160, 0x162, 0x164, 0x166, 0x168, 0x16A, 0x16C,
0x16E, 0x170, 0x172, 0x174, 0x176, 0x178, 0x179, 0x17B, 0x17D,
0x181, 0x182, 0x184, 0x186, 0x187, 0x193, 0x194, 0x19C, 0x19D,
0x19F, 0x1A0, 0x1A2, 0x1A4, 0x1A6, 0x1A7, 0x1A9, 0x1AC, 0x1AE,
0x1AF, 0x1B5, 0x1B7, 0x1B8, 0x1BC, 0x1C4, 0x1C7, 0x1CA, 0x1CD,
0x1CF, 0x1D1, 0x1D3, 0x1D5, 0x1D7, 0x1D9, 0x1DB, 0x1DE, 0x1E0,
0x1E2, 0x1E4, 0x1E6, 0x1E8, 0x1EA, 0x1EC, 0x1EE, 0x1F1, 0x1F4,
0x1FA, 0x1FC, 0x1FE, 0x200, 0x202, 0x204, 0x206, 0x208, 0x20A,
0x20C, 0x20E, 0x210, 0x212, 0x214, 0x216, 0x218, 0x21A, 0x21C,
0x21E, 0x220, 0x222, 0x224, 0x226, 0x228, 0x22A, 0x22C, 0x22E,
0x230, 0x232, 0x23A, 0x23B, 0x23D, 0x23E, 0x241, 0x248, 0x24A,
0x24C, 0x24E, 0x370, 0x372, 0x376, 0x37F, 0x386, 0x38C, 0x38E,
0x38F, 0x3CF, 0x3D8, 0x3DA, 0x3DC, 0x3DE, 0x3E0, 0x3E2, 0x3E4,
0x3E6, 0x3E8, 0x3EA, 0x3EC, 0x3EE, 0x3F4, 0x3F7, 0x3F9, 0x3FA,
0x460, 0x462, 0x464, 0x466, 0x468, 0x46A, 0x46C, 0x46E, 0x470,
0x472, 0x474, 0x476, 0x478, 0x47A, 0x47C, 0x47E, 0x480, 0x48A,
0x48C, 0x48E, 0x490, 0x492, 0x494, 0x496, 0x498, 0x49A, 0x49C,
0x49E, 0x4A0, 0x4A2, 0x4A4, 0x4A6, 0x4A8, 0x4AA, 0x4AC, 0x4AE,
0x4B0, 0x4B2, 0x4B4, 0x4B6, 0x4B8, 0x4BA, 0x4BC, 0x4BE, 0x4C0,
0x4C1, 0x4C3, 0x4C5, 0x4C7, 0x4C9, 0x4CB, 0x4CD, 0x4D0, 0x4D2,
0x4D4, 0x4D6, 0x4D8, 0x4DA, 0x4DC, 0x4DE, 0x4E0, 0x4E2, 0x4E4,
0x4E6, 0x4E8, 0x4EA, 0x4EC, 0x4EE, 0x4F0, 0x4F2, 0x4F4, 0x4F6,
0x4F8, 0x4FA, 0x4FC, 0x4FE, 0x500, 0x502, 0x504, 0x506, 0x508,
0x50A, 0x50C, 0x50E, 0x510, 0x512, 0x514, 0x516, 0x518, 0x51A,
0x51C, 0x51E, 0x520, 0x522, 0x524, 0x526, 0x528, 0x52A, 0x52C,
0x52E, 0x10C7, 0x10CD, 0x1E00, 0x1E02, 0x1E04, 0x1E06, 0x1E08, 0x1E0A,
0x1E0C, 0x1E0E, 0x1E10, 0x1E12, 0x1E14, 0x1E16, 0x1E18, 0x1E1A, 0x1E1C,
0x1E1E, 0x1E20, 0x1E22, 0x1E24, 0x1E26, 0x1E28, 0x1E2A, 0x1E2C, 0x1E2E,
0x1E30, 0x1E32, 0x1E34, 0x1E36, 0x1E38, 0x1E3A, 0x1E3C, 0x1E3E, 0x1E40,
0x1E42, 0x1E44, 0x1E46, 0x1E48, 0x1E4A, 0x1E4C, 0x1E4E, 0x1E50, 0x1E52,
0x1E54, 0x1E56, 0x1E58, 0x1E5A, 0x1E5C, 0x1E5E, 0x1E60, 0x1E62, 0x1E64,
0x1E66, 0x1E68, 0x1E6A, 0x1E6C, 0x1E6E, 0x1E70, 0x1E72, 0x1E74, 0x1E76,
0x1E78, 0x1E7A, 0x1E7C, 0x1E7E, 0x1E80, 0x1E82, 0x1E84, 0x1E86, 0x1E88,
0x1E8A, 0x1E8C, 0x1E8E, 0x1E90, 0x1E92, 0x1E94, 0x1E9E, 0x1EA0, 0x1EA2,
0x1EA4, 0x1EA6, 0x1EA8, 0x1EAA, 0x1EAC, 0x1EAE, 0x1EB0, 0x1EB2, 0x1EB4,
0x1EB6, 0x1EB8, 0x1EBA, 0x1EBC, 0x1EBE, 0x1EC0, 0x1EC2, 0x1EC4, 0x1EC6,
0x1EC8, 0x1ECA, 0x1ECC, 0x1ECE, 0x1ED0, 0x1ED2, 0x1ED4, 0x1ED6, 0x1ED8,
0x1EDA, 0x1EDC, 0x1EDE, 0x1EE0, 0x1EE2, 0x1EE4, 0x1EE6, 0x1EE8, 0x1EEA,
0x1EEC, 0x1EEE, 0x1EF0, 0x1EF2, 0x1EF4, 0x1EF6, 0x1EF8, 0x1EFA, 0x1EFC,
0x1EFE, 0x1F59, 0x1F5B, 0x1F5D, 0x1F5F, 0x2102, 0x2107, 0x2115, 0x2124,
0x2126, 0x2128, 0x213E, 0x213F, 0x2145, 0x2183, 0x2C60, 0x2C67, 0x2C69,
0x2C6B, 0x2C72, 0x2C75, 0x2C82, 0x2C84, 0x2C86, 0x2C88, 0x2C8A, 0x2C8C,
0x2C8E, 0x2C90, 0x2C92, 0x2C94, 0x2C96, 0x2C98, 0x2C9A, 0x2C9C, 0x2C9E,
0x2CA0, 0x2CA2, 0x2CA4, 0x2CA6, 0x2CA8, 0x2CAA, 0x2CAC, 0x2CAE, 0x2CB0,
0x2CB2, 0x2CB4, 0x2CB6, 0x2CB8, 0x2CBA, 0x2CBC, 0x2CBE, 0x2CC0, 0x2CC2,
0x2CC4, 0x2CC6, 0x2CC8, 0x2CCA, 0x2CCC, 0x2CCE, 0x2CD0, 0x2CD2, 0x2CD4,
0x2CD6, 0x2CD8, 0x2CDA, 0x2CDC, 0x2CDE, 0x2CE0, 0x2CE2, 0x2CEB, 0x2CED,
0x2CF2, 0xA640, 0xA642, 0xA644, 0xA646, 0xA648, 0xA64A, 0xA64C, 0xA64E,
0xA650, 0xA652, 0xA654, 0xA656, 0xA658, 0xA65A, 0xA65C, 0xA65E, 0xA660,
0xA662, 0xA664, 0xA666, 0xA668, 0xA66A, 0xA66C, 0xA680, 0xA682, 0xA684,
0xA686, 0xA688, 0xA68A, 0xA68C, 0xA68E, 0xA690, 0xA692, 0xA694, 0xA696,
0xA698, 0xA69A, 0xA722, 0xA724, 0xA726, 0xA728, 0xA72A, 0xA72C, 0xA72E,
0xA732, 0xA734, 0xA736, 0xA738, 0xA73A, 0xA73C, 0xA73E, 0xA740, 0xA742,
0xA744, 0xA746, 0xA748, 0xA74A, 0xA74C, 0xA74E, 0xA750, 0xA752, 0xA754,
0xA756, 0xA758, 0xA75A, 0xA75C, 0xA75E, 0xA760, 0xA762, 0xA764, 0xA766,
0xA768, 0xA76A, 0xA76C, 0xA76E, 0xA779, 0xA77B, 0xA77D, 0xA77E, 0xA780,
0xA782, 0xA784, 0xA786, 0xA78B, 0xA78D, 0xA790, 0xA792, 0xA796, 0xA798,
0xA79A, 0xA79C, 0xA79E, 0xA7A0, 0xA7A2, 0xA7A4, 0xA7A6, 0xA7A8, 0xA7B6,
0xA7B8, 0xA7BA, 0xA7BC, 0xA7BE, 0xA7C2, 0xA7C9, 0xA7F5
#if CHRBITS > 16
,0x1D49C, 0x1D49E, 0x1D49F, 0x1D4A2, 0x1D4A5, 0x1D4A6, 0x1D504, 0x1D505, 0x1D538,
0x1D539, 0x1D546, 0x1D7CA
#endif
};
#define NUM_UPPER_CHAR (sizeof(upperCharTable)/sizeof(chr))
/*
* Unicode: unicode print characters excluding space.
*/
static const crange graphRangeTable[] = {
{0x21, 0x7E}, {0xA1, 0xAC}, {0xAE, 0x377}, {0x37A, 0x37F},
{0x384, 0x38A}, {0x38E, 0x3A1}, {0x3A3, 0x52F}, {0x531, 0x556},
{0x559, 0x58A}, {0x58D, 0x58F}, {0x591, 0x5C7}, {0x5D0, 0x5EA},
{0x5EF, 0x5F4}, {0x606, 0x61B}, {0x61E, 0x6DC}, {0x6DE, 0x70D},
{0x710, 0x74A}, {0x74D, 0x7B1}, {0x7C0, 0x7FA}, {0x7FD, 0x82D},
{0x830, 0x83E}, {0x840, 0x85B}, {0x860, 0x86A}, {0x8A0, 0x8B4},
{0x8B6, 0x8C7}, {0x8D3, 0x8E1}, {0x8E3, 0x983}, {0x985, 0x98C},
{0x993, 0x9A8}, {0x9AA, 0x9B0}, {0x9B6, 0x9B9}, {0x9BC, 0x9C4},
{0x9CB, 0x9CE}, {0x9DF, 0x9E3}, {0x9E6, 0x9FE}, {0xA01, 0xA03},
{0xA05, 0xA0A}, {0xA13, 0xA28}, {0xA2A, 0xA30}, {0xA3E, 0xA42},
{0xA4B, 0xA4D}, {0xA59, 0xA5C}, {0xA66, 0xA76}, {0xA81, 0xA83},
{0xA85, 0xA8D}, {0xA8F, 0xA91}, {0xA93, 0xAA8}, {0xAAA, 0xAB0},
{0xAB5, 0xAB9}, {0xABC, 0xAC5}, {0xAC7, 0xAC9}, {0xACB, 0xACD},
{0xAE0, 0xAE3}, {0xAE6, 0xAF1}, {0xAF9, 0xAFF}, {0xB01, 0xB03},
{0xB05, 0xB0C}, {0xB13, 0xB28}, {0xB2A, 0xB30}, {0xB35, 0xB39},
{0xB3C, 0xB44}, {0xB4B, 0xB4D}, {0xB55, 0xB57}, {0xB5F, 0xB63},
{0xB66, 0xB77}, {0xB85, 0xB8A}, {0xB8E, 0xB90}, {0xB92, 0xB95},
{0xBA8, 0xBAA}, {0xBAE, 0xBB9}, {0xBBE, 0xBC2}, {0xBC6, 0xBC8},
{0xBCA, 0xBCD}, {0xBE6, 0xBFA}, {0xC00, 0xC0C}, {0xC0E, 0xC10},
{0xC12, 0xC28}, {0xC2A, 0xC39}, {0xC3D, 0xC44}, {0xC46, 0xC48},
{0xC4A, 0xC4D}, {0xC58, 0xC5A}, {0xC60, 0xC63}, {0xC66, 0xC6F},
{0xC77, 0xC8C}, {0xC8E, 0xC90}, {0xC92, 0xCA8}, {0xCAA, 0xCB3},
{0xCB5, 0xCB9}, {0xCBC, 0xCC4}, {0xCC6, 0xCC8}, {0xCCA, 0xCCD},
{0xCE0, 0xCE3}, {0xCE6, 0xCEF}, {0xD00, 0xD0C}, {0xD0E, 0xD10},
{0xD12, 0xD44}, {0xD46, 0xD48}, {0xD4A, 0xD4F}, {0xD54, 0xD63},
{0xD66, 0xD7F}, {0xD81, 0xD83}, {0xD85, 0xD96}, {0xD9A, 0xDB1},
{0xDB3, 0xDBB}, {0xDC0, 0xDC6}, {0xDCF, 0xDD4}, {0xDD8, 0xDDF},
{0xDE6, 0xDEF}, {0xDF2, 0xDF4}, {0xE01, 0xE3A}, {0xE3F, 0xE5B},
{0xE86, 0xE8A}, {0xE8C, 0xEA3}, {0xEA7, 0xEBD}, {0xEC0, 0xEC4},
{0xEC8, 0xECD}, {0xED0, 0xED9}, {0xEDC, 0xEDF}, {0xF00, 0xF47},
{0xF49, 0xF6C}, {0xF71, 0xF97}, {0xF99, 0xFBC}, {0xFBE, 0xFCC},
{0xFCE, 0xFDA}, {0x1000, 0x10C5}, {0x10D0, 0x1248}, {0x124A, 0x124D},
{0x1250, 0x1256}, {0x125A, 0x125D}, {0x1260, 0x1288}, {0x128A, 0x128D},
{0x1290, 0x12B0}, {0x12B2, 0x12B5}, {0x12B8, 0x12BE}, {0x12C2, 0x12C5},
{0x12C8, 0x12D6}, {0x12D8, 0x1310}, {0x1312, 0x1315}, {0x1318, 0x135A},
{0x135D, 0x137C}, {0x1380, 0x1399}, {0x13A0, 0x13F5}, {0x13F8, 0x13FD},
{0x1400, 0x167F}, {0x1681, 0x169C}, {0x16A0, 0x16F8}, {0x1700, 0x170C},
{0x170E, 0x1714}, {0x1720, 0x1736}, {0x1740, 0x1753}, {0x1760, 0x176C},
{0x176E, 0x1770}, {0x1780, 0x17DD}, {0x17E0, 0x17E9}, {0x17F0, 0x17F9},
{0x1800, 0x180D}, {0x1810, 0x1819}, {0x1820, 0x1878}, {0x1880, 0x18AA},
{0x18B0, 0x18F5}, {0x1900, 0x191E}, {0x1920, 0x192B}, {0x1930, 0x193B},
{0x1944, 0x196D}, {0x1970, 0x1974}, {0x1980, 0x19AB}, {0x19B0, 0x19C9},
{0x19D0, 0x19DA}, {0x19DE, 0x1A1B}, {0x1A1E, 0x1A5E}, {0x1A60, 0x1A7C},
{0x1A7F, 0x1A89}, {0x1A90, 0x1A99}, {0x1AA0, 0x1AAD}, {0x1AB0, 0x1AC0},
{0x1B00, 0x1B4B}, {0x1B50, 0x1B7C}, {0x1B80, 0x1BF3}, {0x1BFC, 0x1C37},
{0x1C3B, 0x1C49}, {0x1C4D, 0x1C88}, {0x1C90, 0x1CBA}, {0x1CBD, 0x1CC7},
{0x1CD0, 0x1CFA}, {0x1D00, 0x1DF9}, {0x1DFB, 0x1F15}, {0x1F18, 0x1F1D},
{0x1F20, 0x1F45}, {0x1F48, 0x1F4D}, {0x1F50, 0x1F57}, {0x1F5F, 0x1F7D},
{0x1F80, 0x1FB4}, {0x1FB6, 0x1FC4}, {0x1FC6, 0x1FD3}, {0x1FD6, 0x1FDB},
{0x1FDD, 0x1FEF}, {0x1FF2, 0x1FF4}, {0x1FF6, 0x1FFE}, {0x2010, 0x2027},
{0x2030, 0x205E}, {0x2074, 0x208E}, {0x2090, 0x209C}, {0x20A0, 0x20BF},
{0x20D0, 0x20F0}, {0x2100, 0x218B}, {0x2190, 0x2426}, {0x2440, 0x244A},
{0x2460, 0x2B73}, {0x2B76, 0x2B95}, {0x2B97, 0x2C2E}, {0x2C30, 0x2C5E},
{0x2C60, 0x2CF3}, {0x2CF9, 0x2D25}, {0x2D30, 0x2D67}, {0x2D7F, 0x2D96},
{0x2DA0, 0x2DA6}, {0x2DA8, 0x2DAE}, {0x2DB0, 0x2DB6}, {0x2DB8, 0x2DBE},
{0x2DC0, 0x2DC6}, {0x2DC8, 0x2DCE}, {0x2DD0, 0x2DD6}, {0x2DD8, 0x2DDE},
{0x2DE0, 0x2E52}, {0x2E80, 0x2E99}, {0x2E9B, 0x2EF3}, {0x2F00, 0x2FD5},
{0x2FF0, 0x2FFB}, {0x3001, 0x303F}, {0x3041, 0x3096}, {0x3099, 0x30FF},
{0x3105, 0x312F}, {0x3131, 0x318E}, {0x3190, 0x31E3}, {0x31F0, 0x321E},
{0x3220, 0x9FFC}, {0xA000, 0xA48C}, {0xA490, 0xA4C6}, {0xA4D0, 0xA62B},
{0xA640, 0xA6F7}, {0xA700, 0xA7BF}, {0xA7C2, 0xA7CA}, {0xA7F5, 0xA82C},
{0xA830, 0xA839}, {0xA840, 0xA877}, {0xA880, 0xA8C5}, {0xA8CE, 0xA8D9},
{0xA8E0, 0xA953}, {0xA95F, 0xA97C}, {0xA980, 0xA9CD}, {0xA9CF, 0xA9D9},
{0xA9DE, 0xA9FE}, {0xAA00, 0xAA36}, {0xAA40, 0xAA4D}, {0xAA50, 0xAA59},
{0xAA5C, 0xAAC2}, {0xAADB, 0xAAF6}, {0xAB01, 0xAB06}, {0xAB09, 0xAB0E},
{0xAB11, 0xAB16}, {0xAB20, 0xAB26}, {0xAB28, 0xAB2E}, {0xAB30, 0xAB6B},
{0xAB70, 0xABED}, {0xABF0, 0xABF9}, {0xAC00, 0xD7A3}, {0xD7B0, 0xD7C6},
{0xD7CB, 0xD7FB}, {0xF900, 0xFA6D}, {0xFA70, 0xFAD9}, {0xFB00, 0xFB06},
{0xFB13, 0xFB17}, {0xFB1D, 0xFB36}, {0xFB38, 0xFB3C}, {0xFB46, 0xFBC1},
{0xFBD3, 0xFD3F}, {0xFD50, 0xFD8F}, {0xFD92, 0xFDC7}, {0xFDF0, 0xFDFD},
{0xFE00, 0xFE19}, {0xFE20, 0xFE52}, {0xFE54, 0xFE66}, {0xFE68, 0xFE6B},
{0xFE70, 0xFE74}, {0xFE76, 0xFEFC}, {0xFF01, 0xFFBE}, {0xFFC2, 0xFFC7},
{0xFFCA, 0xFFCF}, {0xFFD2, 0xFFD7}, {0xFFDA, 0xFFDC}, {0xFFE0, 0xFFE6},
{0xFFE8, 0xFFEE}
#if CHRBITS > 16
,{0x10000, 0x1000B}, {0x1000D, 0x10026}, {0x10028, 0x1003A}, {0x1003F, 0x1004D},
{0x10050, 0x1005D}, {0x10080, 0x100FA}, {0x10100, 0x10102}, {0x10107, 0x10133},
{0x10137, 0x1018E}, {0x10190, 0x1019C}, {0x101D0, 0x101FD}, {0x10280, 0x1029C},
{0x102A0, 0x102D0}, {0x102E0, 0x102FB}, {0x10300, 0x10323}, {0x1032D, 0x1034A},
{0x10350, 0x1037A}, {0x10380, 0x1039D}, {0x1039F, 0x103C3}, {0x103C8, 0x103D5},
{0x10400, 0x1049D}, {0x104A0, 0x104A9}, {0x104B0, 0x104D3}, {0x104D8, 0x104FB},
{0x10500, 0x10527}, {0x10530, 0x10563}, {0x10600, 0x10736}, {0x10740, 0x10755},
{0x10760, 0x10767}, {0x10800, 0x10805}, {0x1080A, 0x10835}, {0x1083F, 0x10855},
{0x10857, 0x1089E}, {0x108A7, 0x108AF}, {0x108E0, 0x108F2}, {0x108FB, 0x1091B},
{0x1091F, 0x10939}, {0x10980, 0x109B7}, {0x109BC, 0x109CF}, {0x109D2, 0x10A03},
{0x10A0C, 0x10A13}, {0x10A15, 0x10A17}, {0x10A19, 0x10A35}, {0x10A38, 0x10A3A},
{0x10A3F, 0x10A48}, {0x10A50, 0x10A58}, {0x10A60, 0x10A9F}, {0x10AC0, 0x10AE6},
{0x10AEB, 0x10AF6}, {0x10B00, 0x10B35}, {0x10B39, 0x10B55}, {0x10B58, 0x10B72},
{0x10B78, 0x10B91}, {0x10B99, 0x10B9C}, {0x10BA9, 0x10BAF}, {0x10C00, 0x10C48},
{0x10C80, 0x10CB2}, {0x10CC0, 0x10CF2}, {0x10CFA, 0x10D27}, {0x10D30, 0x10D39},
{0x10E60, 0x10E7E}, {0x10E80, 0x10EA9}, {0x10EAB, 0x10EAD}, {0x10F00, 0x10F27},
{0x10F30, 0x10F59}, {0x10FB0, 0x10FCB}, {0x10FE0, 0x10FF6}, {0x11000, 0x1104D},
{0x11052, 0x1106F}, {0x1107F, 0x110BC}, {0x110BE, 0x110C1}, {0x110D0, 0x110E8},
{0x110F0, 0x110F9}, {0x11100, 0x11134}, {0x11136, 0x11147}, {0x11150, 0x11176},
{0x11180, 0x111DF}, {0x111E1, 0x111F4}, {0x11200, 0x11211}, {0x11213, 0x1123E},
{0x11280, 0x11286}, {0x1128A, 0x1128D}, {0x1128F, 0x1129D}, {0x1129F, 0x112A9},
{0x112B0, 0x112EA}, {0x112F0, 0x112F9}, {0x11300, 0x11303}, {0x11305, 0x1130C},
{0x11313, 0x11328}, {0x1132A, 0x11330}, {0x11335, 0x11339}, {0x1133B, 0x11344},
{0x1134B, 0x1134D}, {0x1135D, 0x11363}, {0x11366, 0x1136C}, {0x11370, 0x11374},
{0x11400, 0x1145B}, {0x1145D, 0x11461}, {0x11480, 0x114C7}, {0x114D0, 0x114D9},
{0x11580, 0x115B5}, {0x115B8, 0x115DD}, {0x11600, 0x11644}, {0x11650, 0x11659},
{0x11660, 0x1166C}, {0x11680, 0x116B8}, {0x116C0, 0x116C9}, {0x11700, 0x1171A},
{0x1171D, 0x1172B}, {0x11730, 0x1173F}, {0x11800, 0x1183B}, {0x118A0, 0x118F2},
{0x118FF, 0x11906}, {0x1190C, 0x11913}, {0x11918, 0x11935}, {0x1193B, 0x11946},
{0x11950, 0x11959}, {0x119A0, 0x119A7}, {0x119AA, 0x119D7}, {0x119DA, 0x119E4},
{0x11A00, 0x11A47}, {0x11A50, 0x11AA2}, {0x11AC0, 0x11AF8}, {0x11C00, 0x11C08},
{0x11C0A, 0x11C36}, {0x11C38, 0x11C45}, {0x11C50, 0x11C6C}, {0x11C70, 0x11C8F},
{0x11C92, 0x11CA7}, {0x11CA9, 0x11CB6}, {0x11D00, 0x11D06}, {0x11D0B, 0x11D36},
{0x11D3F, 0x11D47}, {0x11D50, 0x11D59}, {0x11D60, 0x11D65}, {0x11D6A, 0x11D8E},
{0x11D93, 0x11D98}, {0x11DA0, 0x11DA9}, {0x11EE0, 0x11EF8}, {0x11FC0, 0x11FF1},
{0x11FFF, 0x12399}, {0x12400, 0x1246E}, {0x12470, 0x12474}, {0x12480, 0x12543},
{0x13000, 0x1342E}, {0x14400, 0x14646}, {0x16800, 0x16A38}, {0x16A40, 0x16A5E},
{0x16A60, 0x16A69}, {0x16AD0, 0x16AED}, {0x16AF0, 0x16AF5}, {0x16B00, 0x16B45},
{0x16B50, 0x16B59}, {0x16B5B, 0x16B61}, {0x16B63, 0x16B77}, {0x16B7D, 0x16B8F},
{0x16E40, 0x16E9A}, {0x16F00, 0x16F4A}, {0x16F4F, 0x16F87}, {0x16F8F, 0x16F9F},
{0x16FE0, 0x16FE4}, {0x17000, 0x187F7}, {0x18800, 0x18CD5}, {0x18D00, 0x18D08},
{0x1B000, 0x1B11E}, {0x1B150, 0x1B152}, {0x1B164, 0x1B167}, {0x1B170, 0x1B2FB},
{0x1BC00, 0x1BC6A}, {0x1BC70, 0x1BC7C}, {0x1BC80, 0x1BC88}, {0x1BC90, 0x1BC99},
{0x1BC9C, 0x1BC9F}, {0x1D000, 0x1D0F5}, {0x1D100, 0x1D126}, {0x1D129, 0x1D172},
{0x1D17B, 0x1D1E8}, {0x1D200, 0x1D245}, {0x1D2E0, 0x1D2F3}, {0x1D300, 0x1D356},
{0x1D360, 0x1D378}, {0x1D400, 0x1D454}, {0x1D456, 0x1D49C}, {0x1D4A9, 0x1D4AC},
{0x1D4AE, 0x1D4B9}, {0x1D4BD, 0x1D4C3}, {0x1D4C5, 0x1D505}, {0x1D507, 0x1D50A},
{0x1D50D, 0x1D514}, {0x1D516, 0x1D51C}, {0x1D51E, 0x1D539}, {0x1D53B, 0x1D53E},
{0x1D540, 0x1D544}, {0x1D54A, 0x1D550}, {0x1D552, 0x1D6A5}, {0x1D6A8, 0x1D7CB},
{0x1D7CE, 0x1DA8B}, {0x1DA9B, 0x1DA9F}, {0x1DAA1, 0x1DAAF}, {0x1E000, 0x1E006},
{0x1E008, 0x1E018}, {0x1E01B, 0x1E021}, {0x1E026, 0x1E02A}, {0x1E100, 0x1E12C},
{0x1E130, 0x1E13D}, {0x1E140, 0x1E149}, {0x1E2C0, 0x1E2F9}, {0x1E800, 0x1E8C4},
{0x1E8C7, 0x1E8D6}, {0x1E900, 0x1E94B}, {0x1E950, 0x1E959}, {0x1EC71, 0x1ECB4},
{0x1ED01, 0x1ED3D}, {0x1EE00, 0x1EE03}, {0x1EE05, 0x1EE1F}, {0x1EE29, 0x1EE32},
{0x1EE34, 0x1EE37}, {0x1EE4D, 0x1EE4F}, {0x1EE67, 0x1EE6A}, {0x1EE6C, 0x1EE72},
{0x1EE74, 0x1EE77}, {0x1EE79, 0x1EE7C}, {0x1EE80, 0x1EE89}, {0x1EE8B, 0x1EE9B},
{0x1EEA1, 0x1EEA3}, {0x1EEA5, 0x1EEA9}, {0x1EEAB, 0x1EEBB}, {0x1F000, 0x1F02B},
{0x1F030, 0x1F093}, {0x1F0A0, 0x1F0AE}, {0x1F0B1, 0x1F0BF}, {0x1F0C1, 0x1F0CF},
{0x1F0D1, 0x1F0F5}, {0x1F100, 0x1F1AD}, {0x1F1E6, 0x1F202}, {0x1F210, 0x1F23B},
{0x1F240, 0x1F248}, {0x1F260, 0x1F265}, {0x1F300, 0x1F6D7}, {0x1F6E0, 0x1F6EC},
{0x1F6F0, 0x1F6FC}, {0x1F700, 0x1F773}, {0x1F780, 0x1F7D8}, {0x1F7E0, 0x1F7EB},
{0x1F800, 0x1F80B}, {0x1F810, 0x1F847}, {0x1F850, 0x1F859}, {0x1F860, 0x1F887},
{0x1F890, 0x1F8AD}, {0x1F900, 0x1F978}, {0x1F97A, 0x1F9CB}, {0x1F9CD, 0x1FA53},
{0x1FA60, 0x1FA6D}, {0x1FA70, 0x1FA74}, {0x1FA78, 0x1FA7A}, {0x1FA80, 0x1FA86},
{0x1FA90, 0x1FAA8}, {0x1FAB0, 0x1FAB6}, {0x1FAC0, 0x1FAC2}, {0x1FAD0, 0x1FAD6},
{0x1FB00, 0x1FB92}, {0x1FB94, 0x1FBCA}, {0x1FBF0, 0x1FBF9}, {0x20000, 0x2A6DD},
{0x2A700, 0x2B734}, {0x2B740, 0x2B81D}, {0x2B820, 0x2CEA1}, {0x2CEB0, 0x2EBE0},
{0x2F800, 0x2FA1D}, {0x30000, 0x3134A}, {0xE0100, 0xE01EF}
#endif
};
#define NUM_GRAPH_RANGE (sizeof(graphRangeTable)/sizeof(crange))
static const chr graphCharTable[] = {
0x38C, 0x85E, 0x98F, 0x990, 0x9B2, 0x9C7, 0x9C8, 0x9D7, 0x9DC,
0x9DD, 0xA0F, 0xA10, 0xA32, 0xA33, 0xA35, 0xA36, 0xA38, 0xA39,
0xA3C, 0xA47, 0xA48, 0xA51, 0xA5E, 0xAB2, 0xAB3, 0xAD0, 0xB0F,
0xB10, 0xB32, 0xB33, 0xB47, 0xB48, 0xB5C, 0xB5D, 0xB82, 0xB83,
0xB99, 0xB9A, 0xB9C, 0xB9E, 0xB9F, 0xBA3, 0xBA4, 0xBD0, 0xBD7,
0xC55, 0xC56, 0xCD5, 0xCD6, 0xCDE, 0xCF1, 0xCF2, 0xDBD, 0xDCA,
0xDD6, 0xE81, 0xE82, 0xE84, 0xEA5, 0xEC6, 0x10C7, 0x10CD, 0x1258,
0x12C0, 0x1772, 0x1773, 0x1940, 0x1F59, 0x1F5B, 0x1F5D, 0x2070, 0x2071,
0x2D27, 0x2D2D, 0x2D6F, 0x2D70, 0xFB3E, 0xFB40, 0xFB41, 0xFB43, 0xFB44,
0xFFFC, 0xFFFD
#if CHRBITS > 16
,0x1003C, 0x1003D, 0x101A0, 0x1056F, 0x10808, 0x10837, 0x10838, 0x1083C, 0x108F4,
0x108F5, 0x1093F, 0x10A05, 0x10A06, 0x10EB0, 0x10EB1, 0x11288, 0x1130F, 0x11310,
0x11332, 0x11333, 0x11347, 0x11348, 0x11350, 0x11357, 0x11909, 0x11915, 0x11916,
0x11937, 0x11938, 0x11D08, 0x11D09, 0x11D3A, 0x11D3C, 0x11D3D, 0x11D67, 0x11D68,
0x11D90, 0x11D91, 0x11FB0, 0x16A6E, 0x16A6F, 0x16FF0, 0x16FF1, 0x1D49E, 0x1D49F,
0x1D4A2, 0x1D4A5, 0x1D4A6, 0x1D4BB, 0x1D546, 0x1E023, 0x1E024, 0x1E14E, 0x1E14F,
0x1E2FF, 0x1E95E, 0x1E95F, 0x1EE21, 0x1EE22, 0x1EE24, 0x1EE27, 0x1EE39, 0x1EE3B,
0x1EE42, 0x1EE47, 0x1EE49, 0x1EE4B, 0x1EE51, 0x1EE52, 0x1EE54, 0x1EE57, 0x1EE59,
0x1EE5B, 0x1EE5D, 0x1EE5F, 0x1EE61, 0x1EE62, 0x1EE64, 0x1EE7E, 0x1EEF0, 0x1EEF1,
0x1F250, 0x1F251, 0x1F8B0, 0x1F8B1
#endif
};
#define NUM_GRAPH_CHAR (sizeof(graphCharTable)/sizeof(chr))
/*
* End of auto-generated Unicode character ranges declarations.
*/
#define CH NOCELT
/*
- element - map collating-element name to celt
^ static celt element(struct vars *, const chr *, const chr *);
*/
static celt
element(
|
| ︙ | ︙ | |||
886 887 888 889 890 891 892 |
nchrs = (b - a + 1)*2 + 4;
cv = getcvec(v, nchrs, 0);
NOERRN();
for (c=a; c<=b; c++) {
addchr(cv, c);
| | | | | 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 |
nchrs = (b - a + 1)*2 + 4;
cv = getcvec(v, nchrs, 0);
NOERRN();
for (c=a; c<=b; c++) {
addchr(cv, c);
lc = Tcl_UniCharToLower((chr)c);
uc = Tcl_UniCharToUpper((chr)c);
tc = Tcl_UniCharToTitle((chr)c);
if (c != lc) {
addchr(cv, lc);
}
if (c != uc) {
addchr(cv, uc);
}
if (c != tc && tc != uc) {
|
| ︙ | ︙ | |||
937 938 939 940 941 942 943 |
/*
* Crude fake equivalence class for testing.
*/
if ((v->cflags®_FAKE) && c == 'x') {
cv = getcvec(v, 4, 0);
| | | | | | < | | 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 |
/*
* Crude fake equivalence class for testing.
*/
if ((v->cflags®_FAKE) && c == 'x') {
cv = getcvec(v, 4, 0);
addchr(cv, (chr)'x');
addchr(cv, (chr)'y');
if (cases) {
addchr(cv, (chr)'X');
addchr(cv, (chr)'Y');
}
return cv;
}
/*
* Otherwise, none.
*/
if (cases) {
return allcases(v, c);
}
cv = getcvec(v, 1, 0);
assert(cv != NULL);
addchr(cv, (chr)c);
return cv;
}
/*
- cclass - supply cvec for a character class
* Must include case counterparts on request.
^ static struct cvec *cclass(struct vars *, const chr *, const chr *, int);
*/
static struct cvec *
cclass(
struct vars *v, /* context */
const chr *startp, /* where the name starts */
const chr *endp, /* just past the end of the name */
int cases) /* case-independent? */
{
size_t len;
struct cvec *cv = NULL;
Tcl_DString ds;
const char *np;
const char *const *namePtr;
int i, index;
/*
* The following arrays define the valid character class names.
*/
static const char *const classNames[] = {
"alnum", "alpha", "ascii", "blank", "cntrl", "digit", "graph",
|
| ︙ | ︙ | |||
1000 1001 1002 1003 1004 1005 1006 |
/*
* Extract the class name
*/
len = endp - startp;
Tcl_DStringInit(&ds);
| | | 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 |
/*
* Extract the class name
*/
len = endp - startp;
Tcl_DStringInit(&ds);
np = Tcl_UniCharToUtfDString(startp, (int)len, &ds);
/*
* Map the name to the corresponding enumerated value.
*/
index = -1;
for (namePtr=classNames,i=0 ; *namePtr!=NULL ; namePtr++,i++) {
|
| ︙ | ︙ | |||
1035 1036 1037 1038 1039 1040 1041 |
* Now compute the character class contents.
*/
switch((enum classes) index) {
case CC_ALNUM:
cv = getcvec(v, NUM_ALPHA_CHAR, NUM_DIGIT_RANGE + NUM_ALPHA_RANGE);
if (cv) {
| | | | | | | | | | | | | 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 |
* Now compute the character class contents.
*/
switch((enum classes) index) {
case CC_ALNUM:
cv = getcvec(v, NUM_ALPHA_CHAR, NUM_DIGIT_RANGE + NUM_ALPHA_RANGE);
if (cv) {
for (i=0 ; (size_t)i<NUM_ALPHA_CHAR ; i++) {
addchr(cv, alphaCharTable[i]);
}
for (i=0 ; (size_t)i<NUM_ALPHA_RANGE ; i++) {
addrange(cv, alphaRangeTable[i].start,
alphaRangeTable[i].end);
}
for (i=0 ; (size_t)i<NUM_DIGIT_RANGE ; i++) {
addrange(cv, digitRangeTable[i].start,
digitRangeTable[i].end);
}
}
break;
case CC_ALPHA:
cv = getcvec(v, NUM_ALPHA_CHAR, NUM_ALPHA_RANGE);
if (cv) {
for (i=0 ; (size_t)i<NUM_ALPHA_RANGE ; i++) {
addrange(cv, alphaRangeTable[i].start,
alphaRangeTable[i].end);
}
for (i=0 ; (size_t)i<NUM_ALPHA_CHAR ; i++) {
addchr(cv, alphaCharTable[i]);
}
}
break;
case CC_ASCII:
cv = getcvec(v, 0, 1);
if (cv) {
addrange(cv, 0, 0x7F);
}
break;
case CC_BLANK:
cv = getcvec(v, 2, 0);
addchr(cv, '\t');
addchr(cv, ' ');
break;
case CC_CNTRL:
cv = getcvec(v, NUM_CONTROL_CHAR, NUM_CONTROL_RANGE);
if (cv) {
for (i=0 ; (size_t)i<NUM_CONTROL_RANGE ; i++) {
addrange(cv, controlRangeTable[i].start,
controlRangeTable[i].end);
}
for (i=0 ; (size_t)i<NUM_CONTROL_CHAR ; i++) {
addchr(cv, controlCharTable[i]);
}
}
break;
case CC_DIGIT:
cv = getcvec(v, 0, NUM_DIGIT_RANGE);
if (cv) {
for (i=0 ; (size_t)i<NUM_DIGIT_RANGE ; i++) {
addrange(cv, digitRangeTable[i].start,
digitRangeTable[i].end);
}
}
break;
case CC_PUNCT:
cv = getcvec(v, NUM_PUNCT_CHAR, NUM_PUNCT_RANGE);
if (cv) {
for (i=0 ; (size_t)i<NUM_PUNCT_RANGE ; i++) {
addrange(cv, punctRangeTable[i].start,
punctRangeTable[i].end);
}
for (i=0 ; (size_t)i<NUM_PUNCT_CHAR ; i++) {
addchr(cv, punctCharTable[i]);
}
}
break;
case CC_XDIGIT:
/*
* This is a 3 instead of (NUM_DIGIT_RANGE+2) because I've no idea how
|
| ︙ | ︙ | |||
1124 1125 1126 1127 1128 1129 1130 |
addrange(cv, 'a', 'f');
addrange(cv, 'A', 'F');
}
break;
case CC_SPACE:
cv = getcvec(v, NUM_SPACE_CHAR, NUM_SPACE_RANGE);
if (cv) {
| | | | | | | | | | | | | | 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 |
addrange(cv, 'a', 'f');
addrange(cv, 'A', 'F');
}
break;
case CC_SPACE:
cv = getcvec(v, NUM_SPACE_CHAR, NUM_SPACE_RANGE);
if (cv) {
for (i=0 ; (size_t)i<NUM_SPACE_RANGE ; i++) {
addrange(cv, spaceRangeTable[i].start,
spaceRangeTable[i].end);
}
for (i=0 ; (size_t)i<NUM_SPACE_CHAR ; i++) {
addchr(cv, spaceCharTable[i]);
}
}
break;
case CC_LOWER:
cv = getcvec(v, NUM_LOWER_CHAR, NUM_LOWER_RANGE);
if (cv) {
for (i=0 ; (size_t)i<NUM_LOWER_RANGE ; i++) {
addrange(cv, lowerRangeTable[i].start,
lowerRangeTable[i].end);
}
for (i=0 ; (size_t)i<NUM_LOWER_CHAR ; i++) {
addchr(cv, lowerCharTable[i]);
}
}
break;
case CC_UPPER:
cv = getcvec(v, NUM_UPPER_CHAR, NUM_UPPER_RANGE);
if (cv) {
for (i=0 ; (size_t)i<NUM_UPPER_RANGE ; i++) {
addrange(cv, upperRangeTable[i].start,
upperRangeTable[i].end);
}
for (i=0 ; (size_t)i<NUM_UPPER_CHAR ; i++) {
addchr(cv, upperCharTable[i]);
}
}
break;
case CC_PRINT:
cv = getcvec(v, NUM_SPACE_CHAR + NUM_GRAPH_CHAR, NUM_SPACE_RANGE + NUM_GRAPH_RANGE - 1);
if (cv) {
for (i=1 ; (size_t)i<NUM_SPACE_RANGE ; i++) {
addrange(cv, spaceRangeTable[i].start,
spaceRangeTable[i].end);
}
for (i=0 ; (size_t)i<NUM_SPACE_CHAR ; i++) {
addchr(cv, spaceCharTable[i]);
}
for (i=0 ; (size_t)i<NUM_GRAPH_RANGE ; i++) {
addrange(cv, graphRangeTable[i].start,
graphRangeTable[i].end);
}
for (i=0 ; (size_t)i<NUM_GRAPH_CHAR ; i++) {
addchr(cv, graphCharTable[i]);
}
}
break;
case CC_GRAPH:
cv = getcvec(v, NUM_GRAPH_CHAR, NUM_GRAPH_RANGE);
if (cv) {
for (i=0 ; (size_t)i<NUM_GRAPH_RANGE ; i++) {
addrange(cv, graphRangeTable[i].start,
graphRangeTable[i].end);
}
for (i=0 ; (size_t)i<NUM_GRAPH_CHAR ; i++) {
addchr(cv, graphCharTable[i]);
}
}
break;
}
if (cv == NULL) {
ERR(REG_ESPACE);
|
| ︙ | ︙ | |||
1210 1211 1212 1213 1214 1215 1216 |
struct vars *v, /* context */
pchr pc) /* character to get case equivs of */
{
struct cvec *cv;
chr c = (chr)pc;
chr lc, uc, tc;
| | | | | 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 |
struct vars *v, /* context */
pchr pc) /* character to get case equivs of */
{
struct cvec *cv;
chr c = (chr)pc;
chr lc, uc, tc;
lc = Tcl_UniCharToLower((chr)c);
uc = Tcl_UniCharToUpper((chr)c);
tc = Tcl_UniCharToTitle((chr)c);
if (tc != uc) {
cv = getcvec(v, 3, 0);
addchr(cv, tc);
} else {
cv = getcvec(v, 2, 0);
}
|
| ︙ | ︙ |
Changes to generic/regc_nfa.c.
| ︙ | ︙ | |||
2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 |
narcs += s->nouts;
}
fprintf(f, "total of %d states, %d arcs\n", nstates, narcs);
if (nfa->parent == NULL) {
dumpcolors(nfa->cm, f);
}
fflush(f);
#endif
}
#ifdef REG_DEBUG /* subordinates of dumpnfa */
/*
^ #ifdef REG_DEBUG
*/
| > > > | 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 |
narcs += s->nouts;
}
fprintf(f, "total of %d states, %d arcs\n", nstates, narcs);
if (nfa->parent == NULL) {
dumpcolors(nfa->cm, f);
}
fflush(f);
#else
(void)nfa;
(void)f;
#endif
}
#ifdef REG_DEBUG /* subordinates of dumpnfa */
/*
^ #ifdef REG_DEBUG
*/
|
| ︙ | ︙ | |||
3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 |
fprintf(f, ", haslacons");
}
fprintf(f, "\n");
for (st = 0; st < cnfa->nstates; st++) {
dumpcstate(st, cnfa, f);
}
fflush(f);
#endif
}
#ifdef REG_DEBUG /* subordinates of dumpcnfa */
/*
^ #ifdef REG_DEBUG
*/
| > > > | 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 |
fprintf(f, ", haslacons");
}
fprintf(f, "\n");
for (st = 0; st < cnfa->nstates; st++) {
dumpcstate(st, cnfa, f);
}
fflush(f);
#else
(void)cnfa;
(void)f;
#endif
}
#ifdef REG_DEBUG /* subordinates of dumpcnfa */
/*
^ #ifdef REG_DEBUG
*/
|
| ︙ | ︙ |
Changes to generic/regcomp.c.
| ︙ | ︙ | |||
35 36 37 38 39 40 41 | /* * forward declarations, up here so forward datatypes etc. are defined early */ /* =====^!^===== begin forwards =====^!^===== */ /* automatically gathered by fwd; do not hand-edit */ /* === regcomp.c === */ int compile(regex_t *, const chr *, size_t, int); | | < | 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 | /* * forward declarations, up here so forward datatypes etc. are defined early */ /* =====^!^===== begin forwards =====^!^===== */ /* automatically gathered by fwd; do not hand-edit */ /* === regcomp.c === */ int compile(regex_t *, const chr *, size_t, int); static void moresubs(struct vars *, int); static int freev(struct vars *, int); static void makesearch(struct vars *, struct nfa *); static struct subre *parse(struct vars *, int, int, struct state *, struct state *); static struct subre *parsebranch(struct vars *, int, int, struct state *, struct state *, int); static void parseqatom(struct vars *, int, int, struct state *, struct state *, struct subre *); static void nonword(struct vars *, int, struct state *, struct state *); static void word(struct vars *, int, struct state *, struct state *); static int scannum(struct vars *); static void repeat(struct vars *, struct state *, struct state *, int, int); 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 *subre(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 *); static int newlacon(struct vars *, struct state *, struct state *, int); static void freelacons(struct subre *, int); |
| ︙ | ︙ | |||
240 241 242 243 244 245 246 247 248 249 250 251 252 253 |
#define NOERRN() {if (ISERR()) return NULL;} /* NOERR with retval */
#define NOERRZ() {if (ISERR()) return 0;} /* NOERR with retval */
#define INSIST(c, e) do { if (!(c)) ERR(e); } while (0) /* error if c false */
#define NOTE(b) (v->re->re_info |= (b)) /* note visible condition */
#define EMPTYARC(x, y) newarc(v->nfa, EMPTY, 0, x, y)
/* token type codes, some also used as NFA arc types */
#define EMPTY 'n' /* no token present */
#define EOS 'e' /* end of string */
#define PLAIN 'p' /* ordinary character */
#define DIGIT 'd' /* digit (in bound) */
#define BACKREF 'b' /* back reference */
#define COLLEL 'I' /* start of [. */
#define ECLASS 'E' /* start of [= */
| > | 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 |
#define NOERRN() {if (ISERR()) return NULL;} /* NOERR with retval */
#define NOERRZ() {if (ISERR()) return 0;} /* NOERR with retval */
#define INSIST(c, e) do { if (!(c)) ERR(e); } while (0) /* error if c false */
#define NOTE(b) (v->re->re_info |= (b)) /* note visible condition */
#define EMPTYARC(x, y) newarc(v->nfa, EMPTY, 0, x, y)
/* token type codes, some also used as NFA arc types */
#undef DIGIT /* prevent conflict with libtommath */
#define EMPTY 'n' /* no token present */
#define EOS 'e' /* end of string */
#define PLAIN 'p' /* ordinary character */
#define DIGIT 'd' /* digit (in bound) */
#define BACKREF 'b' /* back reference */
#define COLLEL 'I' /* start of [. */
#define ECLASS 'E' /* start of [= */
|
| ︙ | ︙ | |||
334 335 336 337 338 339 340 341 342 343 344 345 346 347 |
v->cv = NULL;
v->cv2 = NULL;
v->lacons = NULL;
v->nlacons = 0;
v->spaceused = 0;
re->re_magic = REMAGIC;
re->re_info = 0; /* bits get set during parse */
re->re_guts = NULL;
re->re_fns = (void*)(&functions);
/*
* More complex setup, malloced things.
*/
| > | 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 |
v->cv = NULL;
v->cv2 = NULL;
v->lacons = NULL;
v->nlacons = 0;
v->spaceused = 0;
re->re_magic = REMAGIC;
re->re_info = 0; /* bits get set during parse */
re->re_csize = sizeof(chr);
re->re_guts = NULL;
re->re_fns = (void*)(&functions);
/*
* More complex setup, malloced things.
*/
|
| ︙ | ︙ | |||
389 390 391 392 393 394 395 |
specialcolors(v->nfa);
CNOERR();
if (debug != NULL) {
fprintf(debug, "\n\n\n========= RAW ==========\n");
dumpnfa(v->nfa, debug);
dumpst(v->tree, debug, 1);
}
| < | 390 391 392 393 394 395 396 397 398 399 400 401 402 403 |
specialcolors(v->nfa);
CNOERR();
if (debug != NULL) {
fprintf(debug, "\n\n\n========= RAW ==========\n");
dumpnfa(v->nfa, debug);
dumpst(v->tree, debug, 1);
}
v->ntree = numst(v->tree, 1);
markst(v->tree);
cleanst(v);
if (debug != NULL) {
fprintf(debug, "\n\n\n========= TREE FIXED ==========\n");
dumpst(v->tree, debug, 1);
}
|
| ︙ | ︙ | |||
463 464 465 466 467 468 469 |
assert(v->err == 0);
return freev(v, 0);
}
/*
- moresubs - enlarge subRE vector
| | | | 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 |
assert(v->err == 0);
return freev(v, 0);
}
/*
- moresubs - enlarge subRE vector
^ static void moresubs(struct vars *, int);
*/
static void
moresubs(
struct vars *v,
int wanted) /* want enough room for this one */
{
struct subre **p;
int n;
assert(wanted > 0 && wanted >= v->nsubs);
n = wanted * 3 / 2 + 1;
if (v->subs == v->sub10) {
|
| ︙ | ︙ | |||
507 508 509 510 511 512 513 |
^ static int freev(struct vars *, int);
*/
static int
freev(
struct vars *v,
int err)
{
| | | 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 |
^ static int freev(struct vars *, int);
*/
static int
freev(
struct vars *v,
int err)
{
int ret;
if (v->re != NULL) {
rfree(v->re);
}
if (v->subs != v->sub10) {
FREE(v->subs);
}
|
| ︙ | ︙ | |||
804 805 806 807 808 809 810 |
/*
* Initial bookkeeping.
*/
atom = NULL;
assert(lp->nouts == 0); /* must string new code */
assert(rp->nins == 0); /* between lp and rp */
| | | 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 |
/*
* Initial bookkeeping.
*/
atom = NULL;
assert(lp->nouts == 0); /* must string new code */
assert(rp->nins == 0); /* between lp and rp */
subno = 0;
/*
* An atom or constraint...
*/
atomtype = v->nexttype;
switch (atomtype) {
|
| ︙ | ︙ | |||
917 918 919 920 921 922 923 | } /* * Legal in EREs due to specification botch. */ NOTE(REG_UPBOTCH); | | | 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 |
}
/*
* Legal in EREs due to specification botch.
*/
NOTE(REG_UPBOTCH);
/* FALLTHRU */
case PLAIN:
onechr(v, v->nextvalue, lp, rp);
okcolors(v->nfa, v->cm);
NOERR();
NEXT();
break;
case '[':
|
| ︙ | ︙ | |||
1804 1805 1806 1807 1808 1809 1810 |
/* we're still parsing, maybe we can reuse the subre */
sr->left = v->treefree;
v->treefree = sr;
} else {
FREE(sr);
}
}
| < < < < < < < < < < < < < < < < < < < | 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 |
/* we're still parsing, maybe we can reuse the subre */
sr->left = v->treefree;
v->treefree = sr;
} else {
FREE(sr);
}
}
/*
- numst - number tree nodes (assigning "id" indexes)
^ static int numst(struct subre *, int);
*/
static int /* next number */
numst(
|
| ︙ | ︙ | |||
2080 2081 2082 2083 2084 2085 2086 |
g = (struct guts *) re->re_guts;
if (g->magic != GUTSMAGIC) {
fprintf(f, "bad guts magic number (0x%x not 0x%x)\n",
g->magic, GUTSMAGIC);
}
fprintf(f, "\n\n\n========= DUMP ==========\n");
| | | > > > | 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 |
g = (struct guts *) re->re_guts;
if (g->magic != GUTSMAGIC) {
fprintf(f, "bad guts magic number (0x%x not 0x%x)\n",
g->magic, GUTSMAGIC);
}
fprintf(f, "\n\n\n========= DUMP ==========\n");
fprintf(f, "nsub %d, info 0%lo, csize %d, ntree %d\n",
(int) re->re_nsub, re->re_info, re->re_csize, g->ntree);
dumpcolors(&g->cmap, f);
if (!NULLCNFA(g->search)) {
fprintf(f, "\nsearch:\n");
dumpcnfa(&g->search, f);
}
for (i = 1; i < g->nlacons; i++) {
fprintf(f, "\nla%d (%s):\n", i,
(g->lacons[i].subno) ? "positive" : "negative");
dumpcnfa(&g->lacons[i].cnfa, f);
}
fprintf(f, "\n");
dumpst(g->tree, f, 0);
#else
(void)re;
(void)f;
#endif
}
/*
- dumpst - dump a subRE tree
^ static void dumpst(struct subre *, FILE *, int);
*/
|
| ︙ | ︙ |
Changes to generic/regcustom.h.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 | #include "regex.h" /* * Overrides for regguts.h definitions, if any. */ | | | | > > > > | | | | 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 | #include "regex.h" /* * Overrides for regguts.h definitions, if any. */ #define MALLOC(n) (void*)(attemptckalloc(n)) #define FREE(p) ckfree((void*)(p)) #define REALLOC(p,n) (void*)(attemptckrealloc((void*)(p),n)) /* * Do not insert extras between the "begin" and "end" lines - this chunk is * automatically extracted to be fitted into regex.h. */ /* --- begin --- */ /* Ensure certain things don't sneak in from system headers. */ #ifdef __REG_WIDE_T #undef __REG_WIDE_T #endif #ifdef __REG_WIDE_COMPILE #undef __REG_WIDE_COMPILE #endif #ifdef __REG_WIDE_EXEC #undef __REG_WIDE_EXEC #endif #ifdef __REG_REGOFF_T #undef __REG_REGOFF_T #endif #ifdef __REG_NOFRONT #undef __REG_NOFRONT #endif #ifdef __REG_NOCHAR #undef __REG_NOCHAR #endif /* Interface types */ #define __REG_WIDE_T Tcl_UniChar #define __REG_REGOFF_T long /* Not really right, but good enough... */ /* Names and declarations */ #define __REG_WIDE_COMPILE TclReComp #define __REG_WIDE_EXEC TclReExec #define __REG_NOFRONT /* Don't want regcomp() and regexec() */ #define __REG_NOCHAR /* Or the char versions */ #define regfree TclReFree #define regerror TclReError /* --- end --- */ /* * Internal character type and related. */ typedef Tcl_UniChar chr; /* The type itself. */ typedef int pchr; /* What it promotes to. */ typedef unsigned uchr; /* Unsigned type that will hold a chr. */ typedef int celt; /* Type to hold chr, or NOCELT */ #define NOCELT (-1) /* Celt value which is not valid chr */ #define CHR(c) (UCHAR(c)) /* Turn char literal into chr literal */ #define DIGITVAL(c) ((c)-'0') /* Turn chr digit into its value */ #if TCL_UTF_MAX > 3 #define CHRBITS 32 /* Bits in a chr; must not use sizeof */ #define CHR_MIN 0x00000000 /* Smallest and largest chr; the value */ #define CHR_MAX 0x10FFFF /* CHR_MAX-CHR_MIN+1 should fit in uchr */ #else #define CHRBITS 16 /* Bits in a chr; must not use sizeof */ #define CHR_MIN 0x0000 /* Smallest and largest chr; the value */ #define CHR_MAX 0xFFFF /* CHR_MAX-CHR_MIN+1 should fit in uchr */ #endif /* * Functions operating on chr. */ #define iscalnum(x) Tcl_UniCharIsAlnum(x) |
| ︙ | ︙ | |||
123 124 125 126 127 128 129 |
* space to store this because the regular expression engine is never
* reentered from the same thread; it doesn't make any callbacks.
*/
#if 1
#define AllocVars(vPtr) \
static Tcl_ThreadDataKey varsKey; \
| | | | 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 |
* space to store this because the regular expression engine is never
* reentered from the same thread; it doesn't make any callbacks.
*/
#if 1
#define AllocVars(vPtr) \
static Tcl_ThreadDataKey varsKey; \
struct vars *vPtr = (struct vars *) \
Tcl_GetThreadData(&varsKey, sizeof(struct vars))
#else
/*
* This strategy for allocating workspace is "more proper" in some sense, but
* quite a bit slower. Using TSD (as above) leads to code that is quite a bit
* faster in practice (measured!)
*/
#define AllocVars(vPtr) \
struct vars *vPtr = (struct vars *) MALLOC(sizeof(struct vars))
#define FreeVars(vPtr) \
FREE(vPtr)
#endif
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/regerror.c.
| ︙ | ︙ | |||
50 51 52 53 54 55 56 |
#include "regerrs.h"
{ -1, "", "oops" }, /* explanation special-cased in code */
};
/*
- regerror - the interface to error numbers
*/
| < < | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 |
#include "regerrs.h"
{ -1, "", "oops" }, /* explanation special-cased in code */
};
/*
- regerror - the interface to error numbers
*/
size_t /* Actual space needed (including NUL) */
regerror(
int code, /* Error code, or REG_ATOI or REG_ITOA */
char *errbuf, /* Result buffer (unless errbuf_size==0) */
size_t errbuf_size) /* Available space in errbuf, can be 0 */
{
const struct rerr *r;
const char *msg;
char convbuf[sizeof(unk)+50]; /* 50 = plenty for int */
size_t len;
|
| ︙ | ︙ | |||
84 85 86 87 88 89 90 |
if (r->code == icode) {
break;
}
}
if (r->code >= 0) {
msg = r->name;
} else { /* Unknown; tell him the number */
| | | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 |
if (r->code == icode) {
break;
}
}
if (r->code >= 0) {
msg = r->name;
} else { /* Unknown; tell him the number */
sprintf(convbuf, "REG_%u", (unsigned)icode);
msg = convbuf;
}
break;
default: /* A real, normal error code */
for (r = rerrs; r->code >= 0; r++) {
if (r->code == code) {
break;
|
| ︙ | ︙ |
Changes to generic/regex.h.
| ︙ | ︙ | |||
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 |
#endif
#ifdef __REG_WIDE_COMPILE
#undef __REG_WIDE_COMPILE
#endif
#ifdef __REG_WIDE_EXEC
#undef __REG_WIDE_EXEC
#endif
#ifdef __REG_NOFRONT
#undef __REG_NOFRONT
#endif
#ifdef __REG_NOCHAR
#undef __REG_NOCHAR
#endif
/* interface types */
#define __REG_WIDE_T Tcl_UniChar
/* names and declarations */
#define __REG_WIDE_COMPILE TclReComp
#define __REG_WIDE_EXEC TclReExec
#define __REG_NOFRONT /* don't want regcomp() and regexec() */
#define __REG_NOCHAR /* or the char versions */
#define regfree TclReFree
#define regerror TclReError
/* --- end --- */
/*
* interface types etc.
*/
/*
* other interface types
*/
/* the biggie, a compiled RE (or rather, a front end to same) */
typedef struct {
int re_magic; /* magic number */
| > > > > > > > > > > > > > > > < > > | | | | | 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 |
#endif
#ifdef __REG_WIDE_COMPILE
#undef __REG_WIDE_COMPILE
#endif
#ifdef __REG_WIDE_EXEC
#undef __REG_WIDE_EXEC
#endif
#ifdef __REG_REGOFF_T
#undef __REG_REGOFF_T
#endif
#ifdef __REG_NOFRONT
#undef __REG_NOFRONT
#endif
#ifdef __REG_NOCHAR
#undef __REG_NOCHAR
#endif
/* interface types */
#define __REG_WIDE_T Tcl_UniChar
#define __REG_REGOFF_T long /* not really right, but good enough... */
/* names and declarations */
#define __REG_WIDE_COMPILE TclReComp
#define __REG_WIDE_EXEC TclReExec
#define __REG_NOFRONT /* don't want regcomp() and regexec() */
#define __REG_NOCHAR /* or the char versions */
#define regfree TclReFree
#define regerror TclReError
/* --- end --- */
/*
* interface types etc.
*/
/*
* regoff_t has to be large enough to hold either off_t or ssize_t, and must
* be signed; it's only a guess that long is suitable, so we offer
* <sys/types.h> an override.
*/
#ifdef __REG_REGOFF_T
typedef __REG_REGOFF_T regoff_t;
#else
typedef long regoff_t;
#endif
/*
* other interface types
*/
/* the biggie, a compiled RE (or rather, a front end to same) */
typedef struct {
int re_magic; /* magic number */
size_t re_nsub; /* number of subexpressions */
long re_info; /* information about RE */
#define REG_UBACKREF 000001
#define REG_ULOOKAHEAD 000002
#define REG_UBOUNDS 000004
#define REG_UBRACES 000010
#define REG_UBSALNUM 000020
#define REG_UPBOTCH 000040
#define REG_UBBS 000100
#define REG_UNONPOSIX 000200
#define REG_UUNSPEC 000400
#define REG_UUNPORT 001000
#define REG_ULOCALE 002000
#define REG_UEMPTYMATCH 004000
#define REG_UIMPOSSIBLE 010000
#define REG_USHORTEST 020000
int re_csize; /* sizeof(character) */
char *re_endp; /* backward compatibility kludge */
/* the rest is opaque pointers to hidden innards */
void *re_guts;
void *re_fns;
} regex_t;
/* result reporting (may acquire more fields later) */
typedef struct {
regoff_t rm_so; /* start of substring */
regoff_t rm_eo; /* end of substring */
} regmatch_t;
/* supplementary control and reporting */
typedef struct {
regmatch_t rm_extend; /* see REG_EXPECT */
} rm_detail_t;
|
| ︙ | ︙ | |||
212 213 214 215 216 217 218 | * Be careful if modifying the list of error codes -- the table used by * regerror() is generated automatically from this file! * * Note that there is no wide-char variant of regerror at this time; what kind * of character is used for error reports is independent of what kind is used * in matching. * | | | 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 | * Be careful if modifying the list of error codes -- the table used by * regerror() is generated automatically from this file! * * Note that there is no wide-char variant of regerror at this time; what kind * of character is used for error reports is independent of what kind is used * in matching. * ^ extern size_t regerror(int, char *, size_t); */ #define REG_OKAY 0 /* no errors detected */ #define REG_NOMATCH 1 /* failed to match */ #define REG_BADPAT 2 /* invalid regexp */ #define REG_ECOLLATE 3 /* invalid collating element */ #define REG_ECTYPE 4 /* invalid character class */ #define REG_EESCAPE 5 /* invalid escape \ sequence */ |
| ︙ | ︙ | |||
263 264 265 266 267 268 269 | #ifndef __REG_NOFRONT int regexec(regex_t *, const char *, size_t, regmatch_t [], int); #endif #ifdef __REG_WIDE_T MODULE_SCOPE int __REG_WIDE_EXEC(regex_t *, const __REG_WIDE_T *, size_t, rm_detail_t *, size_t, regmatch_t [], int); #endif MODULE_SCOPE void regfree(regex_t *); | | | 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 | #ifndef __REG_NOFRONT int regexec(regex_t *, const char *, size_t, regmatch_t [], int); #endif #ifdef __REG_WIDE_T MODULE_SCOPE int __REG_WIDE_EXEC(regex_t *, const __REG_WIDE_T *, size_t, rm_detail_t *, size_t, regmatch_t [], int); #endif MODULE_SCOPE void regfree(regex_t *); MODULE_SCOPE size_t regerror(int, char *, size_t); /* automatically gathered by fwd; do not hand-edit */ /* =====^!^===== end forwards =====^!^===== */ /* * more C++ voodoo */ #ifdef __cplusplus |
| ︙ | ︙ |
Changes to generic/regexec.c.
| ︙ | ︙ | |||
87 88 89 90 91 92 93 |
struct smalldfa {
struct dfa dfa;
struct sset ssets[FEWSTATES*2];
unsigned statesarea[FEWSTATES*2 + WORK];
struct sset *outsarea[FEWSTATES*2 * FEWCOLORS];
struct arcp incarea[FEWSTATES*2 * FEWCOLORS];
};
| < | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 |
struct smalldfa {
struct dfa dfa;
struct sset ssets[FEWSTATES*2];
unsigned statesarea[FEWSTATES*2 + WORK];
struct sset *outsarea[FEWSTATES*2 * FEWCOLORS];
struct arcp incarea[FEWSTATES*2 * FEWCOLORS];
};
/*
* Internal variables, bundled for easy passing around.
*/
struct vars {
regex_t *re;
|
| ︙ | ︙ | |||
125 126 127 128 129 130 131 | /* =====^!^===== begin forwards =====^!^===== */ /* automatically gathered by fwd; do not hand-edit */ /* === regexec.c === */ int exec(regex_t *, const chr *, size_t, rm_detail_t *, size_t, regmatch_t [], int); static struct dfa *getsubdfa(struct vars *, struct subre *); static int simpleFind(struct vars *const, struct cnfa *const, struct colormap *const); static int complicatedFind(struct vars *const, struct cnfa *const, struct colormap *const); | | | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 | /* =====^!^===== begin forwards =====^!^===== */ /* automatically gathered by fwd; do not hand-edit */ /* === regexec.c === */ int exec(regex_t *, const chr *, size_t, rm_detail_t *, size_t, regmatch_t [], int); static struct dfa *getsubdfa(struct vars *, struct subre *); static int simpleFind(struct vars *const, struct cnfa *const, struct colormap *const); static int complicatedFind(struct vars *const, struct cnfa *const, struct colormap *const); static int complicatedFindLoop(struct vars *const, struct dfa *const, struct dfa *const, chr **const); static void zapallsubs(regmatch_t *const, const size_t); static void zaptreesubs(struct vars *const, struct subre *const); static void subset(struct vars *const, struct subre *const, chr *const, chr *const); static int cdissect(struct vars *, struct subre *, chr *, chr *); static int ccondissect(struct vars *, struct subre *, chr *, chr *); static int crevcondissect(struct vars *, struct subre *, chr *, chr *); static int cbrdissect(struct vars *, struct subre *, chr *, chr *); |
| ︙ | ︙ | |||
182 183 184 185 186 187 188 189 190 191 192 193 194 195 |
/*
* Sanity checks.
*/
if (re == NULL || string == NULL || re->re_magic != REMAGIC) {
FreeVars(v);
return REG_INVARG;
}
/*
* Setup.
*/
v->re = re;
| > > > > | 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 |
/*
* Sanity checks.
*/
if (re == NULL || string == NULL || re->re_magic != REMAGIC) {
FreeVars(v);
return REG_INVARG;
}
if (re->re_csize != sizeof(chr)) {
FreeVars(v);
return REG_MIXED;
}
/*
* Setup.
*/
v->re = re;
|
| ︙ | ︙ | |||
291 292 293 294 295 296 297 |
* The DFA will be freed by the cleanup step in exec().
*/
static struct dfa *
getsubdfa(struct vars * v,
struct subre * t)
{
if (v->subdfas[t->id] == NULL) {
| | | 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 |
* The DFA will be freed by the cleanup step in exec().
*/
static struct dfa *
getsubdfa(struct vars * v,
struct subre * t)
{
if (v->subdfas[t->id] == NULL) {
v->subdfas[t->id] = newDFA(v, &t->cnfa, &v->g->cmap, NULL);
if (ISERR())
return NULL;
}
return v->subdfas[t->id];
}
/*
|
| ︙ | ︙ | |||
426 427 428 429 430 431 432 |
d = newDFA(v, cnfa, cm, &v->dfa2);
if (ISERR()) {
assert(d == NULL);
freeDFA(s);
return v->err;
}
| | | < < | 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 |
d = newDFA(v, cnfa, cm, &v->dfa2);
if (ISERR()) {
assert(d == NULL);
freeDFA(s);
return v->err;
}
ret = complicatedFindLoop(v, d, s, &cold);
freeDFA(d);
freeDFA(s);
NOERR();
if (v->g->cflags®_EXPECT) {
assert(v->details != NULL);
if (cold != NULL) {
v->details->rm_extend.rm_so = OFF(cold);
} else {
v->details->rm_extend.rm_so = OFF(v->stop);
}
v->details->rm_extend.rm_eo = OFF(v->stop); /* unknown */
}
return ret;
}
/*
- complicatedFindLoop - the heart of complicatedFind
^ static int complicatedFindLoop(struct vars *,
^ struct dfa *, struct dfa *, chr **);
*/
static int
complicatedFindLoop(
struct vars *const v,
struct dfa *const d,
struct dfa *const s,
chr **const coldp) /* where to put coldstart pointer */
{
chr *begin, *end;
chr *cold;
chr *open, *close; /* Open and close of range of possible
|
| ︙ | ︙ |
Changes to generic/regguts.h.
| ︙ | ︙ | |||
70 71 72 73 74 75 76 | */ #define NOTREACHED 0 #define DUPMAX _POSIX2_RE_DUP_MAX #define DUPINF (DUPMAX+1) | | | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 |
*/
#define NOTREACHED 0
#define DUPMAX _POSIX2_RE_DUP_MAX
#define DUPINF (DUPMAX+1)
#define REMAGIC 0xFED7 /* magic number for main struct */
/*
* debugging facilities
*/
#ifdef REG_DEBUG
/* FDEBUG does finite-state tracing */
#define FDEBUG(arglist) { if (v->eflags®_FTRACE) printf arglist; }
|
| ︙ | ︙ | |||
386 387 388 389 390 391 392 |
/*
* the insides of a regex_t, hidden behind a void *
*/
struct guts {
int magic;
| | | | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 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 |
/*
* the insides of a regex_t, hidden behind a void *
*/
struct guts {
int magic;
#define GUTSMAGIC 0xFED9
int cflags; /* copy of compile flags */
long info; /* copy of re_info */
size_t nsub; /* copy of re_nsub */
struct subre *tree;
struct cnfa search; /* for fast preliminary search */
int ntree; /* number of subre's, plus one */
struct colormap cmap;
int (*compare) (const chr *, const chr *, size_t);
struct subre *lacons; /* lookahead-constraint vector */
int nlacons; /* size of lacons */
};
/*
* Magic for allocating a variable workspace. This default version is
* stack-hungry.
*/
#ifndef AllocVars
#define AllocVars(vPtr) \
struct vars var; \
struct vars *vPtr = &var
#endif
#ifndef FreeVars
#define FreeVars(vPtr) ((void) 0)
#endif
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tcl.decls.
| ︙ | ︙ | |||
36 37 38 39 40 41 42 |
const char *name, const char *version, int exact,
void *clientDataPtr)
}
declare 2 {
TCL_NORETURN void Tcl_Panic(const char *format, ...)
}
declare 3 {
| | | | | | | | | < | | < > | < | | < > | < | | < > < | | | < > | | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 |
const char *name, const char *version, int exact,
void *clientDataPtr)
}
declare 2 {
TCL_NORETURN void Tcl_Panic(const char *format, ...)
}
declare 3 {
char *Tcl_Alloc(unsigned int size)
}
declare 4 {
void Tcl_Free(char *ptr)
}
declare 5 {
char *Tcl_Realloc(char *ptr, unsigned int size)
}
declare 6 {
char *Tcl_DbCkalloc(unsigned int size, const char *file, int line)
}
declare 7 {
void Tcl_DbCkfree(char *ptr, const char *file, int line)
}
declare 8 {
char *Tcl_DbCkrealloc(char *ptr, unsigned int size,
const char *file, int line)
}
# Tcl_CreateFileHandler and Tcl_DeleteFileHandler are only available on unix,
# but they are part of the old generic interface, so we include them here for
# compatibility reasons.
declare 9 unix {
void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc,
ClientData clientData)
}
declare 10 unix {
void Tcl_DeleteFileHandler(int fd)
}
declare 11 {
void Tcl_SetTimer(const Tcl_Time *timePtr)
}
declare 12 {
void Tcl_Sleep(int ms)
}
declare 13 {
int Tcl_WaitForEvent(const Tcl_Time *timePtr)
}
declare 14 {
int Tcl_AppendAllObjTypes(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 15 {
void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...)
}
declare 16 {
void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, int length)
}
declare 17 {
Tcl_Obj *Tcl_ConcatObj(int objc, Tcl_Obj *const objv[])
}
declare 18 {
int Tcl_ConvertToType(Tcl_Interp *interp, Tcl_Obj *objPtr,
const Tcl_ObjType *typePtr)
}
declare 19 {
void Tcl_DbDecrRefCount(Tcl_Obj *objPtr, const char *file, int line)
}
declare 20 {
void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, int line)
}
declare 21 {
int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line)
}
declare 22 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_DbNewBooleanObj(int boolValue, const char *file, int line)
}
declare 23 {
Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, int length,
const char *file, int line)
}
declare 24 {
Tcl_Obj *Tcl_DbNewDoubleObj(double doubleValue, const char *file,
int line)
}
declare 25 {
Tcl_Obj *Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv,
const char *file, int line)
}
declare 26 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_DbNewLongObj(long longValue, const char *file, int line)
}
declare 27 {
Tcl_Obj *Tcl_DbNewObj(const char *file, int line)
}
declare 28 {
Tcl_Obj *Tcl_DbNewStringObj(const char *bytes, int length,
const char *file, int line)
}
declare 29 {
Tcl_Obj *Tcl_DuplicateObj(Tcl_Obj *objPtr)
}
declare 30 {
void TclFreeObj(Tcl_Obj *objPtr)
}
declare 31 {
int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *boolPtr)
}
declare 32 {
int Tcl_GetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
int *boolPtr)
}
declare 33 {
unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *lengthPtr)
}
declare 34 {
int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr)
}
declare 35 {
int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
double *doublePtr)
}
declare 36 {deprecated {No longer in use, changed to macro}} {
int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
const char *const *tablePtr, const char *msg, int flags, int *indexPtr)
}
declare 37 {
int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr)
}
declare 38 {
int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr)
}
declare 39 {
int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr)
}
declare 40 {
CONST86 Tcl_ObjType *Tcl_GetObjType(const char *typeName)
}
declare 41 {
char *Tcl_GetStringFromObj(Tcl_Obj *objPtr, int *lengthPtr)
}
declare 42 {
void Tcl_InvalidateStringRep(Tcl_Obj *objPtr)
}
|
| ︙ | ︙ | |||
198 199 200 201 202 203 204 |
int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
int *lengthPtr)
}
declare 48 {
int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first,
int count, int objc, Tcl_Obj *const objv[])
}
| < | | < > | < | | < > < | | < > | < | | < > | | < | | < > < | | < > | | < | | < < > | | | < > | < | | < < > | | < > | | | | | | | | | | < | | | | < > | | | | | | | | | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 |
int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr,
int *lengthPtr)
}
declare 48 {
int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first,
int count, int objc, Tcl_Obj *const objv[])
}
declare 49 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_NewBooleanObj(int boolValue)
}
declare 50 {
Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, int length)
}
declare 51 {
Tcl_Obj *Tcl_NewDoubleObj(double doubleValue)
}
declare 52 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_NewIntObj(int intValue)
}
declare 53 {
Tcl_Obj *Tcl_NewListObj(int objc, Tcl_Obj *const objv[])
}
declare 54 {deprecated {No longer in use, changed to macro}} {
Tcl_Obj *Tcl_NewLongObj(long longValue)
}
declare 55 {
Tcl_Obj *Tcl_NewObj(void)
}
declare 56 {
Tcl_Obj *Tcl_NewStringObj(const char *bytes, int length)
}
declare 57 {deprecated {No longer in use, changed to macro}} {
void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue)
}
declare 58 {
unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length)
}
declare 59 {
void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes,
int length)
}
declare 60 {
void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue)
}
declare 61 {deprecated {No longer in use, changed to macro}} {
void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue)
}
declare 62 {
void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[])
}
declare 63 {deprecated {No longer in use, changed to macro}} {
void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue)
}
declare 64 {
void Tcl_SetObjLength(Tcl_Obj *objPtr, int length)
}
declare 65 {
void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length)
}
declare 66 {deprecated {No longer in use, changed to macro}} {
void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message)
}
declare 67 {deprecated {No longer in use, changed to macro}} {
void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message,
int length)
}
declare 68 {
void Tcl_AllowExceptions(Tcl_Interp *interp)
}
declare 69 {
void Tcl_AppendElement(Tcl_Interp *interp, const char *element)
}
declare 70 {
void Tcl_AppendResult(Tcl_Interp *interp, ...)
}
declare 71 {
Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc,
ClientData clientData)
}
declare 72 {
void Tcl_AsyncDelete(Tcl_AsyncHandler async)
}
declare 73 {
int Tcl_AsyncInvoke(Tcl_Interp *interp, int code)
}
declare 74 {
void Tcl_AsyncMark(Tcl_AsyncHandler async)
}
declare 75 {
int Tcl_AsyncReady(void)
}
declare 76 {deprecated {No longer in use, changed to macro}} {
void Tcl_BackgroundError(Tcl_Interp *interp)
}
declare 77 {deprecated {Use Tcl_UtfBackslash}} {
char Tcl_Backslash(const char *src, int *readPtr)
}
declare 78 {
int Tcl_BadChannelOption(Tcl_Interp *interp, const char *optionName,
const char *optionList)
}
declare 79 {
void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc,
ClientData clientData)
}
declare 80 {
void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, ClientData clientData)
}
declare 81 {
int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 82 {
int Tcl_CommandComplete(const char *cmd)
}
declare 83 {
char *Tcl_Concat(int argc, const char *const *argv)
}
declare 84 {
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 *slave, const char *slaveCmd,
Tcl_Interp *target, const char *targetCmd, int argc,
const char *const *argv)
}
declare 87 {
int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd,
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)
}
declare 89 {
void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask,
Tcl_ChannelProc *proc, ClientData clientData)
}
declare 90 {
void Tcl_CreateCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc,
ClientData clientData)
}
declare 91 {
Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp, const char *cmdName,
Tcl_CmdProc *proc, ClientData clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 92 {
void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc,
Tcl_EventCheckProc *checkProc, ClientData clientData)
}
declare 93 {
void Tcl_CreateExitHandler(Tcl_ExitProc *proc, ClientData clientData)
}
declare 94 {
Tcl_Interp *Tcl_CreateInterp(void)
}
declare 95 {deprecated {}} {
void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name,
int numArgs, Tcl_ValueType *argTypes,
Tcl_MathProc *proc, ClientData clientData)
}
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_CreateSlave(Tcl_Interp *interp, const char *slaveName,
int isSafe)
}
declare 98 {
Tcl_TimerToken Tcl_CreateTimerHandler(int milliseconds,
Tcl_TimerProc *proc, ClientData clientData)
}
declare 99 {
Tcl_Trace Tcl_CreateTrace(Tcl_Interp *interp, int level,
Tcl_CmdTraceProc *proc, ClientData clientData)
}
declare 100 {
void Tcl_DeleteAssocData(Tcl_Interp *interp, const char *name)
}
declare 101 {
void Tcl_DeleteChannelHandler(Tcl_Channel chan, Tcl_ChannelProc *proc,
ClientData clientData)
}
declare 102 {
void Tcl_DeleteCloseHandler(Tcl_Channel chan, Tcl_CloseProc *proc,
ClientData clientData)
}
declare 103 {
int Tcl_DeleteCommand(Tcl_Interp *interp, const char *cmdName)
}
declare 104 {
int Tcl_DeleteCommandFromToken(Tcl_Interp *interp, Tcl_Command command)
}
declare 105 {
void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc, ClientData clientData)
}
declare 106 {
void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc,
Tcl_EventCheckProc *checkProc, ClientData clientData)
}
declare 107 {
void Tcl_DeleteExitHandler(Tcl_ExitProc *proc, ClientData clientData)
}
declare 108 {
void Tcl_DeleteHashEntry(Tcl_HashEntry *entryPtr)
}
declare 109 {
void Tcl_DeleteHashTable(Tcl_HashTable *tablePtr)
}
|
| ︙ | ︙ | |||
433 434 435 436 437 438 439 |
void Tcl_DeleteTimerHandler(Tcl_TimerToken token)
}
declare 113 {
void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace)
}
declare 114 {
void Tcl_DontCallWhenDeleted(Tcl_Interp *interp,
| | | | | < | | < > < | | < > | | 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 |
void Tcl_DeleteTimerHandler(Tcl_TimerToken token)
}
declare 113 {
void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace)
}
declare 114 {
void Tcl_DontCallWhenDeleted(Tcl_Interp *interp,
Tcl_InterpDeleteProc *proc, ClientData clientData)
}
declare 115 {
int Tcl_DoOneEvent(int flags)
}
declare 116 {
void Tcl_DoWhenIdle(Tcl_IdleProc *proc, ClientData clientData)
}
declare 117 {
char *Tcl_DStringAppend(Tcl_DString *dsPtr, const char *bytes, int length)
}
declare 118 {
char *Tcl_DStringAppendElement(Tcl_DString *dsPtr, const char *element)
}
declare 119 {
void Tcl_DStringEndSublist(Tcl_DString *dsPtr)
}
declare 120 {
void Tcl_DStringFree(Tcl_DString *dsPtr)
}
declare 121 {
void Tcl_DStringGetResult(Tcl_Interp *interp, Tcl_DString *dsPtr)
}
declare 122 {
void Tcl_DStringInit(Tcl_DString *dsPtr)
}
declare 123 {
void Tcl_DStringResult(Tcl_Interp *interp, Tcl_DString *dsPtr)
}
declare 124 {
void Tcl_DStringSetLength(Tcl_DString *dsPtr, int length)
}
declare 125 {
void Tcl_DStringStartSublist(Tcl_DString *dsPtr)
}
declare 126 {
int Tcl_Eof(Tcl_Channel chan)
}
declare 127 {
const char *Tcl_ErrnoId(void)
}
declare 128 {
const char *Tcl_ErrnoMsg(int err)
}
declare 129 {
int Tcl_Eval(Tcl_Interp *interp, const char *script)
}
declare 130 {
int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName)
}
declare 131 {deprecated {No longer in use, changed to macro}} {
int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 132 {
void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc)
}
declare 133 {
TCL_NORETURN void Tcl_Exit(int status)
}
declare 134 {
int Tcl_ExposeCommand(Tcl_Interp *interp, const char *hiddenCmdToken,
const char *cmdName)
|
| ︙ | ︙ | |||
526 527 528 529 530 531 532 |
}
declare 142 {
int Tcl_ExprString(Tcl_Interp *interp, const char *expr)
}
declare 143 {
void Tcl_Finalize(void)
}
| < | | < > | | | | | | 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 |
}
declare 142 {
int Tcl_ExprString(Tcl_Interp *interp, const char *expr)
}
declare 143 {
void Tcl_Finalize(void)
}
declare 144 {nostub {Don't use this function in a stub-enabled extension}} {
void Tcl_FindExecutable(const char *argv0)
}
declare 145 {
Tcl_HashEntry *Tcl_FirstHashEntry(Tcl_HashTable *tablePtr,
Tcl_HashSearch *searchPtr)
}
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 *slaveCmd,
Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
int *argcPtr, const char ***argvPtr)
}
declare 149 {
int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd,
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)
}
declare 151 {
Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, const char *chanName,
int *modePtr)
}
declare 152 {
int Tcl_GetChannelBufferSize(Tcl_Channel chan)
}
declare 153 {
int Tcl_GetChannelHandle(Tcl_Channel chan, int direction,
ClientData *handlePtr)
}
declare 154 {
ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan)
}
declare 155 {
int Tcl_GetChannelMode(Tcl_Channel chan)
}
declare 156 {
const char *Tcl_GetChannelName(Tcl_Channel chan)
}
declare 157 {
int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan,
const char *optionName, Tcl_DString *dsPtr)
}
declare 158 {
CONST86 Tcl_ChannelType *Tcl_GetChannelType(Tcl_Channel chan)
}
declare 159 {
int Tcl_GetCommandInfo(Tcl_Interp *interp, const char *cmdName,
Tcl_CmdInfo *infoPtr)
}
declare 160 {
const char *Tcl_GetCommandName(Tcl_Interp *interp,
|
| ︙ | ︙ | |||
609 610 611 612 613 614 615 |
const char *Tcl_GetNameOfExecutable(void)
}
declare 166 {
Tcl_Obj *Tcl_GetObjResult(Tcl_Interp *interp)
}
# Tcl_GetOpenFile is only available on unix, but it is a part of the old
| | | | | < | | < < > | | | < > < | | < < > | | < > | 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 |
const char *Tcl_GetNameOfExecutable(void)
}
declare 166 {
Tcl_Obj *Tcl_GetObjResult(Tcl_Interp *interp)
}
# Tcl_GetOpenFile is only available on unix, but it is a part of the old
# generic interface, so we include it here for compatibility reasons.
declare 167 unix {
int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting,
int checkUsage, ClientData *filePtr)
}
# Obsolete. Should now use Tcl_FSGetPathType which is objectified
# and therefore usually faster.
declare 168 {
Tcl_PathType Tcl_GetPathType(const char *path)
}
declare 169 {
int Tcl_Gets(Tcl_Channel chan, Tcl_DString *dsPtr)
}
declare 170 {
int Tcl_GetsObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 171 {
int Tcl_GetServiceMode(void)
}
declare 172 {
Tcl_Interp *Tcl_GetSlave(Tcl_Interp *interp, const char *slaveName)
}
declare 173 {
Tcl_Channel Tcl_GetStdChannel(int type)
}
declare 174 {
const char *Tcl_GetStringResult(Tcl_Interp *interp)
}
declare 175 {deprecated {No longer in use, changed to macro}} {
const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName,
int flags)
}
declare 176 {
const char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags)
}
declare 177 {
int Tcl_GlobalEval(Tcl_Interp *interp, const char *command)
}
declare 178 {deprecated {No longer in use, changed to macro}} {
int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 179 {
int Tcl_HideCommand(Tcl_Interp *interp, const char *cmdName,
const char *hiddenCmdToken)
}
declare 180 {
int Tcl_Init(Tcl_Interp *interp)
}
|
| ︙ | ︙ | |||
694 695 696 697 698 699 700 |
# This slot is reserved for use by the plus patch:
# declare 188 {
# Tcl_MainLoop
# }
declare 189 {
| | | | 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 |
# This slot is reserved for use by the plus patch:
# declare 188 {
# Tcl_MainLoop
# }
declare 189 {
Tcl_Channel Tcl_MakeFileChannel(ClientData handle, int mode)
}
declare 190 {
int Tcl_MakeSafe(Tcl_Interp *interp)
}
declare 191 {
Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket)
}
declare 192 {
char *Tcl_Merge(int argc, const char *const *argv)
}
declare 193 {
Tcl_HashEntry *Tcl_NextHashEntry(Tcl_HashSearch *searchPtr)
}
|
| ︙ | ︙ | |||
735 736 737 738 739 740 741 |
declare 199 {
Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port,
const char *address, const char *myaddr, int myport, int async)
}
declare 200 {
Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port,
const char *host, Tcl_TcpAcceptProc *acceptProc,
| | | | | 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 |
declare 199 {
Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port,
const char *address, const char *myaddr, int myport, int async)
}
declare 200 {
Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port,
const char *host, Tcl_TcpAcceptProc *acceptProc,
ClientData callbackData)
}
declare 201 {
void Tcl_Preserve(ClientData data)
}
declare 202 {
void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst)
}
declare 203 {
int Tcl_PutEnv(const char *assignment)
}
declare 204 {
const char *Tcl_PosixError(Tcl_Interp *interp)
}
declare 205 {
void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position)
}
declare 206 {
int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead)
}
declare 207 {
void Tcl_ReapDetachedProcs(void)
}
declare 208 {
int Tcl_RecordAndEval(Tcl_Interp *interp, const char *cmd, int flags)
}
|
| ︙ | ︙ | |||
782 783 784 785 786 787 788 |
const char *text, const char *start)
}
declare 214 {
int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text,
const char *pattern)
}
declare 215 {
| | | | | < | | < > | | 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 |
const char *text, const char *start)
}
declare 214 {
int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text,
const char *pattern)
}
declare 215 {
void Tcl_RegExpRange(Tcl_RegExp regexp, int index,
const char **startPtr, const char **endPtr)
}
declare 216 {
void Tcl_Release(ClientData clientData)
}
declare 217 {
void Tcl_ResetResult(Tcl_Interp *interp)
}
declare 218 {
int Tcl_ScanElement(const char *src, int *flagPtr)
}
declare 219 {
int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr)
}
declare 220 {deprecated {}} {
int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode)
}
declare 221 {
int Tcl_ServiceAll(void)
}
declare 222 {
int Tcl_ServiceEvent(int flags)
}
declare 223 {
void Tcl_SetAssocData(Tcl_Interp *interp, const char *name,
Tcl_InterpDeleteProc *proc, ClientData clientData)
}
declare 224 {
void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz)
}
declare 225 {
int Tcl_SetChannelOption(Tcl_Interp *interp, Tcl_Channel chan,
const char *optionName, const char *newValue)
|
| ︙ | ︙ | |||
831 832 833 834 835 836 837 |
}
declare 228 {
void Tcl_SetErrorCode(Tcl_Interp *interp, ...)
}
declare 229 {
void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr)
}
| < | | < > < | | | < > < | | | < > | 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 |
}
declare 228 {
void Tcl_SetErrorCode(Tcl_Interp *interp, ...)
}
declare 229 {
void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr)
}
declare 230 {nostub {Don't use this function in a stub-enabled extension}} {
void Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc)
}
declare 231 {
int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth)
}
declare 232 {
void Tcl_SetResult(Tcl_Interp *interp, char *result,
Tcl_FreeProc *freeProc)
}
declare 233 {
int Tcl_SetServiceMode(int mode)
}
declare 234 {
void Tcl_SetObjErrorCode(Tcl_Interp *interp, Tcl_Obj *errorObjPtr)
}
declare 235 {
void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr)
}
declare 236 {
void Tcl_SetStdChannel(Tcl_Channel channel, int type)
}
declare 237 {deprecated {No longer in use, changed to macro}} {
const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName,
const char *newValue, int flags)
}
declare 238 {
const char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, const char *newValue, int flags)
}
declare 239 {
const char *Tcl_SignalId(int sig)
}
|
| ︙ | ︙ | |||
881 882 883 884 885 886 887 |
int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr,
const char ***argvPtr)
}
# Obsolete, use Tcl_FSSplitPath
declare 243 {
void Tcl_SplitPath(const char *path, int *argcPtr, const char ***argvPtr)
}
| < | | | < < > | | < < > | | < < > | | | < > | | < | | < > < | | | < > | < | | | < > < | | | < > | | | < | | < < > | | < > < | | | < > < | | | < > < | | | < < > | | < < > | | < > < | | < > | 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 |
int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr,
const char ***argvPtr)
}
# Obsolete, use Tcl_FSSplitPath
declare 243 {
void Tcl_SplitPath(const char *path, int *argcPtr, const char ***argvPtr)
}
declare 244 {nostub {Don't use this function in a stub-enabled extension}} {
void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName,
Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)
}
declare 245 {deprecated {No longer in use, changed to macro}} {
int Tcl_StringMatch(const char *str, const char *pattern)
}
declare 246 {deprecated {}} {
int Tcl_TellOld(Tcl_Channel chan)
}
declare 247 {deprecated {No longer in use, changed to macro}} {
int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags,
Tcl_VarTraceProc *proc, ClientData clientData)
}
declare 248 {
int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2,
int flags, Tcl_VarTraceProc *proc, ClientData clientData)
}
declare 249 {
char *Tcl_TranslateFileName(Tcl_Interp *interp, const char *name,
Tcl_DString *bufferPtr)
}
declare 250 {
int Tcl_Ungets(Tcl_Channel chan, const char *str, int len, int atHead)
}
declare 251 {
void Tcl_UnlinkVar(Tcl_Interp *interp, const char *varName)
}
declare 252 {
int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 253 {deprecated {No longer in use, changed to macro}} {
int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags)
}
declare 254 {
int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2,
int flags)
}
declare 255 {deprecated {No longer in use, changed to macro}} {
void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags,
Tcl_VarTraceProc *proc, ClientData clientData)
}
declare 256 {
void Tcl_UntraceVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags, Tcl_VarTraceProc *proc,
ClientData clientData)
}
declare 257 {
void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName)
}
declare 258 {deprecated {No longer in use, changed to macro}} {
int Tcl_UpVar(Tcl_Interp *interp, const char *frameName,
const char *varName, const char *localName, int flags)
}
declare 259 {
int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, const char *part1,
const char *part2, const char *localName, int flags)
}
declare 260 {
int Tcl_VarEval(Tcl_Interp *interp, ...)
}
declare 261 {deprecated {No longer in use, changed to macro}} {
ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName,
int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData)
}
declare 262 {
ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags, Tcl_VarTraceProc *procPtr,
ClientData prevClientData)
}
declare 263 {
int Tcl_Write(Tcl_Channel chan, const char *s, int slen)
}
declare 264 {
void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[], const char *message)
}
declare 265 {
int Tcl_DumpActiveMemory(const char *fileName)
}
declare 266 {
void Tcl_ValidateAllMemory(const char *file, int line)
}
declare 267 {deprecated {see TIP #422}} {
void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList)
}
declare 268 {deprecated {see TIP #422}} {
void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList)
}
declare 269 {
char *Tcl_HashStats(Tcl_HashTable *tablePtr)
}
declare 270 {
const char *Tcl_ParseVar(Tcl_Interp *interp, const char *start,
const char **termPtr)
}
declare 271 {deprecated {No longer in use, changed to macro}} {
const char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
const char *version, int exact)
}
declare 272 {
const char *Tcl_PkgPresentEx(Tcl_Interp *interp,
const char *name, const char *version, int exact,
void *clientDataPtr)
}
declare 273 {deprecated {No longer in use, changed to macro}} {
int Tcl_PkgProvide(Tcl_Interp *interp, const char *name,
const char *version)
}
# TIP #268: The internally used new Require function is in slot 573.
declare 274 {deprecated {No longer in use, changed to macro}} {
const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
const char *version, int exact)
}
declare 275 {deprecated {see TIP #422}} {
void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList)
}
declare 276 {deprecated {see TIP #422}} {
int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList)
}
declare 277 {
Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options)
}
declare 278 {deprecated {see TIP #422}} {
TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList)
}
declare 279 {
void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type)
}
declare 280 {
void Tcl_InitMemory(Tcl_Interp *interp)
}
|
| ︙ | ︙ | |||
1046 1047 1048 1049 1050 1051 1052 |
# to the alphabetical order used elsewhere in this file, but I decided
# against that to ease the maintenance of the patch across new tcl versions
# (patch usually has no problems to integrate the patch file for the last
# version into the new one).
declare 281 {
Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp,
| | | 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 |
# to the alphabetical order used elsewhere in this file, but I decided
# against that to ease the maintenance of the patch across new tcl versions
# (patch usually has no problems to integrate the patch file for the last
# version into the new one).
declare 281 {
Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp,
const Tcl_ChannelType *typePtr, ClientData instanceData,
int mask, Tcl_Channel prevChan)
}
declare 282 {
int Tcl_UnstackChannel(Tcl_Interp *interp, Tcl_Channel chan)
}
declare 283 {
Tcl_Channel Tcl_GetStackedChannel(Tcl_Channel chan)
|
| ︙ | ︙ | |||
1074 1075 1076 1077 1078 1079 1080 |
declare 286 {
void Tcl_AppendObjToObj(Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr)
}
declare 287 {
Tcl_Encoding Tcl_CreateEncoding(const Tcl_EncodingType *typePtr)
}
declare 288 {
| | | < | | < > | | | | | | | | | | | < | | < < > | | < > | | | | | | | | | | < | | < < > | | < > | | 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 |
declare 286 {
void Tcl_AppendObjToObj(Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr)
}
declare 287 {
Tcl_Encoding Tcl_CreateEncoding(const Tcl_EncodingType *typePtr)
}
declare 288 {
void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData)
}
declare 289 {
void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, ClientData clientData)
}
declare 290 {
void Tcl_DiscardResult(Tcl_SavedResult *statePtr)
}
declare 291 {
int Tcl_EvalEx(Tcl_Interp *interp, const char *script, int numBytes,
int flags)
}
declare 292 {
int Tcl_EvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
int flags)
}
declare 293 {
int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
}
declare 294 {
TCL_NORETURN void Tcl_ExitThread(int status)
}
declare 295 {
int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding,
const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)
}
declare 296 {
char *Tcl_ExternalToUtfDString(Tcl_Encoding encoding,
const char *src, int srcLen, Tcl_DString *dsPtr)
}
declare 297 {
void Tcl_FinalizeThread(void)
}
declare 298 {
void Tcl_FinalizeNotifier(ClientData clientData)
}
declare 299 {
void Tcl_FreeEncoding(Tcl_Encoding encoding)
}
declare 300 {
Tcl_ThreadId Tcl_GetCurrentThread(void)
}
declare 301 {
Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name)
}
declare 302 {
const char *Tcl_GetEncodingName(Tcl_Encoding encoding)
}
declare 303 {
void Tcl_GetEncodingNames(Tcl_Interp *interp)
}
declare 304 {
int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr,
const void *tablePtr, int offset, const char *msg, int flags,
int *indexPtr)
}
declare 305 {
void *Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr, int size)
}
declare 306 {
Tcl_Obj *Tcl_GetVar2Ex(Tcl_Interp *interp, const char *part1,
const char *part2, int flags)
}
declare 307 {
ClientData Tcl_InitNotifier(void)
}
declare 308 {
void Tcl_MutexLock(Tcl_Mutex *mutexPtr)
}
declare 309 {
void Tcl_MutexUnlock(Tcl_Mutex *mutexPtr)
}
declare 310 {
void Tcl_ConditionNotify(Tcl_Condition *condPtr)
}
declare 311 {
void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr,
const Tcl_Time *timePtr)
}
declare 312 {
int Tcl_NumUtfChars(const char *src, int length)
}
declare 313 {
int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead,
int appendFlag)
}
declare 314 {
void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
}
declare 315 {
void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr)
}
declare 316 {
int Tcl_SetSystemEncoding(Tcl_Interp *interp, const char *name)
}
declare 317 {
Tcl_Obj *Tcl_SetVar2Ex(Tcl_Interp *interp, const char *part1,
const char *part2, Tcl_Obj *newValuePtr, int flags)
}
declare 318 {
void Tcl_ThreadAlert(Tcl_ThreadId threadId)
}
declare 319 {
void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr,
Tcl_QueuePosition position)
}
declare 320 {
int Tcl_UniCharAtIndex(const char *src, int index)
}
declare 321 {
int Tcl_UniCharToLower(int ch)
}
declare 322 {
int Tcl_UniCharToTitle(int ch)
}
declare 323 {
int Tcl_UniCharToUpper(int ch)
}
declare 324 {
int Tcl_UniCharToUtf(int ch, char *buf)
}
declare 325 {
const char *Tcl_UtfAtIndex(const char *src, int index)
}
declare 326 {
int Tcl_UtfCharComplete(const char *src, int length)
}
declare 327 {
int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst)
}
declare 328 {
const char *Tcl_UtfFindFirst(const char *src, int ch)
}
declare 329 {
const char *Tcl_UtfFindLast(const char *src, int ch)
}
declare 330 {
const char *Tcl_UtfNext(const char *src)
}
declare 331 {
const char *Tcl_UtfPrev(const char *src, const char *start)
}
declare 332 {
int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding,
const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst, int dstLen,
int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr)
}
declare 333 {
char *Tcl_UtfToExternalDString(Tcl_Encoding encoding,
const char *src, int srcLen, Tcl_DString *dsPtr)
}
declare 334 {
int Tcl_UtfToLower(char *src)
}
declare 335 {
int Tcl_UtfToTitle(char *src)
}
declare 336 {
int Tcl_UtfToChar16(const char *src, unsigned short *chPtr)
}
declare 337 {
int Tcl_UtfToUpper(char *src)
}
declare 338 {
int Tcl_WriteChars(Tcl_Channel chan, const char *src, int srcLen)
}
declare 339 {
int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr)
}
declare 340 {
char *Tcl_GetString(Tcl_Obj *objPtr)
}
declare 341 {deprecated {Use Tcl_GetEncodingSearchPath}} {
const char *Tcl_GetDefaultEncodingDir(void)
}
declare 342 {deprecated {Use Tcl_SetEncodingSearchPath}} {
void Tcl_SetDefaultEncodingDir(const char *path)
}
declare 343 {
void Tcl_AlertNotifier(ClientData clientData)
}
declare 344 {
void Tcl_ServiceModeHook(int mode)
}
declare 345 {
int Tcl_UniCharIsAlnum(int ch)
}
|
| ︙ | ︙ | |||
1287 1288 1289 1290 1291 1292 1293 |
}
declare 350 {
int Tcl_UniCharIsUpper(int ch)
}
declare 351 {
int Tcl_UniCharIsWordChar(int ch)
}
| | | | | | | | | < | | | < > | | | < | | | | | | | | | | | | | < | | < > | | | | | | | | | | 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 |
}
declare 350 {
int Tcl_UniCharIsUpper(int ch)
}
declare 351 {
int Tcl_UniCharIsWordChar(int ch)
}
declare 352 {deprecated {Use Tcl_GetCharLength}} {
int Tcl_UniCharLen(const Tcl_UniChar *uniStr)
}
declare 353 {deprecated {Use Tcl_UtfNcmp}} {
int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct,
unsigned long numChars)
}
declare 354 {
char *Tcl_Char16ToUtfDString(const unsigned short *uniStr,
int uniLength, Tcl_DString *dsPtr)
}
declare 355 {
unsigned short *Tcl_UtfToChar16DString(const char *src,
int length, Tcl_DString *dsPtr)
}
declare 356 {
Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj,
int flags)
}
declare 357 {deprecated {Use Tcl_EvalTokensStandard}} {
Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
int count)
}
declare 358 {
void Tcl_FreeParse(Tcl_Parse *parsePtr)
}
declare 359 {
void Tcl_LogCommandInfo(Tcl_Interp *interp, const char *script,
const char *command, int length)
}
declare 360 {
int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, int numBytes,
Tcl_Parse *parsePtr, int append, const char **termPtr)
}
declare 361 {
int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, int numBytes,
int nested, Tcl_Parse *parsePtr)
}
declare 362 {
int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, int numBytes,
Tcl_Parse *parsePtr)
}
declare 363 {
int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start,
int numBytes, Tcl_Parse *parsePtr, int append,
const char **termPtr)
}
declare 364 {
int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, int numBytes,
Tcl_Parse *parsePtr, int append)
}
# These 4 functions are obsolete, use Tcl_FSGetCwd, Tcl_FSChdir,
# Tcl_FSAccess and Tcl_FSStat
declare 365 {
char *Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
declare 366 {
int Tcl_Chdir(const char *dirName)
}
declare 367 {
int Tcl_Access(const char *path, int mode)
}
declare 368 {
int Tcl_Stat(const char *path, struct stat *bufPtr)
}
declare 369 {
int Tcl_UtfNcmp(const char *s1, const char *s2, unsigned long n)
}
declare 370 {
int Tcl_UtfNcasecmp(const char *s1, const char *s2, unsigned long n)
}
declare 371 {
int Tcl_StringCaseMatch(const char *str, const char *pattern, int nocase)
}
declare 372 {
int Tcl_UniCharIsControl(int ch)
}
declare 373 {
int Tcl_UniCharIsGraph(int ch)
}
declare 374 {
int Tcl_UniCharIsPrint(int ch)
}
declare 375 {
int Tcl_UniCharIsPunct(int ch)
}
declare 376 {
int Tcl_RegExpExecObj(Tcl_Interp *interp, Tcl_RegExp regexp,
Tcl_Obj *textObj, int offset, int nmatches, int flags)
}
declare 377 {
void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr)
}
declare 378 {
Tcl_Obj *Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, int numChars)
}
declare 379 {
void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode,
int numChars)
}
declare 380 {
int Tcl_GetCharLength(Tcl_Obj *objPtr)
}
declare 381 {
int Tcl_GetUniChar(Tcl_Obj *objPtr, int index)
}
declare 382 {deprecated {No longer in use, changed to macro}} {
Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr)
}
declare 383 {
Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, int first, int last)
}
declare 384 {deprecated {Use Tcl_AppendStringsToObj}} {
void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode,
int length)
}
declare 385 {
int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj,
Tcl_Obj *patternObj)
}
declare 386 {
void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr)
}
declare 387 {
Tcl_Mutex *Tcl_GetAllocMutex(void)
}
declare 388 {
int Tcl_GetChannelNames(Tcl_Interp *interp)
}
declare 389 {
int Tcl_GetChannelNamesEx(Tcl_Interp *interp, const char *pattern)
}
declare 390 {
int Tcl_ProcObjCmd(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 391 {
void Tcl_ConditionFinalize(Tcl_Condition *condPtr)
}
declare 392 {
void Tcl_MutexFinalize(Tcl_Mutex *mutex)
}
declare 393 {
int Tcl_CreateThread(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc,
ClientData clientData, int stackSize, int flags)
}
# Introduced in 8.3.2
declare 394 {
int Tcl_ReadRaw(Tcl_Channel chan, char *dst, int bytesToRead)
}
declare 395 {
int Tcl_WriteRaw(Tcl_Channel chan, const char *src, int srcLen)
}
declare 396 {
Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan)
}
declare 397 {
int Tcl_ChannelBuffered(Tcl_Channel chan)
}
declare 398 {
const char *Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr)
}
declare 399 {
Tcl_ChannelTypeVersion Tcl_ChannelVersion(
const Tcl_ChannelType *chanTypePtr)
}
declare 400 {
Tcl_DriverBlockModeProc *Tcl_ChannelBlockModeProc(
const Tcl_ChannelType *chanTypePtr)
}
declare 401 {deprecated {Use Tcl_ChannelClose2Proc}} {
Tcl_DriverCloseProc *Tcl_ChannelCloseProc(
const Tcl_ChannelType *chanTypePtr)
}
declare 402 {
Tcl_DriverClose2Proc *Tcl_ChannelClose2Proc(
const Tcl_ChannelType *chanTypePtr)
}
declare 403 {
Tcl_DriverInputProc *Tcl_ChannelInputProc(
const Tcl_ChannelType *chanTypePtr)
}
declare 404 {
Tcl_DriverOutputProc *Tcl_ChannelOutputProc(
const Tcl_ChannelType *chanTypePtr)
}
declare 405 {deprecated {Use Tcl_ChannelWideSeekProc}} {
Tcl_DriverSeekProc *Tcl_ChannelSeekProc(
const Tcl_ChannelType *chanTypePtr)
}
declare 406 {
Tcl_DriverSetOptionProc *Tcl_ChannelSetOptionProc(
const Tcl_ChannelType *chanTypePtr)
}
|
| ︙ | ︙ | |||
1528 1529 1530 1531 1532 1533 1534 |
}
declare 417 {
void Tcl_ClearChannelHandlers(Tcl_Channel channel)
}
declare 418 {
int Tcl_IsChannelExisting(const char *channelName)
}
| | | | < | | < < > | | | < > | | | | | | | | | < | | | | < < > | | < > | 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 |
}
declare 417 {
void Tcl_ClearChannelHandlers(Tcl_Channel channel)
}
declare 418 {
int Tcl_IsChannelExisting(const char *channelName)
}
declare 419 {deprecated {Use Tcl_UtfNcasecmp}} {
int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct,
unsigned long numChars)
}
declare 420 {deprecated {Use Tcl_StringCaseMatch}} {
int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr,
const Tcl_UniChar *uniPattern, int nocase)
}
declare 421 {
Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key)
}
declare 422 {
Tcl_HashEntry *Tcl_CreateHashEntry(Tcl_HashTable *tablePtr,
const void *key, int *newPtr)
}
declare 423 {
void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, int keyType,
const Tcl_HashKeyType *typePtr)
}
declare 424 {
void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr)
}
declare 425 {
ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp, const char *varName,
int flags, Tcl_CommandTraceProc *procPtr,
ClientData prevClientData)
}
declare 426 {
int Tcl_TraceCommand(Tcl_Interp *interp, const char *varName, int flags,
Tcl_CommandTraceProc *proc, ClientData clientData)
}
declare 427 {
void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName,
int flags, Tcl_CommandTraceProc *proc, ClientData clientData)
}
declare 428 {
char *Tcl_AttemptAlloc(unsigned int size)
}
declare 429 {
char *Tcl_AttemptDbCkalloc(unsigned int size, const char *file, int line)
}
declare 430 {
char *Tcl_AttemptRealloc(char *ptr, unsigned int size)
}
declare 431 {
char *Tcl_AttemptDbCkrealloc(char *ptr, unsigned int size,
const char *file, int line)
}
declare 432 {
int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length)
}
# TIP#10 (thread-aware channels) akupries
declare 433 {
Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel)
}
# introduced in 8.4a3
declare 434 {
Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr)
}
# TIP#15 (math function introspection) dkf
declare 435 {deprecated {}} {
int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name,
int *numArgsPtr, Tcl_ValueType **argTypesPtr,
Tcl_MathProc **procPtr, ClientData *clientDataPtr)
}
declare 436 {deprecated {}} {
Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern)
}
# TIP#36 (better access to 'subst') dkf
declare 437 {
Tcl_Obj *Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
}
# TIP#17 (virtual filesystem layer) vdarley
|
| ︙ | ︙ | |||
1664 1665 1666 1667 1668 1669 1670 |
int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef)
}
declare 452 {
int Tcl_FSFileAttrsSet(Tcl_Interp *interp,
int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr)
}
declare 453 {
| | | 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 |
int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef)
}
declare 452 {
int Tcl_FSFileAttrsSet(Tcl_Interp *interp,
int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr)
}
declare 453 {
const char *CONST86 *Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr,
Tcl_Obj **objPtrRef)
}
declare 454 {
int Tcl_FSStat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf)
}
declare 455 {
int Tcl_FSAccess(Tcl_Obj *pathPtr, int mode)
|
| ︙ | ︙ | |||
1703 1704 1705 1706 1707 1708 1709 |
Tcl_Obj *Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr)
}
declare 464 {
Tcl_Obj *Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc,
Tcl_Obj *const objv[])
}
declare 465 {
| | | | | | | | | 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 |
Tcl_Obj *Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr)
}
declare 464 {
Tcl_Obj *Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc,
Tcl_Obj *const objv[])
}
declare 465 {
ClientData Tcl_FSGetInternalRep(Tcl_Obj *pathPtr,
const Tcl_Filesystem *fsPtr)
}
declare 466 {
Tcl_Obj *Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr)
}
declare 467 {
int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName)
}
declare 468 {
Tcl_Obj *Tcl_FSNewNativePath(const Tcl_Filesystem *fromFilesystem,
ClientData clientData)
}
declare 469 {
const void *Tcl_FSGetNativePath(Tcl_Obj *pathPtr)
}
declare 470 {
Tcl_Obj *Tcl_FSFileSystemInfo(Tcl_Obj *pathPtr)
}
declare 471 {
Tcl_Obj *Tcl_FSPathSeparator(Tcl_Obj *pathPtr)
}
declare 472 {
Tcl_Obj *Tcl_FSListVolumes(void)
}
declare 473 {
int Tcl_FSRegister(ClientData clientData, const Tcl_Filesystem *fsPtr)
}
declare 474 {
int Tcl_FSUnregister(const Tcl_Filesystem *fsPtr)
}
declare 475 {
ClientData Tcl_FSData(const Tcl_Filesystem *fsPtr)
}
declare 476 {
const char *Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp,
Tcl_Obj *pathPtr)
}
declare 477 {
CONST86 Tcl_Filesystem *Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr)
}
declare 478 {
Tcl_PathType Tcl_FSGetPathType(Tcl_Obj *pathPtr)
}
# TIP#49 (detection of output buffering) akupries
declare 479 {
int Tcl_OutputBuffered(Tcl_Channel chan)
}
declare 480 {
void Tcl_FSMountsChanged(const Tcl_Filesystem *fsPtr)
}
# TIP#56 (evaluate a parsed script) msofer
declare 481 {
int Tcl_EvalTokensStandard(Tcl_Interp *interp, Tcl_Token *tokenPtr,
int count)
}
# TIP#73 (access to current time) kbk
declare 482 {
void Tcl_GetTime(Tcl_Time *timeBuf)
}
# TIP#32 (object-enabled traces) kbk
declare 483 {
Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, int flags,
Tcl_CmdObjTraceProc *objProc, ClientData clientData,
Tcl_CmdObjTraceDeleteProc *delProc)
}
declare 484 {
int Tcl_GetCommandInfoFromToken(Tcl_Command token, Tcl_CmdInfo *infoPtr)
}
declare 485 {
int Tcl_SetCommandInfoFromToken(Tcl_Command token,
|
| ︙ | ︙ | |||
1868 1869 1870 1871 1872 1873 1874 |
const Tcl_Config *configuration, const char *valEncoding)
}
# TIP #139 (partial exposure of namespace API - transferred from tclInt.decls)
# dkf, API by Brent Welch?
declare 506 {
Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name,
| | | 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 |
const Tcl_Config *configuration, const char *valEncoding)
}
# TIP #139 (partial exposure of namespace API - transferred from tclInt.decls)
# dkf, API by Brent Welch?
declare 506 {
Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name,
ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc)
}
declare 507 {
void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr)
}
declare 508 {
int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
Tcl_Obj *objPtr)
|
| ︙ | ︙ | |||
1917 1918 1919 1920 1921 1922 1923 |
# TIP#137 (encoding-aware source command) dgp for Anton Kovalenko
declare 518 {
int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName,
const char *encodingName)
}
| | | | < > | | | 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 |
# TIP#137 (encoding-aware source command) dgp for Anton Kovalenko
declare 518 {
int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName,
const char *encodingName)
}
# TIP#121 (exit handler) dkf for Joe Mistachkin
declare 519 {nostub {Don't use this function in a stub-enabled extension}} {
Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc)
}
# TIP#143 (resource limits) dkf
declare 520 {
void Tcl_LimitAddHandler(Tcl_Interp *interp, int type,
Tcl_LimitHandlerProc *handlerProc, ClientData clientData,
Tcl_LimitHandlerDeleteProc *deleteProc)
}
declare 521 {
void Tcl_LimitRemoveHandler(Tcl_Interp *interp, int type,
Tcl_LimitHandlerProc *handlerProc, ClientData clientData)
}
declare 522 {
int Tcl_LimitReady(Tcl_Interp *interp)
}
declare 523 {
int Tcl_LimitCheck(Tcl_Interp *interp)
}
|
| ︙ | ︙ | |||
2043 2044 2045 2046 2047 2048 2049 |
Tcl_Namespace **namespacePtrPtr)
}
# TIP#233 (virtualized time) akupries
declare 552 {
void Tcl_SetTimeProc(Tcl_GetTimeProc *getProc,
Tcl_ScaleTimeProc *scaleProc,
| | | | | | | | | 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 |
Tcl_Namespace **namespacePtrPtr)
}
# TIP#233 (virtualized time) akupries
declare 552 {
void Tcl_SetTimeProc(Tcl_GetTimeProc *getProc,
Tcl_ScaleTimeProc *scaleProc,
ClientData clientData)
}
declare 553 {
void Tcl_QueryTimeProc(Tcl_GetTimeProc **getProc,
Tcl_ScaleTimeProc **scaleProc,
ClientData *clientData)
}
# TIP#218 (driver thread actions) davygrvy/akupries ChannelType ver 4
declare 554 {
Tcl_DriverThreadActionProc *Tcl_ChannelThreadActionProc(
const Tcl_ChannelType *chanTypePtr)
}
# TIP#237 (arbitrary-precision integers) kbk
declare 555 {
Tcl_Obj *Tcl_NewBignumObj(void *value)
}
declare 556 {
Tcl_Obj *Tcl_DbNewBignumObj(void *value, const char *file, int line)
}
declare 557 {
void Tcl_SetBignumObj(Tcl_Obj *obj, void *value)
}
declare 558 {
int Tcl_GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, void *value)
}
declare 559 {
int Tcl_TakeBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, void *value)
}
# TIP #208 ('chan' command) jeffh
declare 560 {
int Tcl_TruncateChannel(Tcl_Channel chan, Tcl_WideInt length)
}
declare 561 {
|
| ︙ | ︙ | |||
2100 2101 2102 2103 2104 2105 2106 |
declare 565 {
void Tcl_GetChannelError(Tcl_Channel chan, Tcl_Obj **msg)
}
# TIP #237 (additional conversion functions for bignum support) kbk/dgp
declare 566 {
int Tcl_InitBignumFromDouble(Tcl_Interp *interp, double initval,
| | | 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 |
declare 565 {
void Tcl_GetChannelError(Tcl_Channel chan, Tcl_Obj **msg)
}
# TIP #237 (additional conversion functions for bignum support) kbk/dgp
declare 566 {
int Tcl_InitBignumFromDouble(Tcl_Interp *interp, double initval,
void *toInit)
}
# TIP#181 (namespace unknown command) dgp for Neil Madden
declare 567 {
Tcl_Obj *Tcl_GetNamespaceUnknownHandler(Tcl_Interp *interp,
Tcl_Namespace *nsPtr)
}
|
| ︙ | ︙ | |||
2139 2140 2141 2142 2143 2144 2145 |
}
# TIP#270 (utility C routines for string formatting) dgp
declare 574 {
void Tcl_AppendObjToErrorInfo(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 575 {
| | | | 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 |
}
# TIP#270 (utility C routines for string formatting) dgp
declare 574 {
void Tcl_AppendObjToErrorInfo(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 575 {
void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, const char *bytes, int length,
int limit, const char *ellipsis)
}
declare 576 {
Tcl_Obj *Tcl_Format(Tcl_Interp *interp, const char *format, int objc,
Tcl_Obj *const objv[])
}
declare 577 {
int Tcl_AppendFormatToObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
|
| ︙ | ︙ | |||
2162 2163 2164 2165 2166 2167 2168 |
}
# ----- BASELINE -- FOR -- 8.5.0 ----- #
# TIP #285 (script cancellation support) jmistachkin
declare 580 {
int Tcl_CancelEval(Tcl_Interp *interp, Tcl_Obj *resultObjPtr,
| | | | | | | | | 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 |
}
# ----- BASELINE -- FOR -- 8.5.0 ----- #
# TIP #285 (script cancellation support) jmistachkin
declare 580 {
int Tcl_CancelEval(Tcl_Interp *interp, Tcl_Obj *resultObjPtr,
ClientData clientData, int flags)
}
declare 581 {
int Tcl_Canceled(Tcl_Interp *interp, int flags)
}
# TIP#304 (chan pipe) aferrieux
declare 582 {
int Tcl_CreatePipe(Tcl_Interp *interp, Tcl_Channel *rchan,
Tcl_Channel *wchan, int flags)
}
# TIP #322 (NRE public interface) msofer
declare 583 {
Tcl_Command Tcl_NRCreateCommand(Tcl_Interp *interp,
const char *cmdName, Tcl_ObjCmdProc *proc,
Tcl_ObjCmdProc *nreProc, ClientData clientData,
Tcl_CmdDeleteProc *deleteProc)
}
declare 584 {
int Tcl_NREvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
}
declare 585 {
int Tcl_NREvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
int flags)
}
declare 586 {
int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, int objc,
Tcl_Obj *const objv[], int flags)
}
declare 587 {
void Tcl_NRAddCallback(Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr,
ClientData data0, ClientData data1, ClientData data2,
ClientData data3)
}
# For use by NR extenders, to have a simple way to also provide a (required!)
# classic objProc
declare 588 {
int Tcl_NRCallObjProc(Tcl_Interp *interp, Tcl_ObjCmdProc *objProc,
ClientData clientData, int objc, Tcl_Obj *const objv[])
}
# TIP#316 (Tcl_StatBuf reader functions) dkf
declare 589 {
unsigned Tcl_GetFSDeviceFromStat(const Tcl_StatBuf *statPtr)
}
declare 590 {
|
| ︙ | ︙ | |||
2271 2272 2273 2274 2275 2276 2277 |
}
declare 606 {
void Tcl_SetErrorLine(Tcl_Interp *interp, int lineNum)
}
# TIP#307 (move results between interpreters) dkf
declare 607 {
| | | | | | < | 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 |
}
declare 606 {
void Tcl_SetErrorLine(Tcl_Interp *interp, int lineNum)
}
# TIP#307 (move results between interpreters) dkf
declare 607 {
void Tcl_TransferResult(Tcl_Interp *sourceInterp, int code,
Tcl_Interp *targetInterp)
}
# TIP#335 (detect if interpreter in use) jmistachkin
declare 608 {
int Tcl_InterpActive(Tcl_Interp *interp)
}
# TIP#337 (log exception for background processing) dgp
declare 609 {
void Tcl_BackgroundException(Tcl_Interp *interp, int code)
}
# TIP#234 (zlib interface) dkf/Pascal Scheffers
declare 610 {
int Tcl_ZlibDeflate(Tcl_Interp *interp, int format, Tcl_Obj *data,
int level, Tcl_Obj *gzipHeaderDictObj)
}
declare 611 {
int Tcl_ZlibInflate(Tcl_Interp *interp, int format, Tcl_Obj *data,
int buffersize, Tcl_Obj *gzipHeaderDictObj)
}
declare 612 {
unsigned int Tcl_ZlibCRC32(unsigned int crc, const unsigned char *buf,
int len)
}
declare 613 {
unsigned int Tcl_ZlibAdler32(unsigned int adler, const unsigned char *buf,
int len)
}
declare 614 {
int Tcl_ZlibStreamInit(Tcl_Interp *interp, int mode, int format,
int level, Tcl_Obj *dictObj, Tcl_ZlibStream *zshandle)
}
declare 615 {
Tcl_Obj *Tcl_ZlibStreamGetCommandName(Tcl_ZlibStream zshandle)
}
declare 616 {
int Tcl_ZlibStreamEof(Tcl_ZlibStream zshandle)
}
declare 617 {
int Tcl_ZlibStreamChecksum(Tcl_ZlibStream zshandle)
}
declare 618 {
int Tcl_ZlibStreamPut(Tcl_ZlibStream zshandle, Tcl_Obj *data, int flush)
}
declare 619 {
int Tcl_ZlibStreamGet(Tcl_ZlibStream zshandle, Tcl_Obj *data, int count)
}
declare 620 {
int Tcl_ZlibStreamClose(Tcl_ZlibStream zshandle)
}
declare 621 {
int Tcl_ZlibStreamReset(Tcl_ZlibStream zshandle)
}
|
| ︙ | ︙ | |||
2378 2379 2380 2381 2382 2383 2384 |
# ----- BASELINE -- FOR -- 8.6.0 ----- #
# TIP #456
declare 631 {
Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, const char *service,
const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc,
| | | 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 |
# ----- BASELINE -- FOR -- 8.6.0 ----- #
# TIP #456
declare 631 {
Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, const char *service,
const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc,
ClientData callbackData)
}
# TIP #430
declare 632 {
int TclZipfs_Mount(Tcl_Interp *interp, const char *mountPoint,
const char *zipname, const char *passwd)
}
|
| ︙ | ︙ | |||
2403 2404 2405 2406 2407 2408 2409 |
# TIP #445
declare 636 {
void Tcl_FreeIntRep(Tcl_Obj *objPtr)
}
declare 637 {
char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes,
| | | 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 |
# TIP #445
declare 636 {
void Tcl_FreeIntRep(Tcl_Obj *objPtr)
}
declare 637 {
char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes,
unsigned int numBytes)
}
declare 638 {
Tcl_ObjIntRep *Tcl_FetchIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr)
}
declare 639 {
void Tcl_StoreIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr,
const Tcl_ObjIntRep *irPtr)
|
| ︙ | ︙ | |||
2432 2433 2434 2435 2436 2437 2438 |
declare 643 {
int Tcl_IsShared(Tcl_Obj *objPtr)
}
# TIP#312 New Tcl_LinkArray() function
declare 644 {
int Tcl_LinkArray(Tcl_Interp *interp, const char *varName, void *addr,
| | | > > > > > > > > > > > > > | 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 |
declare 643 {
int Tcl_IsShared(Tcl_Obj *objPtr)
}
# TIP#312 New Tcl_LinkArray() function
declare 644 {
int Tcl_LinkArray(Tcl_Interp *interp, const char *varName, void *addr,
int type, int size)
}
declare 645 {
int Tcl_GetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
int endValue, int *indexPtr)
}
# TIP #548
declare 646 {
int Tcl_UtfToUniChar(const char *src, int *chPtr)
}
declare 647 {
char *Tcl_UniCharToUtfDString(const int *uniStr,
int uniLength, Tcl_DString *dsPtr)
}
declare 648 {
int *Tcl_UtfToUniCharDString(const char *src,
int length, Tcl_DString *dsPtr)
}
# ----- BASELINE -- FOR -- 8.7.0 ----- #
##############################################################################
# Define the platform specific public Tcl interface. These functions are only
|
| ︙ | ︙ | |||
2459 2460 2461 2462 2463 2464 2465 |
################################
# Windows specific functions
# Added in Tcl 8.1
declare 0 win {
| | | | | > > > | 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 |
################################
# Windows specific functions
# Added in Tcl 8.1
declare 0 win {
TCHAR *Tcl_WinUtfToTChar(const char *str, int len, Tcl_DString *dsPtr)
}
declare 1 win {
char *Tcl_WinTCharToUtf(const TCHAR *str, int len, Tcl_DString *dsPtr)
}
################################
# Mac OS X specific functions
declare 0 macosx {
int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
const char *bundleName, int hasResourceFile,
int maxPathLen, char *libraryPath)
}
declare 1 macosx {
int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp,
const char *bundleName, const char *bundleVersion,
int hasResourceFile, int maxPathLen, char *libraryPath)
}
##############################################################################
# Public functions that are not accessible via the stubs table.
export {
void Tcl_Main(int argc, char **argv, Tcl_AppInitProc *appInitProc)
}
export {
void Tcl_MainEx(int argc, char **argv, Tcl_AppInitProc *appInitProc,
Tcl_Interp *interp)
}
export {
void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName,
Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc)
|
| ︙ | ︙ | |||
2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 |
export {
const char *Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version,
int exact)
}
export {
void Tcl_GetMemoryInfo(Tcl_DString *dsPtr)
}
# Local Variables:
# mode: tcl
# End:
| > > > | 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 |
export {
const char *Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version,
int exact)
}
export {
void Tcl_GetMemoryInfo(Tcl_DString *dsPtr)
}
export {
void Tcl_InitSubsystems(void)
}
# Local Variables:
# mode: tcl
# End:
|
Changes to generic/tcl.h.
| ︙ | ︙ | |||
44 45 46 47 48 49 50 | * 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) * tools/tcl.hpj.in (not patchlevel, for windows installer) */ | | | | | | > > > > > > | > > > > > > > > > > > > | > | 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 | * 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) * tools/tcl.hpj.in (not patchlevel, for windows installer) */ #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 7 #define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE #define TCL_RELEASE_SERIAL 4 #define TCL_VERSION "8.7" #define TCL_PATCH_LEVEL "8.7a4" #if !defined(TCL_NO_DEPRECATED) || defined(RC_INVOKED) /* *---------------------------------------------------------------------------- * The following definitions set up the proper options for Windows compilers. * We use this method because there is no autoconf equivalent. */ #ifdef _WIN32 # ifndef __WIN32__ # define __WIN32__ # endif # ifndef WIN32 # define WIN32 # endif #endif /* * Utility macros: STRINGIFY takes an argument and wraps it in "" (double * quotation marks), JOIN joins two arguments. */ #ifndef STRINGIFY # define STRINGIFY(x) STRINGIFY1(x) # define STRINGIFY1(x) #x #endif #ifndef JOIN # define JOIN(a,b) JOIN1(a,b) # define JOIN1(a,b) a##b #endif #ifndef TCL_THREADS # define TCL_THREADS 1 #endif #endif /* !TCL_NO_DEPRECATED */ /* * A special definition used to allow this header file to be included from * windows resource files so that they can obtain version information. * RC_INVOKED is defined by default by the windows RC tool. * * Resource compilers don't like all the C stuff, like typedefs and function |
| ︙ | ︙ | |||
97 98 99 100 101 102 103 104 105 106 107 | * providing it for them rather than #include-ing it themselves as they * should, so also for their sake, we keep the #include to be consistent with * prior Tcl releases. */ #include <stdio.h> #if defined(__GNUC__) && (__GNUC__ > 2) # define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b))) # define TCL_NORETURN __attribute__ ((noreturn)) # define TCL_NOINLINE __attribute__ ((noinline)) | > > > > > > > > > > > > > > > > > > | > > > | 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 | * providing it for them rather than #include-ing it themselves as they * should, so also for their sake, we keep the #include to be consistent with * prior Tcl releases. */ #include <stdio.h> /* *---------------------------------------------------------------------------- * Support for functions with a variable number of arguments. * * The following TCL_VARARGS* macros are to support old extensions * written for older versions of Tcl where the macros permitted * support for the varargs.h system as well as stdarg.h . * * New code should just directly be written to use stdarg.h conventions. */ #include <stdarg.h> #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # define TCL_VARARGS(type, name) (type name, ...) # define TCL_VARARGS_DEF(type, name) (type name, ...) # define TCL_VARARGS_START(type, name, list) (va_start(list, name), name) #endif /* !TCL_NO_DEPRECATED */ #if defined(__GNUC__) && (__GNUC__ > 2) # define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b))) # define TCL_NORETURN __attribute__ ((noreturn)) # define TCL_NOINLINE __attribute__ ((noinline)) # if defined(BUILD_tcl) || defined(BUILD_tk) # define TCL_NORETURN1 __attribute__ ((noreturn)) # else # define TCL_NORETURN1 /* nothing */ # endif #else # define TCL_FORMAT_PRINTF(a,b) # if defined(_MSC_VER) && (_MSC_VER >= 1310) # define TCL_NORETURN _declspec(noreturn) # define TCL_NOINLINE __declspec(noinline) # else # define TCL_NORETURN /* nothing */ |
| ︙ | ︙ | |||
197 198 199 200 201 202 203 | # ifdef USE_TCL_STUBS # define TCL_STORAGE_CLASS # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif | > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | 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 |
# ifdef USE_TCL_STUBS
# define TCL_STORAGE_CLASS
# else
# define TCL_STORAGE_CLASS DLLIMPORT
# endif
#endif
/*
* The following _ANSI_ARGS_ macro is to support old extensions
* written for older versions of Tcl where it permitted support
* for compilers written in the pre-prototype era of C.
*
* New code should use prototypes.
*/
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
# undef _ANSI_ARGS_
# define _ANSI_ARGS_(x) x
/*
* Definitions that allow this header file to be used either with or without
* ANSI C features.
*/
#ifndef INLINE
# define INLINE
#endif
#ifndef CONST
# define CONST const
#endif
#endif /* !TCL_NO_DEPRECATED */
#ifndef CONST86
# define CONST86 const
#endif
/*
* Make sure EXTERN isn't defined elsewhere.
*/
#ifdef EXTERN
# undef EXTERN
#endif /* EXTERN */
#ifdef __cplusplus
# define EXTERN extern "C" TCL_STORAGE_CLASS
#else
# define EXTERN extern TCL_STORAGE_CLASS
#endif
/*
*----------------------------------------------------------------------------
* The following code is copied from winnt.h. If we don't replicate it here,
* then <windows.h> can't be included after tcl.h, since tcl.h also defines
* VOID. This block is skipped under Cygwin and Mingw.
*/
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
#if defined(_WIN32) && !defined(HAVE_WINNT_IGNORE_VOID)
#ifndef VOID
#define VOID void
typedef char CHAR;
typedef short SHORT;
typedef long LONG;
#endif
#endif /* _WIN32 && !HAVE_WINNT_IGNORE_VOID */
/*
* Macro to use instead of "void" for arguments that must have type "void *"
* in ANSI C; maps them to type "char *" in non-ANSI systems.
*/
#ifndef __VXWORKS__
# define VOID void
#endif
#endif /* !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 */
/*
* Miscellaneous declarations.
*/
#ifndef _CLIENTDATA
typedef void *ClientData;
# define _CLIENTDATA
#endif
/*
* Darwin specific configure overrides (to support fat compiles, where
* configure runs only once for multiple architectures):
*/
#ifdef __APPLE__
|
| ︙ | ︙ | |||
261 262 263 264 265 266 267 | * * 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) | | | 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 | * * 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(_MSC_VER) || defined(_WIN32) # 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" |
| ︙ | ︙ | |||
306 307 308 309 310 311 312 | #define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val))) #define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) #define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) #if defined(_WIN32) # ifdef __BORLANDC__ typedef struct stati64 Tcl_StatBuf; | | | 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 | #define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val))) #define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) #define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) #if defined(_WIN32) # ifdef __BORLANDC__ typedef struct stati64 Tcl_StatBuf; # elif defined(_WIN64) || defined(_USE_64BIT_TIME_T) typedef struct __stat64 Tcl_StatBuf; # elif (defined(_MSC_VER) && (_MSC_VER < 1400)) || defined(_USE_32BIT_TIME_T) typedef struct _stati64 Tcl_StatBuf; # else typedef struct _stat32i64 Tcl_StatBuf; # endif /* _MSC_VER < 1400 */ #elif defined(__CYGWIN__) |
| ︙ | ︙ | |||
356 357 358 359 360 361 362 | * "real" definition in tclInt.h. * * Note: Tcl_ObjCmdProc functions do not directly set result and freeProc. * Instead, they set a Tcl_Obj member in the "real" structure that can be * accessed with Tcl_GetObjResult() and Tcl_SetObjResult(). */ | | > > > > > > > > > > | 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 |
* "real" definition in tclInt.h.
*
* Note: Tcl_ObjCmdProc functions do not directly set result and freeProc.
* Instead, they set a Tcl_Obj member in the "real" structure that can be
* accessed with Tcl_GetObjResult() and Tcl_SetObjResult().
*/
typedef struct Tcl_Interp
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
{
/* TIP #330: Strongly discourage extensions from using the string
* result. */
char *resultDontUse; /* Don't use in extensions! */
void (*freeProcDontUse) (char *); /* Don't use in extensions! */
int errorLineDontUse; /* Don't use in extensions! */
}
#endif /* !TCL_NO_DEPRECATED */
Tcl_Interp;
typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler;
typedef struct Tcl_Channel_ *Tcl_Channel;
typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion;
typedef struct Tcl_Command_ *Tcl_Command;
typedef struct Tcl_Condition_ *Tcl_Condition;
typedef struct Tcl_Dict_ *Tcl_Dict;
|
| ︙ | ︙ | |||
387 388 389 390 391 392 393 | *---------------------------------------------------------------------------- * Definition of the interface to functions implementing threads. A function * following this definition is given to each call of 'Tcl_CreateThread' and * will be called as the main fuction of the new thread created by that call. */ #if defined _WIN32 | | | | 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 | *---------------------------------------------------------------------------- * Definition of the interface to functions implementing threads. A function * following this definition is given to each call of 'Tcl_CreateThread' and * will be called as the main fuction of the new thread created by that call. */ #if defined _WIN32 typedef unsigned (__stdcall Tcl_ThreadCreateProc) (ClientData clientData); #else typedef void (Tcl_ThreadCreateProc) (ClientData clientData); #endif /* * Threading function return types used for abstracting away platform * differences when writing a Tcl_ThreadCreateProc. See the NewThread function * in generic/tclThreadTest.c for it's usage. */ |
| ︙ | ︙ | |||
455 456 457 458 459 460 461 |
/*
* Structures filled in by Tcl_RegExpInfo. Note that all offset values are
* relative to the start of the match string, not the beginning of the entire
* string.
*/
typedef struct Tcl_RegExpIndices {
| | | | | > | 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 |
/*
* Structures filled in by Tcl_RegExpInfo. Note that all offset values are
* relative to the start of the match string, not the beginning of the entire
* string.
*/
typedef struct Tcl_RegExpIndices {
long start; /* Character offset of first character in
* match. */
long end; /* Character offset of first character after
* the match. */
} Tcl_RegExpIndices;
typedef struct Tcl_RegExpInfo {
int nsubs; /* Number of subexpressions in the compiled
* expression. */
Tcl_RegExpIndices *matches; /* Array of nsubs match offset pairs. */
long extendStart; /* The offset at which a subsequent match
* might begin. */
long reserved; /* Reserved for later use. */
} Tcl_RegExpInfo;
/*
* Picky compilers complain if this typdef doesn't appear before the struct's
* reference in tclDecls.h.
*/
|
| ︙ | ︙ | |||
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 | #define TCL_OK 0 #define TCL_ERROR 1 #define TCL_RETURN 2 #define TCL_BREAK 3 #define TCL_CONTINUE 4 /* *---------------------------------------------------------------------------- * Flags to control what substitutions are performed by Tcl_SubstObj(): */ #define TCL_SUBST_COMMANDS 001 #define TCL_SUBST_VARIABLES 002 #define TCL_SUBST_BACKSLASHES 004 #define TCL_SUBST_ALL 007 /* * Forward declaration of Tcl_Obj to prevent an error when the forward * reference to Tcl_Obj is encountered in the function types declared below. */ struct Tcl_Obj; /* *---------------------------------------------------------------------------- * Function types defined by Tcl: */ typedef int (Tcl_AppInitProc) (Tcl_Interp *interp); | > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | 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 |
#define TCL_OK 0
#define TCL_ERROR 1
#define TCL_RETURN 2
#define TCL_BREAK 3
#define TCL_CONTINUE 4
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
#define TCL_RESULT_SIZE 200
#endif
/*
*----------------------------------------------------------------------------
* Flags to control what substitutions are performed by Tcl_SubstObj():
*/
#define TCL_SUBST_COMMANDS 001
#define TCL_SUBST_VARIABLES 002
#define TCL_SUBST_BACKSLASHES 004
#define TCL_SUBST_ALL 007
/*
* Argument descriptors for math function callbacks in expressions:
*/
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
typedef enum {
TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT
} Tcl_ValueType;
typedef struct Tcl_Value {
Tcl_ValueType type; /* Indicates intValue or doubleValue is valid,
* or both. */
long intValue; /* Integer value. */
double doubleValue; /* Double-precision floating value. */
Tcl_WideInt wideValue; /* Wide (min. 64-bit) integer value. */
} Tcl_Value;
#else
#define Tcl_ValueType void /* Just enough to prevent compilation error in Tcl */
#define Tcl_Value void /* Just enough to prevent compilation error in Tcl */
#endif
/*
* Forward declaration of Tcl_Obj to prevent an error when the forward
* reference to Tcl_Obj is encountered in the function types declared below.
*/
struct Tcl_Obj;
/*
*----------------------------------------------------------------------------
* Function types defined by Tcl:
*/
typedef int (Tcl_AppInitProc) (Tcl_Interp *interp);
typedef int (Tcl_AsyncProc) (ClientData clientData, Tcl_Interp *interp,
int code);
typedef void (Tcl_ChannelProc) (ClientData clientData, int mask);
typedef void (Tcl_CloseProc) (ClientData data);
typedef void (Tcl_CmdDeleteProc) (ClientData clientData);
typedef int (Tcl_CmdProc) (ClientData clientData, Tcl_Interp *interp,
int argc, const char *argv[]);
typedef void (Tcl_CmdTraceProc) (ClientData clientData, Tcl_Interp *interp,
int level, char *command, Tcl_CmdProc *proc,
ClientData cmdClientData, int argc, const char *argv[]);
typedef int (Tcl_CmdObjTraceProc) (ClientData clientData, Tcl_Interp *interp,
int level, const char *command, Tcl_Command commandInfo, int objc,
struct Tcl_Obj *const *objv);
typedef void (Tcl_CmdObjTraceDeleteProc) (ClientData clientData);
typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr,
struct Tcl_Obj *dupPtr);
typedef int (Tcl_EncodingConvertProc) (ClientData clientData, const char *src,
int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst,
int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr);
typedef void (Tcl_EncodingFreeProc) (ClientData clientData);
typedef int (Tcl_EventProc) (Tcl_Event *evPtr, int flags);
typedef void (Tcl_EventCheckProc) (ClientData clientData, int flags);
typedef int (Tcl_EventDeleteProc) (Tcl_Event *evPtr, ClientData clientData);
typedef void (Tcl_EventSetupProc) (ClientData clientData, int flags);
typedef void (Tcl_ExitProc) (ClientData clientData);
typedef void (Tcl_FileProc) (ClientData clientData, int mask);
typedef void (Tcl_FileFreeProc) (ClientData clientData);
typedef void (Tcl_FreeInternalRepProc) (struct Tcl_Obj *objPtr);
typedef void (Tcl_FreeProc) (char *blockPtr);
typedef void (Tcl_IdleProc) (ClientData clientData);
typedef void (Tcl_InterpDeleteProc) (ClientData clientData,
Tcl_Interp *interp);
typedef int (Tcl_MathProc) (ClientData clientData, Tcl_Interp *interp,
Tcl_Value *args, Tcl_Value *resultPtr);
typedef void (Tcl_NamespaceDeleteProc) (ClientData clientData);
typedef int (Tcl_ObjCmdProc) (ClientData clientData, Tcl_Interp *interp,
int objc, struct Tcl_Obj *const *objv);
typedef int (Tcl_PackageInitProc) (Tcl_Interp *interp);
typedef int (Tcl_PackageUnloadProc) (Tcl_Interp *interp, int flags);
typedef void (Tcl_PanicProc) (const char *format, ...);
typedef void (Tcl_TcpAcceptProc) (ClientData callbackData, Tcl_Channel chan,
char *address, int port);
typedef void (Tcl_TimerProc) (ClientData clientData);
typedef int (Tcl_SetFromAnyProc) (Tcl_Interp *interp, struct Tcl_Obj *objPtr);
typedef void (Tcl_UpdateStringProc) (struct Tcl_Obj *objPtr);
typedef char * (Tcl_VarTraceProc) (ClientData clientData, Tcl_Interp *interp,
const char *part1, const char *part2, int flags);
typedef void (Tcl_CommandTraceProc) (ClientData clientData, Tcl_Interp *interp,
const char *oldName, const char *newName, int flags);
typedef void (Tcl_CreateFileHandlerProc) (int fd, int mask, Tcl_FileProc *proc,
ClientData clientData);
typedef void (Tcl_DeleteFileHandlerProc) (int fd);
typedef void (Tcl_AlertNotifierProc) (ClientData clientData);
typedef void (Tcl_ServiceModeHookProc) (int mode);
typedef ClientData (Tcl_InitNotifierProc) (void);
typedef void (Tcl_FinalizeNotifierProc) (ClientData clientData);
typedef void (Tcl_MainLoopProc) (void);
/*
*----------------------------------------------------------------------------
* The following structure represents a type of object, which is a particular
* internal representation for an object plus a set of functions that provide
* standard operations on objects of that type.
|
| ︙ | ︙ | |||
638 639 640 641 642 643 644 |
/*
* One of the following structures exists for each object in the Tcl system.
* An object stores a value as either a string, some internal representation,
* or both.
*/
typedef struct Tcl_Obj {
| | | | | > | > > > > > > > > | | | 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 |
/*
* One of the following structures exists for each object in the Tcl system.
* An object stores a value as either a string, some internal representation,
* or both.
*/
typedef struct Tcl_Obj {
int refCount; /* When 0 the object will be freed. */
char *bytes; /* This points to the first byte of the
* object's string representation. The array
* must be followed by a null byte (i.e., at
* offset length) but may also contain
* embedded null characters. The array's
* storage is allocated by ckalloc. NULL means
* the string rep is invalid and must be
* regenerated from the internal rep. Clients
* should use Tcl_GetStringFromObj or
* Tcl_GetString to get a pointer to the byte
* array as a readonly value. */
int length; /* The number of bytes at *bytes, not
* including the terminating null. */
const Tcl_ObjType *typePtr; /* Denotes the object's type. Always
* corresponds to the type of the object's
* internal rep. NULL indicates the object has
* no internal rep (has no type). */
Tcl_ObjIntRep internalRep; /* The internal representation: */
} Tcl_Obj;
/*
*----------------------------------------------------------------------------
* The following structure contains the state needed by Tcl_SaveResult. No-one
* outside of Tcl should access any of these fields. This structure is
* typically allocated on the stack.
*/
typedef struct Tcl_SavedResult {
char *result;
Tcl_FreeProc *freeProc;
Tcl_Obj *objResultPtr;
char *appendResult;
int appendAvl;
int appendUsed;
char resultSpace[200+1];
} Tcl_SavedResult;
/*
*----------------------------------------------------------------------------
* The following definitions support Tcl's namespace facility. Note: the first
* five fields must match exactly the fields in a Namespace structure (see
* tclInt.h).
*/
typedef struct Tcl_Namespace {
char *name; /* The namespace's name within its parent
* namespace. This contains no ::'s. The name
* of the global namespace is "" although "::"
* is an synonym. */
char *fullName; /* The namespace's fully qualified name. This
* starts with ::. */
ClientData clientData; /* Arbitrary value associated with this
* namespace. */
Tcl_NamespaceDeleteProc *deleteProc;
/* Function invoked when deleting the
* namespace to, e.g., free clientData. */
struct Tcl_Namespace *parentPtr;
/* Points to the namespace that contains this
* one. NULL if this is the global
|
| ︙ | ︙ | |||
754 755 756 757 758 759 760 |
typedef struct Tcl_CmdInfo {
int isNativeObjectProc; /* 1 if objProc was registered by a call to
* Tcl_CreateObjCommand; 0 otherwise.
* Tcl_SetCmdInfo does not modify this
* field. */
Tcl_ObjCmdProc *objProc; /* Command's object-based function. */
| | | | | | > > > | | | 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 |
typedef struct Tcl_CmdInfo {
int isNativeObjectProc; /* 1 if objProc was registered by a call to
* Tcl_CreateObjCommand; 0 otherwise.
* Tcl_SetCmdInfo does not modify this
* field. */
Tcl_ObjCmdProc *objProc; /* Command's object-based function. */
ClientData objClientData; /* ClientData for object proc. */
Tcl_CmdProc *proc; /* Command's string-based function. */
ClientData clientData; /* ClientData for string proc. */
Tcl_CmdDeleteProc *deleteProc;
/* Function to call when command is
* deleted. */
ClientData deleteData; /* Value to pass to deleteProc (usually the
* same as clientData). */
Tcl_Namespace *namespacePtr;/* Points to the namespace that contains this
* command. Note that Tcl_SetCmdInfo will not
* change a command's namespace; use
* TclRenameCommand or Tcl_Eval (of 'rename')
* to do that. */
} Tcl_CmdInfo;
/*
*----------------------------------------------------------------------------
* The structure defined below is used to hold dynamic strings. The only
* fields that clients should use are string and length, accessible via the
* macros Tcl_DStringValue and Tcl_DStringLength.
*/
#define TCL_DSTRING_STATIC_SIZE 200
typedef struct Tcl_DString {
char *string; /* Points to beginning of string: either
* staticSpace below or a malloced array. */
int length; /* Number of non-NULL characters in the
* string. */
int spaceAvl; /* Total number of bytes available for the
* string and its terminating NULL char. */
char staticSpace[TCL_DSTRING_STATIC_SIZE];
/* Space to use in common case where string is
* small. */
} Tcl_DString;
#define Tcl_DStringLength(dsPtr) ((dsPtr)->length)
#define Tcl_DStringValue(dsPtr) ((dsPtr)->string)
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
# define Tcl_DStringTrunc Tcl_DStringSetLength
#endif /* !TCL_NO_DEPRECATED */
/*
* Definitions for the maximum number of digits of precision that may be
* specified in the "tcl_precision" variable, and the number of bytes of
* buffer space required by Tcl_PrintDouble.
*/
#define TCL_MAX_PREC 17
#define TCL_DOUBLE_SPACE (TCL_MAX_PREC+10)
/*
* Definition for a number of bytes of buffer space sufficient to hold the
|
| ︙ | ︙ | |||
881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 | #define TCL_NAMESPACE_ONLY 2 #define TCL_APPEND_VALUE 4 #define TCL_LIST_ELEMENT 8 #define TCL_TRACE_READS 0x10 #define TCL_TRACE_WRITES 0x20 #define TCL_TRACE_UNSETS 0x40 #define TCL_TRACE_DESTROYED 0x80 #define TCL_INTERP_DESTROYED 0x100 #define TCL_LEAVE_ERR_MSG 0x200 #define TCL_TRACE_ARRAY 0x800 #ifndef TCL_REMOVE_OBSOLETE_TRACES /* Required to support old variable/vdelete/vinfo traces. */ #define TCL_TRACE_OLD_STYLE 0x1000 #endif /* Indicate the semantics of the result of a trace. */ | > > > > | 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 | #define TCL_NAMESPACE_ONLY 2 #define TCL_APPEND_VALUE 4 #define TCL_LIST_ELEMENT 8 #define TCL_TRACE_READS 0x10 #define TCL_TRACE_WRITES 0x20 #define TCL_TRACE_UNSETS 0x40 #define TCL_TRACE_DESTROYED 0x80 #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 #define TCL_INTERP_DESTROYED 0x100 #endif #define TCL_LEAVE_ERR_MSG 0x200 #define TCL_TRACE_ARRAY 0x800 #ifndef TCL_REMOVE_OBSOLETE_TRACES /* Required to support old variable/vdelete/vinfo traces. */ #define TCL_TRACE_OLD_STYLE 0x1000 #endif /* Indicate the semantics of the result of a trace. */ |
| ︙ | ︙ | |||
909 910 911 912 913 914 915 916 917 918 919 920 921 922 | */ #define TCL_TRACE_RENAME 0x2000 #define TCL_TRACE_DELETE 0x4000 #define TCL_ALLOW_INLINE_COMPILATION 0x20000 /* * Types for linked variables: */ #define TCL_LINK_INT 1 #define TCL_LINK_DOUBLE 2 #define TCL_LINK_BOOLEAN 3 | > > > > > > > > > > > | 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 | */ #define TCL_TRACE_RENAME 0x2000 #define TCL_TRACE_DELETE 0x4000 #define TCL_ALLOW_INLINE_COMPILATION 0x20000 /* * The TCL_PARSE_PART1 flag is deprecated and has no effect. The part1 is now * always parsed whenever the part2 is NULL. (This is to avoid a common error * when converting code to use the new object based APIs and forgetting to * give the flag) */ #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # define TCL_PARSE_PART1 0x400 #endif /* !TCL_NO_DEPRECATED */ /* * Types for linked variables: */ #define TCL_LINK_INT 1 #define TCL_LINK_DOUBLE 2 #define TCL_LINK_BOOLEAN 3 |
| ︙ | ︙ | |||
942 943 944 945 946 947 948 | /* *---------------------------------------------------------------------------- * Forward declarations of Tcl_HashTable and related types. */ #ifndef TCL_HASH_TYPE | | | 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 | /* *---------------------------------------------------------------------------- * Forward declarations of Tcl_HashTable and related types. */ #ifndef TCL_HASH_TYPE # define TCL_HASH_TYPE unsigned #endif typedef struct Tcl_HashKeyType Tcl_HashKeyType; typedef struct Tcl_HashTable Tcl_HashTable; typedef struct Tcl_HashEntry Tcl_HashEntry; typedef TCL_HASH_TYPE (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr); |
| ︙ | ︙ | |||
964 965 966 967 968 969 970 |
* should access any of these fields directly; use the macros defined below.
*/
struct Tcl_HashEntry {
Tcl_HashEntry *nextPtr; /* Pointer to next entry in this hash bucket,
* or NULL for end of chain. */
Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */
| | > > | | 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 |
* should access any of these fields directly; use the macros defined below.
*/
struct Tcl_HashEntry {
Tcl_HashEntry *nextPtr; /* Pointer to next entry in this hash bucket,
* or NULL for end of chain. */
Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */
void *hash; /* Hash value, stored as pointer to ensure
* that the offsets of the fields in this
* structure are not changed. */
ClientData clientData; /* Application stores something here with
* Tcl_SetHashValue. */
union { /* Key has one of these forms: */
char *oneWordValue; /* One-word value for key. */
Tcl_Obj *objPtr; /* Tcl_Obj * key value. */
int words[1]; /* Multiple integer words for key. The actual
* size will be as large as necessary for this
* table's keys. */
|
| ︙ | ︙ | |||
1053 1054 1055 1056 1057 1058 1059 |
struct Tcl_HashTable {
Tcl_HashEntry **buckets; /* Pointer to bucket array. Each element
* points to first entry in bucket's hash
* chain, or NULL. */
Tcl_HashEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
/* Bucket array used for small tables (to
* avoid mallocs and frees). */
| | | | < > | | 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 |
struct Tcl_HashTable {
Tcl_HashEntry **buckets; /* Pointer to bucket array. Each element
* points to first entry in bucket's hash
* chain, or NULL. */
Tcl_HashEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
/* Bucket array used for small tables (to
* avoid mallocs and frees). */
int numBuckets; /* Total number of buckets allocated at
* **bucketPtr. */
int numEntries; /* Total number of entries present in
* table. */
int rebuildSize; /* Enlarge table when numEntries gets to be
* this large. */
int downShift; /* Shift count used in hashing function.
* Designed to use high-order bits of
* randomized keys. */
int mask; /* Mask value used in hashing function. */
int keyType; /* Type of keys used in this table. It's
* either TCL_CUSTOM_KEYS, TCL_STRING_KEYS,
* TCL_ONE_WORD_KEYS, or an integer giving the
* number of ints that is the size of the
* key. */
Tcl_HashEntry *(*findProc) (Tcl_HashTable *tablePtr, const char *key);
Tcl_HashEntry *(*createProc) (Tcl_HashTable *tablePtr, const char *key,
int *newPtr);
const Tcl_HashKeyType *typePtr;
/* Type of the keys used in the
* Tcl_HashTable. */
};
/*
* Structure definition for information used to keep track of searches through
* hash tables:
*/
typedef struct Tcl_HashSearch {
Tcl_HashTable *tablePtr; /* Table being searched. */
int nextIndex; /* Index of next bucket to be enumerated after
* present one. */
Tcl_HashEntry *nextEntryPtr;/* Next entry to be enumerated in the current
* bucket. */
} Tcl_HashSearch;
/*
* Acceptable key types for hash tables:
|
| ︙ | ︙ | |||
1124 1125 1126 1127 1128 1129 1130 |
* dictionaries. These fields should not be accessed by code outside
* tclDictObj.c
*/
typedef struct {
void *next; /* Search position for underlying hash
* table. */
| | | 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 |
* dictionaries. These fields should not be accessed by code outside
* tclDictObj.c
*/
typedef struct {
void *next; /* Search position for underlying hash
* table. */
unsigned int epoch; /* Epoch marker for dictionary being searched,
* or 0 if search has terminated. */
Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */
} Tcl_DictSearch;
/*
*----------------------------------------------------------------------------
* Flag values to pass to Tcl_DoOneEvent to disable searches for some kinds of
|
| ︙ | ︙ | |||
1183 1184 1185 1186 1187 1188 1189 |
*/
typedef struct Tcl_Time {
long sec; /* Seconds. */
long usec; /* Microseconds. */
} Tcl_Time;
| | | | | | 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 |
*/
typedef struct Tcl_Time {
long sec; /* Seconds. */
long usec; /* Microseconds. */
} Tcl_Time;
typedef void (Tcl_SetTimerProc) (CONST86 Tcl_Time *timePtr);
typedef int (Tcl_WaitForEventProc) (CONST86 Tcl_Time *timePtr);
/*
* TIP #233 (Virtualized Time)
*/
typedef void (Tcl_GetTimeProc) (Tcl_Time *timebuf, ClientData clientData);
typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, ClientData clientData);
/*
*----------------------------------------------------------------------------
* Bits to pass to Tcl_CreateFileHandler and Tcl_CreateChannelHandler to
* indicate what sorts of events are of interest:
*/
|
| ︙ | ︙ | |||
1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 | #define TCL_CLOSE2PROC ((Tcl_DriverCloseProc *) 1) /* * Channel version tag. This was introduced in 8.3.2/8.4. */ #define TCL_CHANNEL_VERSION_1 ((Tcl_ChannelTypeVersion) 0x1) #define TCL_CHANNEL_VERSION_2 ((Tcl_ChannelTypeVersion) 0x2) #define TCL_CHANNEL_VERSION_3 ((Tcl_ChannelTypeVersion) 0x3) #define TCL_CHANNEL_VERSION_4 ((Tcl_ChannelTypeVersion) 0x4) #define TCL_CHANNEL_VERSION_5 ((Tcl_ChannelTypeVersion) 0x5) /* * TIP #218: Channel Actions, Ids for Tcl_DriverThreadActionProc. */ #define TCL_CHANNEL_THREAD_INSERT (0) #define TCL_CHANNEL_THREAD_REMOVE (1) /* * Typedefs for the various operations in a channel type: */ | > > | | | | | | | | | | | | | | | | | 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 | #define TCL_CLOSE2PROC ((Tcl_DriverCloseProc *) 1) /* * Channel version tag. This was introduced in 8.3.2/8.4. */ #ifndef TCL_NO_DEPRECATED #define TCL_CHANNEL_VERSION_1 ((Tcl_ChannelTypeVersion) 0x1) #define TCL_CHANNEL_VERSION_2 ((Tcl_ChannelTypeVersion) 0x2) #define TCL_CHANNEL_VERSION_3 ((Tcl_ChannelTypeVersion) 0x3) #define TCL_CHANNEL_VERSION_4 ((Tcl_ChannelTypeVersion) 0x4) #endif #define TCL_CHANNEL_VERSION_5 ((Tcl_ChannelTypeVersion) 0x5) /* * TIP #218: Channel Actions, Ids for Tcl_DriverThreadActionProc. */ #define TCL_CHANNEL_THREAD_INSERT (0) #define TCL_CHANNEL_THREAD_REMOVE (1) /* * Typedefs for the various operations in a channel type: */ typedef int (Tcl_DriverBlockModeProc) (ClientData instanceData, int mode); typedef int (Tcl_DriverCloseProc) (ClientData instanceData, Tcl_Interp *interp); typedef int (Tcl_DriverClose2Proc) (ClientData instanceData, Tcl_Interp *interp, int flags); typedef int (Tcl_DriverInputProc) (ClientData instanceData, char *buf, int toRead, int *errorCodePtr); typedef int (Tcl_DriverOutputProc) (ClientData instanceData, const char *buf, int toWrite, int *errorCodePtr); typedef int (Tcl_DriverSeekProc) (ClientData instanceData, long offset, int mode, int *errorCodePtr); typedef int (Tcl_DriverSetOptionProc) (ClientData instanceData, Tcl_Interp *interp, const char *optionName, const char *value); typedef int (Tcl_DriverGetOptionProc) (ClientData instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); typedef void (Tcl_DriverWatchProc) (ClientData instanceData, int mask); typedef int (Tcl_DriverGetHandleProc) (ClientData instanceData, int direction, ClientData *handlePtr); typedef int (Tcl_DriverFlushProc) (ClientData instanceData); typedef int (Tcl_DriverHandlerProc) (ClientData instanceData, int interestMask); typedef Tcl_WideInt (Tcl_DriverWideSeekProc) (ClientData instanceData, Tcl_WideInt offset, int mode, int *errorCodePtr); /* * TIP #218, Channel Thread Actions */ typedef void (Tcl_DriverThreadActionProc) (ClientData instanceData, int action); /* * TIP #208, File Truncation (etc.) */ typedef int (Tcl_DriverTruncateProc) (ClientData instanceData, Tcl_WideInt length); /* * struct Tcl_ChannelType: * * One such structure exists for each type (kind) of channel. It collects * together in one place all the functions that are part of the specific |
| ︙ | ︙ | |||
1305 1306 1307 1308 1309 1310 1311 |
const char *typeName; /* The name of the channel type in Tcl
* commands. This storage is owned by channel
* type. */
Tcl_ChannelTypeVersion version;
/* Version of the channel type. */
Tcl_DriverCloseProc *closeProc;
/* Function to call to close the channel, or
| | | 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 |
const char *typeName; /* The name of the channel type in Tcl
* commands. This storage is owned by channel
* type. */
Tcl_ChannelTypeVersion version;
/* Version of the channel type. */
Tcl_DriverCloseProc *closeProc;
/* Function to call to close the channel, or
* NULL or TCL_CLOSE2PROC if the close2Proc should be
* used instead. */
Tcl_DriverInputProc *inputProc;
/* Function to call for input on channel. */
Tcl_DriverOutputProc *outputProc;
/* Function to call for output on channel. */
Tcl_DriverSeekProc *seekProc;
/* Function to call to seek on the channel.
|
| ︙ | ︙ | |||
1456 1457 1458 1459 1460 1461 1462 | /* We have to declare the utime structure here. */ struct utimbuf; typedef int (Tcl_FSUtimeProc) (Tcl_Obj *pathPtr, struct utimbuf *tval); typedef int (Tcl_FSNormalizePathProc) (Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint); typedef int (Tcl_FSFileAttrsGetProc) (Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); | | | | | | | | | | | > | | > | < | < | | < | | | | | | | | < | | | | | < | < | | < | < | < | < | > | < < | | < | | | < < | | | < | | < | | | | < | | < | | < | | < | | | < | | < > | < < | > | | < < | < | | | | < | | | | | | < | | < | | < | < < | | < < < | | | | > > > > | 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 |
/* We have to declare the utime structure here. */
struct utimbuf;
typedef int (Tcl_FSUtimeProc) (Tcl_Obj *pathPtr, struct utimbuf *tval);
typedef int (Tcl_FSNormalizePathProc) (Tcl_Interp *interp, Tcl_Obj *pathPtr,
int nextCheckpoint);
typedef int (Tcl_FSFileAttrsGetProc) (Tcl_Interp *interp, int index,
Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef);
typedef const char *CONST86 * (Tcl_FSFileAttrStringsProc) (Tcl_Obj *pathPtr,
Tcl_Obj **objPtrRef);
typedef int (Tcl_FSFileAttrsSetProc) (Tcl_Interp *interp, int index,
Tcl_Obj *pathPtr, Tcl_Obj *objPtr);
typedef Tcl_Obj * (Tcl_FSLinkProc) (Tcl_Obj *pathPtr, Tcl_Obj *toPtr,
int linkType);
typedef int (Tcl_FSLoadFileProc) (Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr);
typedef int (Tcl_FSPathInFilesystemProc) (Tcl_Obj *pathPtr,
ClientData *clientDataPtr);
typedef Tcl_Obj * (Tcl_FSFilesystemPathTypeProc) (Tcl_Obj *pathPtr);
typedef Tcl_Obj * (Tcl_FSFilesystemSeparatorProc) (Tcl_Obj *pathPtr);
typedef void (Tcl_FSFreeInternalRepProc) (ClientData clientData);
typedef ClientData (Tcl_FSDupInternalRepProc) (ClientData clientData);
typedef Tcl_Obj * (Tcl_FSInternalToNormalizedProc) (ClientData clientData);
typedef ClientData (Tcl_FSCreateInternalRepProc) (Tcl_Obj *pathPtr);
typedef struct Tcl_FSVersion_ *Tcl_FSVersion;
/*
*----------------------------------------------------------------------------
* Data structures related to hooking into the filesystem
*/
/*
* Filesystem version tag. This was introduced in 8.4.
*/
#define TCL_FILESYSTEM_VERSION_1 ((Tcl_FSVersion) 0x1)
/*
* struct Tcl_Filesystem:
*
* One such structure exists for each type (kind) of filesystem. It collects
* together the functions that form the interface for a particulr the
* filesystem. Tcl always accesses the filesystem through one of these
* structures.
*
* Not all entries need be non-NULL; any which are NULL are simply ignored.
* However, a complete filesystem should provide all of these functions. The
* explanations in the structure show the importance of each function.
*/
typedef struct Tcl_Filesystem {
const char *typeName; /* The name of the filesystem. */
int structureLength; /* Length of this structure, so future binary
* compatibility can be assured. */
Tcl_FSVersion version; /* Version of the filesystem type. */
Tcl_FSPathInFilesystemProc *pathInFilesystemProc;
/* Determines whether the pathname is in this
* filesystem. This is the most important
* filesystem function. */
Tcl_FSDupInternalRepProc *dupInternalRepProc;
/* Duplicates the internal handle of the node.
* If it is NULL, the filesystem is less
* performant. */
Tcl_FSFreeInternalRepProc *freeInternalRepProc;
/* Frees the internal handle of the node. NULL
* only if there is no need to free resources
* used for the internal handle. */
Tcl_FSInternalToNormalizedProc *internalToNormalizedProc;
/* Converts the internal handle to a normalized
* path. NULL if the filesystem creates nodes
* having no pathname. */
Tcl_FSCreateInternalRepProc *createInternalRepProc;
/* Creates an internal handle for a pathname.
* May be NULL if pathnames have no internal
* handle or if pathInFilesystemProc always
* immediately creates an internal
* representation for pathnames in the
* filesystem. */
Tcl_FSNormalizePathProc *normalizePathProc;
/* Normalizes a path. Should be implemented if
* the filesystems supports multiple paths to
* the same node. */
Tcl_FSFilesystemPathTypeProc *filesystemPathTypeProc;
/* Determines the type of a path in this
* filesystem. May be NULL. */
Tcl_FSFilesystemSeparatorProc *filesystemSeparatorProc;
/* Produces the separator character(s) for this
* filesystem. Must not be NULL. */
Tcl_FSStatProc *statProc; /* Called by 'Tcl_FSStat()'. Provided by any
* reasonable filesystem. */
Tcl_FSAccessProc *accessProc;
/* Called by 'Tcl_FSAccess()'. Implemented by
* any reasonable filesystem. */
Tcl_FSOpenFileChannelProc *openFileChannelProc;
/* Called by 'Tcl_FSOpenFileChannel()'.
* Provided by any reasonable filesystem. */
Tcl_FSMatchInDirectoryProc *matchInDirectoryProc;
/* Called by 'Tcl_FSMatchInDirectory()'. NULL
* if the filesystem does not support glob or
* recursive copy. */
Tcl_FSUtimeProc *utimeProc; /* Called by 'Tcl_FSUtime()', by 'file
* mtime' to set (not read) times, 'file
* atime', and the open-r/open-w/fcopy variant
* of 'file copy'. */
Tcl_FSLinkProc *linkProc; /* Called by 'Tcl_FSLink()'. NULL if reading or
* creating links is not supported. */
Tcl_FSListVolumesProc *listVolumesProc;
/* Lists filesystem volumes added by this
* filesystem. NULL if the filesystem does not
* use volumes. */
Tcl_FSFileAttrStringsProc *fileAttrStringsProc;
/* List all valid attributes strings. NULL if
* the filesystem does not support the 'file
* attributes' command. Can be used to attach
* arbitrary additional data to files in a
* filesystem. */
Tcl_FSFileAttrsGetProc *fileAttrsGetProc;
/* Called by 'Tcl_FSFileAttrsGet()' and by
* 'file attributes'. */
Tcl_FSFileAttrsSetProc *fileAttrsSetProc;
/* Called by 'Tcl_FSFileAttrsSet()' and by
* 'file attributes'. */
Tcl_FSCreateDirectoryProc *createDirectoryProc;
/* Called by 'Tcl_FSCreateDirectory()'. May be
* NULL if the filesystem is read-only. */
Tcl_FSRemoveDirectoryProc *removeDirectoryProc;
/* Called by 'Tcl_FSRemoveDirectory()'. May be
* NULL if the filesystem is read-only. */
Tcl_FSDeleteFileProc *deleteFileProc;
/* Called by 'Tcl_FSDeleteFile()' May be NULL
* if the filesystem is is read-only. */
Tcl_FSCopyFileProc *copyFileProc;
/* Called by 'Tcl_FSCopyFile()'. If NULL, for
* a copy operation at the script level (not
* C) Tcl uses open-r, open-w and fcopy. */
Tcl_FSRenameFileProc *renameFileProc;
/* Called by 'Tcl_FSRenameFile()'. If NULL, for
* a rename operation at the script level (not
* C) Tcl performs a copy operation followed
* by a delete operation. */
Tcl_FSCopyDirectoryProc *copyDirectoryProc;
/* Called by 'Tcl_FSCopyDirectory()'. If NULL,
* for a copy operation at the script level
* (not C) Tcl recursively creates directories
* and copies files. */
Tcl_FSLstatProc *lstatProc; /* Called by 'Tcl_FSLstat()'. If NULL, Tcl
* attempts to use 'statProc' instead. */
Tcl_FSLoadFileProc *loadFileProc;
/* Called by 'Tcl_FSLoadFile()'. If NULL, Tcl
* performs a copy to a temporary file in the
* native filesystem and then calls
* Tcl_FSLoadFile() on that temporary copy. */
Tcl_FSGetCwdProc *getCwdProc;
/* Called by 'Tcl_FSGetCwd()'. Normally NULL.
* Usually only called once: If 'getcwd' is
* called before 'chdir' is ever called. */
Tcl_FSChdirProc *chdirProc; /* Called by 'Tcl_FSChdir()'. For a virtual
* filesystem, chdirProc just returns zero
* (success) if the pathname is a valid
* directory, and some other value otherwise.
* For A real filesystem, chdirProc performs
* the correct action, e.g. calls the system
* 'chdir' function. If not implemented, then
* 'cd' and 'pwd' fail for a pathname in this
* filesystem. On success Tcl stores the
* pathname for use by GetCwd. If NULL, Tcl
* performs records the pathname as the new
* current directory if it passes a series of
* directory access checks. */
} Tcl_Filesystem;
/*
* The following definitions are used as values for the 'linkAction' flag to
* Tcl_FSLink, or the linkProc of any filesystem. Any combination of flags can
* be given. For link creation, the linkProc should create a link which
* matches any of the types given.
|
| ︙ | ︙ | |||
1691 1692 1693 1694 1695 1696 1697 |
* token.
*/
typedef struct Tcl_Token {
int type; /* Type of token, such as TCL_TOKEN_WORD; see
* below for valid types. */
const char *start; /* First character in token. */
| | | | 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 |
* token.
*/
typedef struct Tcl_Token {
int type; /* Type of token, such as TCL_TOKEN_WORD; see
* below for valid types. */
const char *start; /* First character in token. */
int size; /* Number of bytes in token. */
int numComponents; /* If this token is composed of other tokens,
* this field tells how many of them there are
* (including components of components, etc.).
* The component tokens immediately follow
* this one. */
} Tcl_Token;
/*
|
| ︙ | ︙ | |||
1758 1759 1760 1761 1762 1763 1764 | * is described by a TCL_TOKEN_SUB_EXPR token * followed by the TCL_TOKEN_OPERATOR token for * the operator, then TCL_TOKEN_SUB_EXPR tokens * for the left then the right operands. * TCL_TOKEN_OPERATOR - The token describes one expression operator. * An operator might be the name of a math * function such as "abs". A TCL_TOKEN_OPERATOR | | | 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 |
* is described by a TCL_TOKEN_SUB_EXPR token
* followed by the TCL_TOKEN_OPERATOR token for
* the operator, then TCL_TOKEN_SUB_EXPR tokens
* for the left then the right operands.
* TCL_TOKEN_OPERATOR - The token describes one expression operator.
* An operator might be the name of a math
* function such as "abs". A TCL_TOKEN_OPERATOR
* token is always preceded by one
* TCL_TOKEN_SUB_EXPR token for the operator's
* subexpression, and is followed by zero or more
* TCL_TOKEN_SUB_EXPR tokens for the operator's
* operands. NumComponents is always 0.
* TCL_TOKEN_EXPAND_WORD - This token is just like TCL_TOKEN_WORD except
* that it marks a word that began with the
* literal character prefix "{*}". This word is
|
| ︙ | ︙ | |||
1806 1807 1808 1809 1810 1811 1812 |
*/
#define NUM_STATIC_TOKENS 20
typedef struct Tcl_Parse {
const char *commentStart; /* Pointer to # that begins the first of one
* or more comments preceding the command. */
| | | 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 |
*/
#define NUM_STATIC_TOKENS 20
typedef struct Tcl_Parse {
const char *commentStart; /* Pointer to # that begins the first of one
* or more comments preceding the command. */
int commentSize; /* Number of bytes in comments (up through
* newline character that terminates the last
* comment). If there were no comments, this
* field is 0. */
const char *commandStart; /* First character in first word of
* command. */
int commandSize; /* Number of bytes in command, including first
* character of first word, up through the
|
| ︙ | ︙ | |||
1874 1875 1876 1877 1878 1879 1880 |
* encoding type. */
Tcl_EncodingConvertProc *toUtfProc;
/* Function to convert from external encoding
* into UTF-8. */
Tcl_EncodingConvertProc *fromUtfProc;
/* Function to convert from UTF-8 into
* external encoding. */
| | | | 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 |
* encoding type. */
Tcl_EncodingConvertProc *toUtfProc;
/* Function to convert from external encoding
* into UTF-8. */
Tcl_EncodingConvertProc *fromUtfProc;
/* Function to convert from UTF-8 into
* external encoding. */
Tcl_EncodingFreeProc *freeProc;
/* If non-NULL, function to call when this
* encoding is deleted. */
ClientData clientData; /* Arbitrary value associated with encoding
* type. Passed to conversion functions. */
int nullSize; /* Number of zero bytes that signify
* end-of-string in this encoding. This number
* is used to determine the source string
* length when the srcLen argument is
* negative. Must be 1 or 2. */
} Tcl_EncodingType;
|
| ︙ | ︙ | |||
1906 1907 1908 1909 1910 1911 1912 | * block in a (potentially multi-block) input * stream. Tells the conversion routine to * perform any finalization that needs to occur * after the last byte is converted and then to * reset to an initial state. If the source * buffer contains the entire input stream to be * converted, this flag should be set. | | | | | | | | | | | | | < | | | | | | | | | 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 | * block in a (potentially multi-block) input * stream. Tells the conversion routine to * perform any finalization that needs to occur * after the last byte is converted and then to * reset to an initial state. If the source * buffer contains the entire input stream to be * converted, this flag should be set. * TCL_ENCODING_STOPONERROR - If set, the converter returns immediately upon * encountering an invalid byte sequence or a * source character that has no mapping in the * target encoding. If clear, the converter * substitues the problematic character(s) with * one or more "close" characters in the * destination buffer and then continues to * convert the source. * TCL_ENCODING_NO_TERMINATE - If set, Tcl_ExternalToUtf does not append a * terminating NUL byte. Since it does not need * an extra byte for a terminating NUL, it fills * all dstLen bytes with encoded UTF-8 content if * needed. If clear, a byte is reserved in the * dst space for NUL termination, and a * terminating NUL is appended. * TCL_ENCODING_CHAR_LIMIT - If set and dstCharsPtr is not NULL, then * Tcl_ExternalToUtf takes the initial value of * *dstCharsPtr as a limit of the maximum number * of chars to produce in the encoded UTF-8 * content. Otherwise, the number of chars * produced is controlled only by other limiting * factors. */ #define TCL_ENCODING_START 0x01 #define TCL_ENCODING_END 0x02 #define TCL_ENCODING_STOPONERROR 0x04 #define TCL_ENCODING_NO_TERMINATE 0x08 #define TCL_ENCODING_CHAR_LIMIT 0x10 |
| ︙ | ︙ | |||
1972 1973 1974 1975 1976 1977 1978 | #define TCL_CONVERT_MULTIBYTE (-1) #define TCL_CONVERT_SYNTAX (-2) #define TCL_CONVERT_UNKNOWN (-3) #define TCL_CONVERT_NOSPACE (-4) /* * The maximum number of bytes that are necessary to represent a single | | | | | | < | | | | | < < < < | | 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 |
#define TCL_CONVERT_MULTIBYTE (-1)
#define TCL_CONVERT_SYNTAX (-2)
#define TCL_CONVERT_UNKNOWN (-3)
#define TCL_CONVERT_NOSPACE (-4)
/*
* The maximum number of bytes that are necessary to represent a single
* Unicode character in UTF-8. The valid values are 3 and 4
* (or perhaps 1 if we want to support a non-unicode enabled core). If 3,
* then Tcl_UniChar must be 2-bytes in size (UTF-16) (the default). If > 3,
* then Tcl_UniChar must be 4-bytes in size (UCS-4). At this time UTF-16 mode
* is the default and recommended mode.
*/
#ifndef TCL_UTF_MAX
#define TCL_UTF_MAX 3
#endif
/*
* This represents a Unicode character. Any changes to this should also be
* reflected in regcustom.h.
*/
#if TCL_UTF_MAX > 3
/*
* int isn't 100% accurate as it should be a strict 4-byte value
* (perhaps wchar_t). ILP64/SILP64 systems may have troubles. The
* size of this value must be reflected correctly in regcustom.h.
*/
typedef int Tcl_UniChar;
#else
typedef unsigned short Tcl_UniChar;
#endif
/*
*----------------------------------------------------------------------------
* TIP #59: The following structure is used in calls 'Tcl_RegisterConfig' to
|
| ︙ | ︙ | |||
2031 2032 2033 2034 2035 2036 2037 | #define TCL_LIMIT_TIME 0x02 /* * Structure containing information about a limit handler to be called when a * command- or time-limit is exceeded by an interpreter. */ | | | > > > > | > > > | | > | < < > | | 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 |
#define TCL_LIMIT_TIME 0x02
/*
* Structure containing information about a limit handler to be called when a
* command- or time-limit is exceeded by an interpreter.
*/
typedef void (Tcl_LimitHandlerProc) (ClientData clientData, Tcl_Interp *interp);
typedef void (Tcl_LimitHandlerDeleteProc) (ClientData clientData);
#if 0
/*
*----------------------------------------------------------------------------
* We would like to provide an anonymous structure "mp_int" here, which is
* compatible with libtommath's "mp_int", but without duplicating anything
* from <tommath.h> or including <tommath.h> here. But the libtommath project
* didn't honor our request. See: <https://github.com/libtom/libtommath/pull/473>
*
* That's why this part is commented out, and we are using (void *) in
* various API's in stead of the more correct (mp_int *).
*/
#ifndef MP_INT_DECLARED
#define MP_INT_DECLARED
typedef struct mp_int mp_int;
#endif
#endif
/*
*----------------------------------------------------------------------------
* Definitions needed for Tcl_ParseArgvObj routines.
* Based on tkArgv.c.
* Modifications from the original are copyright (c) Sam Bromley 2006
*/
typedef struct {
int type; /* Indicates the option type; see below. */
const char *keyStr; /* The key string that flags the option in the
* argv array. */
void *srcPtr; /* Value to be used in setting dst; usage
* depends on type.*/
void *dstPtr; /* Address of value to be modified; usage
* depends on type.*/
const char *helpStr; /* Documentation message describing this
* option. */
ClientData clientData; /* Word to pass to function callbacks. */
} Tcl_ArgvInfo;
/*
* Legal values for the type field of a Tcl_ArgInfo: see the user
* documentation for details.
*/
|
| ︙ | ︙ | |||
2086 2087 2088 2089 2090 2091 2092 | #define TCL_ARGV_END 23 /* * Types of callback functions for the TCL_ARGV_FUNC and TCL_ARGV_GENFUNC * argument types: */ | | | | 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 | #define TCL_ARGV_END 23 /* * Types of callback functions for the TCL_ARGV_FUNC and TCL_ARGV_GENFUNC * argument types: */ typedef int (Tcl_ArgvFuncProc)(ClientData clientData, Tcl_Obj *objPtr, void *dstPtr); typedef int (Tcl_ArgvGenFuncProc)(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, void *dstPtr); /* * Shorthand for commonly used argTable entries. */ #define TCL_ARGV_AUTO_HELP \ |
| ︙ | ︙ | |||
2161 2162 2163 2164 2165 2166 2167 | *---------------------------------------------------------------------------- * Definitions needed for the Tcl_OpenTcpServerEx function. [TIP #456] */ #define TCL_TCPSERVER_REUSEADDR (1<<0) #define TCL_TCPSERVER_REUSEPORT (1<<1) /* | | | | | | | | | | | 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 |
*----------------------------------------------------------------------------
* Definitions needed for the Tcl_OpenTcpServerEx function. [TIP #456]
*/
#define TCL_TCPSERVER_REUSEADDR (1<<0)
#define TCL_TCPSERVER_REUSEPORT (1<<1)
/*
* Constants for special int-typed values, see TIP #494
*/
#define TCL_IO_FAILURE (-1)
#define TCL_AUTO_LENGTH (-1)
#define TCL_INDEX_NONE (-1)
/*
*----------------------------------------------------------------------------
* Single public declaration for NRE.
*/
typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp,
int result);
/*
*----------------------------------------------------------------------------
* The following constant is used to test for older versions of Tcl in the
* stubs tables.
*/
#define TCL_STUB_MAGIC ((int) 0xFCA3BACF)
/*
* The following function is required to be defined in all stubs aware
* extensions. The function is actually implemented in the stub library, not
* the main Tcl library, although there is a trivial implementation in the
* main library in case an extension is statically linked into an application.
*/
const char * Tcl_InitStubs(Tcl_Interp *interp, const char *version,
int exact, int magic);
const char * TclTomMathInitializeStubs(Tcl_Interp *interp,
const char *version, int epoch, int revision);
#if defined(_WIN32)
TCL_NORETURN void Tcl_ConsolePanic(const char *format, ...);
#else
# define Tcl_ConsolePanic ((Tcl_PanicProc *)0)
#endif
#ifdef USE_TCL_STUBS
#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE
# define Tcl_InitStubs(interp, version, exact) \
(Tcl_InitStubs)(interp, version, \
(exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \
|
| ︙ | ︙ | |||
2232 2233 2234 2235 2236 2237 2238 | /* * Public functions that are not accessible via the stubs table. * Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171] */ #define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \ ((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp)())) | | < < | < | < < < < | > > | 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 | /* * Public functions that are not accessible via the stubs table. * Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171] */ #define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \ ((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp)())) EXTERN void Tcl_MainEx(int argc, char **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version, int exact); EXTERN void Tcl_InitSubsystems(void); EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); #ifdef _WIN32 EXTERN int TclZipfs_AppHook(int *argc, wchar_t ***argv); #else EXTERN int TclZipfs_AppHook(int *argc, char ***argv); #endif /* *---------------------------------------------------------------------------- * Include the public function declarations that are accessible via the stubs * table. |
| ︙ | ︙ | |||
2272 2273 2274 2275 2276 2277 2278 | # define TCLAPI MODULE_SCOPE #endif #include "tclPlatDecls.h" /* *---------------------------------------------------------------------------- | | > | > > | > | > | > | > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
# define TCLAPI MODULE_SCOPE
#endif
#include "tclPlatDecls.h"
/*
*----------------------------------------------------------------------------
* The following declarations either map ckalloc and ckfree to malloc and
* free, or they map them to functions with all sorts of debugging hooks
* defined in tclCkalloc.c.
*/
#ifdef TCL_MEM_DEBUG
# define ckalloc(x) \
((void *) Tcl_DbCkalloc((unsigned)(x), __FILE__, __LINE__))
# define ckfree(x) \
Tcl_DbCkfree((char *)(x), __FILE__, __LINE__)
# define ckrealloc(x,y) \
((void *) Tcl_DbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__))
# define attemptckalloc(x) \
((void *) Tcl_AttemptDbCkalloc((unsigned)(x), __FILE__, __LINE__))
# define attemptckrealloc(x,y) \
((void *) Tcl_AttemptDbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__))
#else /* !TCL_MEM_DEBUG */
/*
* If we are not using the debugging allocator, we should call the Tcl_Alloc,
* et al. routines in order to guarantee that every module is using the same
* memory allocator both inside and outside of the Tcl library.
*/
# define ckalloc(x) \
((void *) Tcl_Alloc((unsigned)(x)))
# define ckfree(x) \
Tcl_Free((char *)(x))
# define ckrealloc(x,y) \
((void *) Tcl_Realloc((char *)(x), (unsigned)(y)))
# define attemptckalloc(x) \
((void *) Tcl_AttemptAlloc((unsigned)(x)))
# define attemptckrealloc(x,y) \
((void *) Tcl_AttemptRealloc((char *)(x), (unsigned)(y)))
# undef Tcl_InitMemory
# define Tcl_InitMemory(x)
# undef Tcl_DumpActiveMemory
# define Tcl_DumpActiveMemory(x)
# undef Tcl_ValidateAllMemory
# define Tcl_ValidateAllMemory(x,y)
#endif /* !TCL_MEM_DEBUG */
#ifdef TCL_MEM_DEBUG
# undef Tcl_IncrRefCount
# define Tcl_IncrRefCount(objPtr) \
Tcl_DbIncrRefCount(objPtr, __FILE__, __LINE__)
# undef Tcl_DecrRefCount
# define Tcl_DecrRefCount(objPtr) \
Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)
# undef Tcl_IsShared
# define Tcl_IsShared(objPtr) \
Tcl_DbIsShared(objPtr, __FILE__, __LINE__)
#else
# undef Tcl_IncrRefCount
# define Tcl_IncrRefCount(objPtr) \
++(objPtr)->refCount
/*
* 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
/*
* Macros and definitions that help to debug the use of Tcl objects. When
* TCL_MEM_DEBUG is defined, the Tcl_New declarations are overridden to call
* debugging versions of the object creation functions.
*/
|
| ︙ | ︙ | |||
2350 2351 2352 2353 2354 2355 2356 | /* *---------------------------------------------------------------------------- * Macros for clients to use to access fields of hash entries: */ #define Tcl_GetHashValue(h) ((h)->clientData) | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | /* *---------------------------------------------------------------------------- * Macros for clients to use to access fields of hash entries: */ #define Tcl_GetHashValue(h) ((h)->clientData) #define Tcl_SetHashValue(h, value) ((h)->clientData = (ClientData) (value)) #define Tcl_GetHashKey(tablePtr, h) \ ((void *) (((tablePtr)->keyType == TCL_ONE_WORD_KEYS || \ (tablePtr)->keyType == TCL_CUSTOM_PTR_KEYS) \ ? (h)->key.oneWordValue \ : (h)->key.string)) /* * Macros to use for clients to use to invoke find and create functions for * hash tables: */ #undef Tcl_FindHashEntry #define Tcl_FindHashEntry(tablePtr, key) \ (*((tablePtr)->findProc))(tablePtr, (const char *)(key)) #undef Tcl_CreateHashEntry #define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ (*((tablePtr)->createProc))(tablePtr, (const char *)(key), newPtr) /* *---------------------------------------------------------------------------- * Deprecated Tcl functions: */ #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* * These function have been renamed. The old names are deprecated, but we * define these macros for backwards compatibility. */ # define Tcl_Ckalloc Tcl_Alloc # define Tcl_Ckfree Tcl_Free # define Tcl_Ckrealloc Tcl_Realloc # define Tcl_Return Tcl_SetResult # define Tcl_TildeSubst Tcl_TranslateFileName #if !defined(__APPLE__) /* On OSX, there is a conflict with "mach/mach.h" */ # define panic Tcl_Panic #endif # define panicVA Tcl_PanicVA /* *---------------------------------------------------------------------------- * Convenience declaration of Tcl_AppInit for backwards compatibility. This * function is not *implemented* by the tcl library, so the storage class is * neither DLLEXPORT nor DLLIMPORT. */ extern Tcl_AppInitProc Tcl_AppInit; #endif /* !TCL_NO_DEPRECATED */ #endif /* RC_INVOKED */ /* * end block for C++ */ #ifdef __cplusplus |
| ︙ | ︙ |
Changes to generic/tclAlloc.c.
| ︙ | ︙ | |||
64 65 66 67 68 69 70 | #define overMagic1 ovu.magic1 #define bucketIndex ovu.index #define rangeCheckMagic ovu.rmagic #define realBlockSize ovu.size }; | | | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | #define overMagic1 ovu.magic1 #define bucketIndex ovu.index #define rangeCheckMagic ovu.rmagic #define realBlockSize ovu.size }; #define MAGIC 0xEF /* magic # on accounting info */ #define RMAGIC 0x5555 /* magic # on range info */ #ifndef NDEBUG #define RSLOP sizeof(unsigned short) #else #define RSLOP 0 #endif |
| ︙ | ︙ | |||
247 248 249 250 251 252 253 | * None. * *---------------------------------------------------------------------- */ void * TclpAlloc( | | | | | | | | | | 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 |
* None.
*
*----------------------------------------------------------------------
*/
void *
TclpAlloc(
unsigned int numBytes) /* Number of bytes to allocate. */
{
union overhead *overPtr;
size_t bucket;
unsigned amount;
struct block *bigBlockPtr = NULL;
if (!allocInit) {
/*
* We have to make the "self initializing" because Tcl_Alloc may be
* used before any other part of Tcl. E.g., see main() for tclsh!
*/
TclInitAlloc();
}
Tcl_MutexLock(allocMutexPtr);
/*
* First the simple case: we simple allocate big blocks directly.
*/
if (numBytes >= MAXMALLOC - OVERHEAD) {
if (numBytes <= UINT_MAX - OVERHEAD -sizeof(struct block)) {
bigBlockPtr = (struct block *) TclpSysAlloc(
sizeof(struct block) + OVERHEAD + numBytes, 0);
}
if (bigBlockPtr == NULL) {
Tcl_MutexUnlock(allocMutexPtr);
return NULL;
}
bigBlockPtr->nextPtr = bigBlocks.nextPtr;
bigBlocks.nextPtr = bigBlockPtr;
bigBlockPtr->prevPtr = &bigBlocks;
bigBlockPtr->nextPtr->prevPtr = bigBlockPtr;
overPtr = (union overhead *) (bigBlockPtr + 1);
overPtr->overMagic0 = overPtr->overMagic1 = MAGIC;
overPtr->bucketIndex = 0xFF;
#ifdef MSTATS
numMallocs[NBUCKETS]++;
#endif
#ifndef NDEBUG
/*
* Record allocated size of block and bound space with magic numbers.
*/
overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1);
overPtr->rangeCheckMagic = RMAGIC;
BLOCK_END(overPtr) = RMAGIC;
#endif
Tcl_MutexUnlock(allocMutexPtr);
return (char *)(overPtr+1);
}
/*
* Convert amount of memory requested into closest block size stored in
* hash buckets which satisfies request. Account for space used per block
* for accounting.
*/
|
| ︙ | ︙ | |||
341 342 343 344 345 346 347 |
/*
* Remove from linked list
*/
nextf[bucket] = overPtr->next;
overPtr->overMagic0 = overPtr->overMagic1 = MAGIC;
| | | 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 |
/*
* Remove from linked list
*/
nextf[bucket] = overPtr->next;
overPtr->overMagic0 = overPtr->overMagic1 = MAGIC;
overPtr->bucketIndex = UCHAR(bucket);
#ifdef MSTATS
numMallocs[bucket]++;
#endif
#ifndef NDEBUG
/*
|
| ︙ | ︙ | |||
383 384 385 386 387 388 389 |
*----------------------------------------------------------------------
*/
static void
MoreCore(
size_t bucket) /* What bucket to allocate to. */
{
| | | > | | 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 |
*----------------------------------------------------------------------
*/
static void
MoreCore(
size_t bucket) /* What bucket to allocate to. */
{
union overhead *overPtr;
size_t size; /* size of desired block */
size_t amount; /* amount to allocate */
size_t numBlocks; /* how many blocks we get */
struct block *blockPtr;
/*
* sbrk_size <= 0 only for big, FLUFFY, requests (about 2^30 bytes on a
* VAX, I think) or for a negative arg.
*/
size = ((size_t)1) << (bucket + 3);
ASSERT(size > 0);
amount = MAXMALLOC;
numBlocks = amount / size;
ASSERT(numBlocks*size == amount);
blockPtr = (struct block *) TclpSysAlloc(
(sizeof(struct block) + amount), 1);
/* no more room! */
if (blockPtr == NULL) {
return;
}
blockPtr->nextPtr = blockList;
blockList = blockPtr;
|
| ︙ | ︙ | |||
443 444 445 446 447 448 449 |
*----------------------------------------------------------------------
*/
void
TclpFree(
void *oldPtr) /* Pointer to memory to free. */
{
| | | | | 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 |
*----------------------------------------------------------------------
*/
void
TclpFree(
void *oldPtr) /* Pointer to memory to free. */
{
size_t size;
union overhead *overPtr;
struct block *bigBlockPtr;
if (oldPtr == NULL) {
return;
}
Tcl_MutexLock(allocMutexPtr);
overPtr = (union overhead *)((caddr_t)oldPtr - sizeof(union overhead));
ASSERT(overPtr->overMagic0 == MAGIC); /* make sure it was in use */
ASSERT(overPtr->overMagic1 == MAGIC);
if (overPtr->overMagic0 != MAGIC || overPtr->overMagic1 != MAGIC) {
Tcl_MutexUnlock(allocMutexPtr);
return;
}
RANGE_ASSERT(overPtr->rangeCheckMagic == RMAGIC);
RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC);
size = overPtr->bucketIndex;
if (size == 0xFF) {
#ifdef MSTATS
numMallocs[NBUCKETS]--;
#endif
bigBlockPtr = (struct block *) overPtr - 1;
bigBlockPtr->prevPtr->nextPtr = bigBlockPtr->nextPtr;
bigBlockPtr->nextPtr->prevPtr = bigBlockPtr->prevPtr;
|
| ︙ | ︙ | |||
507 508 509 510 511 512 513 |
*
*----------------------------------------------------------------------
*/
void *
TclpRealloc(
void *oldPtr, /* Pointer to alloced block. */
| | | 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 |
*
*----------------------------------------------------------------------
*/
void *
TclpRealloc(
void *oldPtr, /* Pointer to alloced block. */
unsigned int numBytes) /* New size of memory. */
{
int i;
union overhead *overPtr;
struct block *bigBlockPtr;
int expensive;
size_t maxSize;
|
| ︙ | ︙ | |||
538 539 540 541 542 543 544 |
RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC);
i = overPtr->bucketIndex;
/*
* If the block isn't in a bin, just realloc it.
*/
| | | 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 |
RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC);
i = overPtr->bucketIndex;
/*
* If the block isn't in a bin, just realloc it.
*/
if (i == 0xFF) {
struct block *prevPtr, *nextPtr;
bigBlockPtr = (struct block *) overPtr - 1;
prevPtr = bigBlockPtr->prevPtr;
nextPtr = bigBlockPtr->nextPtr;
bigBlockPtr = (struct block *) TclpSysRealloc(bigBlockPtr,
sizeof(struct block) + OVERHEAD + numBytes);
if (bigBlockPtr == NULL) {
|
| ︙ | ︙ | |||
576 577 578 579 580 581 582 | */ overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1); BLOCK_END(overPtr) = RMAGIC; #endif Tcl_MutexUnlock(allocMutexPtr); | | | 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 |
*/
overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1);
BLOCK_END(overPtr) = RMAGIC;
#endif
Tcl_MutexUnlock(allocMutexPtr);
return (void *)(overPtr+1);
}
maxSize = 1 << (i+3);
expensive = 0;
if (numBytes+OVERHEAD > maxSize) {
expensive = 1;
} else if (i>0 && numBytes+OVERHEAD < maxSize/2) {
expensive = 1;
|
| ︙ | ︙ | |||
640 641 642 643 644 645 646 |
*/
#ifdef MSTATS
void
mstats(
char *s) /* Where to write info. */
{
| | | | 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 |
*/
#ifdef MSTATS
void
mstats(
char *s) /* Where to write info. */
{
unsigned int i, j;
union overhead *overPtr;
size_t totalFree = 0, totalUsed = 0;
Tcl_MutexLock(allocMutexPtr);
fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s);
for (i = 0; i < NBUCKETS; i++) {
for (j=0, overPtr=nextf[i]; overPtr; overPtr=overPtr->next, j++) {
|
| ︙ | ︙ | |||
687 688 689 690 691 692 693 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < | < | 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void *
TclpAlloc(
unsigned int numBytes) /* Number of bytes to allocate. */
{
return malloc(numBytes);
}
/*
*----------------------------------------------------------------------
*
* TclpFree --
*
* Free memory.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclpFree(
void *oldPtr) /* Pointer to memory to free. */
{
free(oldPtr);
return;
}
|
| ︙ | ︙ | |||
739 740 741 742 743 744 745 |
*
*----------------------------------------------------------------------
*/
void *
TclpRealloc(
void *oldPtr, /* Pointer to alloced block. */
| | | 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 |
*
*----------------------------------------------------------------------
*/
void *
TclpRealloc(
void *oldPtr, /* Pointer to alloced block. */
unsigned int numBytes) /* New size of memory. */
{
return realloc(oldPtr, numBytes);
}
#endif /* !USE_TCLALLOC */
#endif /* !TCL_THREADS */
|
| ︙ | ︙ |
Changes to generic/tclAssembly.c.
| ︙ | ︙ | |||
283 284 285 286 287 288 289 | static void FreeAssemblyEnv(AssemblyEnv*); static int GetBooleanOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetListIndexOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetIntegerOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetNextOperand(AssemblyEnv*, Tcl_Token**, Tcl_Obj**); static void LookForFreshCatches(BasicBlock*, BasicBlock**); static void MoveCodeForJumps(AssemblyEnv*, int); | | < | 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 | static void FreeAssemblyEnv(AssemblyEnv*); static int GetBooleanOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetListIndexOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetIntegerOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetNextOperand(AssemblyEnv*, Tcl_Token**, Tcl_Obj**); static void LookForFreshCatches(BasicBlock*, BasicBlock**); static void MoveCodeForJumps(AssemblyEnv*, int); static void MoveExceptionRangesToBasicBlock(AssemblyEnv*, int); static AssemblyEnv* NewAssemblyEnv(CompileEnv*, int); static int ProcessCatches(AssemblyEnv*); static int ProcessCatchesInBasicBlock(AssemblyEnv*, BasicBlock*, BasicBlock*, enum BasicBlockCatchState, int); static void ResetVisitedBasicBlocks(AssemblyEnv*); static void ResolveJumpTableTargets(AssemblyEnv*, BasicBlock*); static void ReportUndefinedLabel(AssemblyEnv*, BasicBlock*, |
| ︙ | ︙ | |||
406 407 408 409 410 411 412 413 414 415 416 417 418 419 |
{"jump4", ASSEM_JUMP4, INST_JUMP4, 0, 0},
{"jumpFalse", ASSEM_JUMP, INST_JUMP_FALSE1, 1, 0},
{"jumpFalse4", ASSEM_JUMP4, INST_JUMP_FALSE4, 1, 0},
{"jumpTable", ASSEM_JUMPTABLE,INST_JUMP_TABLE, 1, 0},
{"jumpTrue", ASSEM_JUMP, INST_JUMP_TRUE1, 1, 0},
{"jumpTrue4", ASSEM_JUMP4, INST_JUMP_TRUE4, 1, 0},
{"label", ASSEM_LABEL, 0, 0, 0},
{"lappend", ASSEM_LVT, (INST_LAPPEND_SCALAR1<<8
| INST_LAPPEND_SCALAR4),
1, 1},
{"lappendArray", ASSEM_LVT, (INST_LAPPEND_ARRAY1<<8
| INST_LAPPEND_ARRAY4),2, 1},
{"lappendArrayStk", ASSEM_1BYTE, INST_LAPPEND_ARRAY_STK, 3, 1},
{"lappendList", ASSEM_LVT4, INST_LAPPEND_LIST, 1, 1},
| > | 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 |
{"jump4", ASSEM_JUMP4, INST_JUMP4, 0, 0},
{"jumpFalse", ASSEM_JUMP, INST_JUMP_FALSE1, 1, 0},
{"jumpFalse4", ASSEM_JUMP4, INST_JUMP_FALSE4, 1, 0},
{"jumpTable", ASSEM_JUMPTABLE,INST_JUMP_TABLE, 1, 0},
{"jumpTrue", ASSEM_JUMP, INST_JUMP_TRUE1, 1, 0},
{"jumpTrue4", ASSEM_JUMP4, INST_JUMP_TRUE4, 1, 0},
{"label", ASSEM_LABEL, 0, 0, 0},
{"land", ASSEM_1BYTE, INST_LAND, 2, 1},
{"lappend", ASSEM_LVT, (INST_LAPPEND_SCALAR1<<8
| INST_LAPPEND_SCALAR4),
1, 1},
{"lappendArray", ASSEM_LVT, (INST_LAPPEND_ARRAY1<<8
| INST_LAPPEND_ARRAY4),2, 1},
{"lappendArrayStk", ASSEM_1BYTE, INST_LAPPEND_ARRAY_STK, 3, 1},
{"lappendList", ASSEM_LVT4, INST_LAPPEND_LIST, 1, 1},
|
| ︙ | ︙ | |||
433 434 435 436 437 438 439 440 441 442 443 444 445 446 |
{"listNotIn", ASSEM_1BYTE, INST_LIST_NOT_IN, 2, 1},
{"load", ASSEM_LVT, (INST_LOAD_SCALAR1 << 8
| INST_LOAD_SCALAR4), 0, 1},
{"loadArray", ASSEM_LVT, (INST_LOAD_ARRAY1<<8
| INST_LOAD_ARRAY4), 1, 1},
{"loadArrayStk", ASSEM_1BYTE, INST_LOAD_ARRAY_STK, 2, 1},
{"loadStk", ASSEM_1BYTE, INST_LOAD_STK, 1, 1},
{"lsetFlat", ASSEM_LSET_FLAT,INST_LSET_FLAT, INT_MIN,1},
{"lsetList", ASSEM_1BYTE, INST_LSET_LIST, 3, 1},
{"lshift", ASSEM_1BYTE, INST_LSHIFT, 2, 1},
{"lt", ASSEM_1BYTE, INST_LT, 2, 1},
{"mod", ASSEM_1BYTE, INST_MOD, 2, 1},
{"mult", ASSEM_1BYTE, INST_MULT, 2, 1},
{"neq", ASSEM_1BYTE, INST_NEQ, 2, 1},
| > | 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 |
{"listNotIn", ASSEM_1BYTE, INST_LIST_NOT_IN, 2, 1},
{"load", ASSEM_LVT, (INST_LOAD_SCALAR1 << 8
| INST_LOAD_SCALAR4), 0, 1},
{"loadArray", ASSEM_LVT, (INST_LOAD_ARRAY1<<8
| INST_LOAD_ARRAY4), 1, 1},
{"loadArrayStk", ASSEM_1BYTE, INST_LOAD_ARRAY_STK, 2, 1},
{"loadStk", ASSEM_1BYTE, INST_LOAD_STK, 1, 1},
{"lor", ASSEM_1BYTE, INST_LOR, 2, 1},
{"lsetFlat", ASSEM_LSET_FLAT,INST_LSET_FLAT, INT_MIN,1},
{"lsetList", ASSEM_1BYTE, INST_LSET_LIST, 3, 1},
{"lshift", ASSEM_1BYTE, INST_LSHIFT, 2, 1},
{"lt", ASSEM_1BYTE, INST_LT, 2, 1},
{"mod", ASSEM_1BYTE, INST_MOD, 2, 1},
{"mult", ASSEM_1BYTE, INST_MULT, 2, 1},
{"neq", ASSEM_1BYTE, INST_NEQ, 2, 1},
|
| ︙ | ︙ | |||
500 501 502 503 504 505 506 |
{"unsetArrayStk", ASSEM_BOOL, INST_UNSET_ARRAY_STK, 2, 0},
{"unsetStk", ASSEM_BOOL, INST_UNSET_STK, 1, 0},
{"uplus", ASSEM_1BYTE, INST_UPLUS, 1, 1},
{"upvar", ASSEM_LVT4, INST_UPVAR, 2, 1},
{"variable", ASSEM_LVT4, INST_VARIABLE, 1, 0},
{"verifyDict", ASSEM_1BYTE, INST_DICT_VERIFY, 1, 0},
{"yield", ASSEM_1BYTE, INST_YIELD, 1, 1},
| | | 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 |
{"unsetArrayStk", ASSEM_BOOL, INST_UNSET_ARRAY_STK, 2, 0},
{"unsetStk", ASSEM_BOOL, INST_UNSET_STK, 1, 0},
{"uplus", ASSEM_1BYTE, INST_UPLUS, 1, 1},
{"upvar", ASSEM_LVT4, INST_UPVAR, 2, 1},
{"variable", ASSEM_LVT4, INST_VARIABLE, 1, 0},
{"verifyDict", ASSEM_1BYTE, INST_DICT_VERIFY, 1, 0},
{"yield", ASSEM_1BYTE, INST_YIELD, 1, 1},
{NULL, ASSEM_1BYTE, 0, 0, 0}
};
/*
* List of instructions that cannot throw an exception under any
* circumstances. These instructions are the ones that are permissible after
* an exception is caught but before the corresponding exception range is
* popped from the stack.
|
| ︙ | ︙ | |||
671 672 673 674 675 676 677 |
int tblIdx, /* Table index in TalInstructionTable of op */
int count) /* Operand count for variadic ops */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* bbPtr = assemEnvPtr->curr_bb;
/* Current basic block */
| | | 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 |
int tblIdx, /* Table index in TalInstructionTable of op */
int count) /* Operand count for variadic ops */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* bbPtr = assemEnvPtr->curr_bb;
/* Current basic block */
int op = TalInstructionTable[tblIdx].tclInstCode & 0xFF;
/*
* If this is the first instruction in a basic block, record its line
* number.
*/
if (bbPtr->startOffset == envPtr->codeNext - envPtr->codeStart) {
|
| ︙ | ︙ | |||
733 734 735 736 737 738 739 |
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* bbPtr = assemEnvPtr->curr_bb;
/* Current basic block */
int op = TalInstructionTable[tblIdx].tclInstCode;
| | | | | 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 |
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* bbPtr = assemEnvPtr->curr_bb;
/* Current basic block */
int op = TalInstructionTable[tblIdx].tclInstCode;
if (param <= 0xFF) {
op >>= 8;
} else {
op &= 0xFF;
}
TclEmitInt1(op, envPtr);
if (param <= 0xFF) {
TclEmitInt1(param, envPtr);
} else {
TclEmitInt4(param, envPtr);
}
TclUpdateAtCmdStart(op, envPtr);
BBUpdateStackReqs(bbPtr, tblIdx, count);
}
|
| ︙ | ︙ | |||
767 768 769 770 771 772 773 | * include whatever the code does. * *----------------------------------------------------------------------------- */ int Tcl_AssembleObjCmd( | | | | | 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 |
* include whatever the code does.
*
*-----------------------------------------------------------------------------
*/
int
Tcl_AssembleObjCmd(
ClientData clientData, /* clientData */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
/*
* Boilerplate - make sure that there is an NRE trampoline on the C stack
* because there needs to be one in place to execute bytecode.
*/
return Tcl_NRCallObjProc(interp, TclNRAssembleObjCmd, clientData, objc, objv);
}
int
TclNRAssembleObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
ByteCode *codePtr; /* Pointer to the bytecode to execute */
Tcl_Obj* backtrace; /* Object where extra error information is
* constructed. */
|
| ︙ | ︙ | |||
847 848 849 850 851 852 853 |
CompileAssembleObj(
Tcl_Interp *interp, /* Tcl interpreter */
Tcl_Obj *objPtr) /* Source code to assemble */
{
Interp *iPtr = (Interp *) interp;
/* Internals of the interpreter */
CompileEnv compEnv; /* Compilation environment structure */
| | | | 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 |
CompileAssembleObj(
Tcl_Interp *interp, /* Tcl interpreter */
Tcl_Obj *objPtr) /* Source code to assemble */
{
Interp *iPtr = (Interp *) interp;
/* Internals of the interpreter */
CompileEnv compEnv; /* Compilation environment structure */
ByteCode *codePtr = NULL;
/* Bytecode resulting from the assembly */
Namespace* namespacePtr; /* Namespace in which variable and command
* names in the bytecode resolve */
int status; /* Status return from Tcl_AssembleCode */
const char* source; /* String representation of the source code */
int sourceLen; /* Length of the source code in bytes */
/*
* Get the expression ByteCode from the object. If it exists, make sure it
* is valid in the current context.
*/
ByteCodeGetIntRep(objPtr, &assembleCodeType, codePtr);
|
| ︙ | ︙ | |||
955 956 957 958 959 960 961 |
*/
int
TclCompileAssembleCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < < | 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 |
*/
int
TclCompileAssembleCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr; /* Token in the input script */
int numCommands = envPtr->numCommands;
int offset = envPtr->codeNext - envPtr->codeStart;
int depth = envPtr->currStackDepth;
/*
* Make sure that the command has a single arg that is a simple word.
*/
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
987 988 989 990 991 992 993 |
*/
if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start,
tokenPtr[1].size, TCL_EVAL_DIRECT)) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (\"%.*s\" body, line %d)",
| | | 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 |
*/
if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start,
tokenPtr[1].size, TCL_EVAL_DIRECT)) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (\"%.*s\" body, line %d)",
parsePtr->tokenPtr->size, parsePtr->tokenPtr->start,
Tcl_GetErrorLine(interp)));
envPtr->numCommands = numCommands;
envPtr->codeNext = envPtr->codeStart + offset;
envPtr->currStackDepth = depth;
TclCompileSyntaxError(interp, envPtr);
}
return TCL_OK;
|
| ︙ | ︙ | |||
1074 1075 1076 1077 1078 1079 1080 |
parsePtr->commandStart - envPtr->source);
/*
* Process the line of code.
*/
if (parsePtr->numWords > 0) {
| | | | | 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 |
parsePtr->commandStart - envPtr->source);
/*
* Process the line of code.
*/
if (parsePtr->numWords > 0) {
int instLen = parsePtr->commandSize;
/* Length in bytes of the current command */
if (parsePtr->term == parsePtr->commandStart + instLen - 1) {
--instLen;
}
/*
* If tracing, show each line assembled as it happens.
*/
#ifdef TCL_COMPILE_DEBUG
if ((tclTraceCompile >= 2) && (envPtr->procPtr == NULL)) {
printf(" %4ld Assembling: ",
(long)(envPtr->codeNext - envPtr->codeStart));
TclPrintSource(stdout, parsePtr->commandStart,
TclMin(instLen, 55));
printf("\n");
}
#endif
if (AssembleOneLine(assemEnvPtr) != TCL_OK) {
if (flags & TCL_EVAL_DIRECT) {
|
| ︙ | ︙ | |||
1149 1150 1151 1152 1153 1154 1155 |
NewAssemblyEnv(
CompileEnv* envPtr, /* Compilation environment being used for code
* generation*/
int flags) /* Compilation flags (TCL_EVAL_DIRECT) */
{
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
| | | | 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 |
NewAssemblyEnv(
CompileEnv* envPtr, /* Compilation environment being used for code
* generation*/
int flags) /* Compilation flags (TCL_EVAL_DIRECT) */
{
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
AssemblyEnv* assemEnvPtr = (AssemblyEnv*)TclStackAlloc(interp, sizeof(AssemblyEnv));
/* Assembler environment under construction */
Tcl_Parse* parsePtr = (Tcl_Parse*)TclStackAlloc(interp, sizeof(Tcl_Parse));
/* Parse of one line of assembly code */
assemEnvPtr->envPtr = envPtr;
assemEnvPtr->parsePtr = parsePtr;
assemEnvPtr->cmdLine = 1;
assemEnvPtr->clNext = envPtr->clNext;
|
| ︙ | ︙ | |||
1214 1215 1216 1217 1218 1219 1220 |
*/
for (thisBB = assemEnvPtr->head_bb; thisBB != NULL; thisBB = nextBB) {
if (thisBB->jumpTarget != NULL) {
Tcl_DecrRefCount(thisBB->jumpTarget);
}
if (thisBB->foreignExceptions != NULL) {
| | | | 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 |
*/
for (thisBB = assemEnvPtr->head_bb; thisBB != NULL; thisBB = nextBB) {
if (thisBB->jumpTarget != NULL) {
Tcl_DecrRefCount(thisBB->jumpTarget);
}
if (thisBB->foreignExceptions != NULL) {
ckfree(thisBB->foreignExceptions);
}
nextBB = thisBB->successor1;
if (thisBB->jtPtr != NULL) {
DeleteMirrorJumpTable(thisBB->jtPtr);
thisBB->jtPtr = NULL;
}
ckfree(thisBB);
}
/*
* Dispose what's left.
*/
Tcl_DeleteHashTable(&assemEnvPtr->labelHash);
|
| ︙ | ︙ | |||
1267 1268 1269 1270 1271 1272 1273 |
Tcl_Obj* instNameObj; /* Name of the instruction */
int tblIdx; /* Index in TalInstructionTable of the
* instruction */
enum TalInstType instType; /* Type of the instruction */
Tcl_Obj* operand1Obj = NULL;
/* First operand to the instruction */
const char* operand1; /* String rep of the operand */
| | | 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 |
Tcl_Obj* instNameObj; /* Name of the instruction */
int tblIdx; /* Index in TalInstructionTable of the
* instruction */
enum 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 */
int flags; /* Flags for a basic block */
JumptableInfo* jtPtr; /* Pointer to a jumptable */
int infoIndex; /* Index of the jumptable in auxdata */
int status = TCL_ERROR; /* Return value from this function */
|
| ︙ | ︙ | |||
1540 1541 1542 1543 1544 1545 1546 |
Tcl_WrongNumArgs(interp, 1, &instNameObj, "table");
goto cleanup;
}
if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
goto cleanup;
}
| | | 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 |
Tcl_WrongNumArgs(interp, 1, &instNameObj, "table");
goto cleanup;
}
if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) {
goto cleanup;
}
jtPtr = (JumptableInfo*)ckalloc(sizeof(JumptableInfo));
Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine;
assemEnvPtr->curr_bb->jumpOffset = envPtr->codeNext-envPtr->codeStart;
DEBUG_PRINT("bb %p jumpLine %d jumpOffset %d\n",
assemEnvPtr->curr_bb, assemEnvPtr->cmdLine,
envPtr->codeNext - envPtr->codeStart);
|
| ︙ | ︙ | |||
1703 1704 1705 1706 1707 1708 1709 |
Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean");
goto cleanup;
}
if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
goto cleanup;
}
{
| < < | | 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 |
Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean");
goto cleanup;
}
if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
goto cleanup;
}
{
BBEmitInstInt1(assemEnvPtr, tblIdx, TCL_REG_ADVANCED | (opnd ? TCL_REG_NOCASE : 0), 0);
}
break;
case ASSEM_REVERSE:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "count");
goto cleanup;
|
| ︙ | ︙ | |||
1814 1815 1816 1817 1818 1819 1820 |
* We'll record the stack usage of the script in the BasicBlock, and
* accumulate it together with the stack usage of the enclosing assembly
* code.
*/
int savedStackDepth = envPtr->currStackDepth;
int savedMaxStackDepth = envPtr->maxStackDepth;
| < | 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 |
* We'll record the stack usage of the script in the BasicBlock, and
* accumulate it together with the stack usage of the enclosing assembly
* code.
*/
int savedStackDepth = envPtr->currStackDepth;
int savedMaxStackDepth = envPtr->maxStackDepth;
int savedExceptArrayNext = envPtr->exceptArrayNext;
envPtr->currStackDepth = 0;
envPtr->maxStackDepth = 0;
StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL);
switch(instPtr->tclInstCode) {
|
| ︙ | ︙ | |||
1847 1848 1849 1850 1851 1852 1853 |
envPtr->maxStackDepth = savedMaxStackDepth;
/*
* Save any exception ranges that were pushed by the compiler; they will
* need to be fixed up once the stack depth is known.
*/
| | < | 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 |
envPtr->maxStackDepth = savedMaxStackDepth;
/*
* Save any exception ranges that were pushed by the compiler; they will
* need to be fixed up once the stack depth is known.
*/
MoveExceptionRangesToBasicBlock(assemEnvPtr, savedExceptArrayNext);
/*
* Flush the current basic block.
*/
StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL);
}
|
| ︙ | ︙ | |||
1907 1908 1909 1910 1911 1912 1913 |
*
*-----------------------------------------------------------------------------
*/
static void
MoveExceptionRangesToBasicBlock(
AssemblyEnv* assemEnvPtr, /* Assembly environment */
| < | 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 |
*
*-----------------------------------------------------------------------------
*/
static void
MoveExceptionRangesToBasicBlock(
AssemblyEnv* assemEnvPtr, /* Assembly environment */
int savedExceptArrayNext) /* Saved index of the end of the exception
* range array */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
BasicBlock* curr_bb = assemEnvPtr->curr_bb;
/* Current basic block */
|
| ︙ | ︙ | |||
1939 1940 1941 1942 1943 1944 1945 |
*/
DEBUG_PRINT("basic block %p has %d exceptions starting at %d\n",
curr_bb, exceptionCount, savedExceptArrayNext);
curr_bb->foreignExceptionBase = savedExceptArrayNext;
curr_bb->foreignExceptionCount = exceptionCount;
curr_bb->foreignExceptions =
| | | 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 |
*/
DEBUG_PRINT("basic block %p has %d exceptions starting at %d\n",
curr_bb, exceptionCount, savedExceptArrayNext);
curr_bb->foreignExceptionBase = savedExceptArrayNext;
curr_bb->foreignExceptionCount = exceptionCount;
curr_bb->foreignExceptions =
(ExceptionRange*)ckalloc(exceptionCount * sizeof(ExceptionRange));
memcpy(curr_bb->foreignExceptions,
envPtr->exceptArrayPtr + savedExceptArrayNext,
exceptionCount * sizeof(ExceptionRange));
for (i = 0; i < exceptionCount; ++i) {
curr_bb->foreignExceptions[i].nestingLevel -= envPtr->exceptDepth;
}
envPtr->exceptArrayNext = savedExceptArrayNext;
|
| ︙ | ︙ | |||
2004 2005 2006 2007 2008 2009 2010 |
return TCL_ERROR;
}
/*
* Allocate the jumptable.
*/
| | | 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 |
return TCL_ERROR;
}
/*
* Allocate the jumptable.
*/
jtPtr = (JumptableInfo*)ckalloc(sizeof(JumptableInfo));
jtHashPtr = &jtPtr->hashTable;
Tcl_InitHashTable(jtHashPtr, TCL_STRING_KEYS);
/*
* Fill the keys and labels into the table.
*/
|
| ︙ | ︙ | |||
2064 2065 2066 2067 2068 2069 2070 |
Tcl_HashSearch search; /* Hash search control */
Tcl_HashEntry* entry; /* Hash table entry containing a jump label */
Tcl_Obj* label; /* Jump label from the hash table */
for (entry = Tcl_FirstHashEntry(jtHashPtr, &search);
entry != NULL;
entry = Tcl_NextHashEntry(&search)) {
| | | | 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 |
Tcl_HashSearch search; /* Hash search control */
Tcl_HashEntry* entry; /* Hash table entry containing a jump label */
Tcl_Obj* label; /* Jump label from the hash table */
for (entry = Tcl_FirstHashEntry(jtHashPtr, &search);
entry != NULL;
entry = Tcl_NextHashEntry(&search)) {
label = (Tcl_Obj*)Tcl_GetHashValue(entry);
Tcl_DecrRefCount(label);
Tcl_SetHashValue(entry, NULL);
}
Tcl_DeleteHashTable(jtHashPtr);
ckfree(jtPtr);
}
/*
*-----------------------------------------------------------------------------
*
* GetNextOperand --
*
|
| ︙ | ︙ | |||
2235 2236 2237 2238 2239 2240 2241 | * Gets the value of an operand intended to serve as a list index. * * Results: * Returns a standard Tcl result: TCL_OK if the parse is successful and * TCL_ERROR (with an appropriate error message) if the parse fails. * * Side effects: | | | 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 | * Gets the value of an operand intended to serve as a list index. * * Results: * Returns a standard Tcl result: TCL_OK if the parse is successful and * TCL_ERROR (with an appropriate error message) if the parse fails. * * Side effects: * Stores the list index at '*index'. Values between -1 and 0x7FFFFFFF * have their natural meaning; values between -2 and -0x80000000 * represent 'end-2-N'. * *----------------------------------------------------------------------------- */ static int |
| ︙ | ︙ | |||
2312 2313 2314 2315 2316 2317 2318 |
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
Tcl_Token* tokenPtr = *tokenPtrPtr;
/* INOUT: Pointer to the next token in the
* source code. */
Tcl_Obj* varNameObj; /* Name of the variable */
const char* varNameStr;
| | | 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 |
Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
/* Tcl interpreter */
Tcl_Token* tokenPtr = *tokenPtrPtr;
/* INOUT: Pointer to the next token in the
* source code. */
Tcl_Obj* varNameObj; /* Name of the variable */
const char* varNameStr;
int varNameLen;
int localVar; /* Index of the variable in the LVT */
if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) {
return -1;
}
varNameStr = TclGetStringFromObj(varNameObj, &varNameLen);
if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) {
|
| ︙ | ︙ | |||
2398 2399 2400 2401 2402 2403 2404 |
static int
CheckOneByte(
Tcl_Interp* interp, /* Tcl interpreter for error reporting */
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
| | | 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 |
static int
CheckOneByte(
Tcl_Interp* interp, /* Tcl interpreter for error reporting */
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
if (value < 0 || value > 0xFF) {
result = Tcl_NewStringObj("operand does not fit in one byte", -1);
Tcl_SetObjResult(interp, result);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
2433 2434 2435 2436 2437 2438 2439 |
static int
CheckSignedOneByte(
Tcl_Interp* interp, /* Tcl interpreter for error reporting */
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
| | | 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 |
static int
CheckSignedOneByte(
Tcl_Interp* interp, /* Tcl interpreter for error reporting */
int value) /* Value to check */
{
Tcl_Obj* result; /* Error message */
if (value > 0x7F || value < -0x80) {
result = Tcl_NewStringObj("operand does not fit in one byte", -1);
Tcl_SetObjResult(interp, result);
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "1BYTE", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
2652 2653 2654 2655 2656 2657 2658 |
*/
static BasicBlock *
AllocBB(
AssemblyEnv* assemEnvPtr) /* Assembly environment */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
| | | 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 |
*/
static BasicBlock *
AllocBB(
AssemblyEnv* assemEnvPtr) /* Assembly environment */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
BasicBlock *bb = (BasicBlock*)ckalloc(sizeof(BasicBlock));
bb->originalStartOffset =
bb->startOffset = envPtr->codeNext - envPtr->codeStart;
bb->startLine = assemEnvPtr->cmdLine + 1;
bb->jumpOffset = -1;
bb->jumpLine = -1;
bb->prevPtr = assemEnvPtr->curr_bb;
|
| ︙ | ︙ | |||
2843 2844 2845 2846 2847 2848 2849 | } /* * If the instruction is a JUMP1, turn it into a JUMP4 if its * target is out of range. */ | | | | 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 |
}
/*
* If the instruction is a JUMP1, turn it into a JUMP4 if its
* target is out of range.
*/
jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
if (bbPtr->flags & BB_JUMP1) {
offset = jumpTarget->startOffset
- (bbPtr->jumpOffset + motion);
if (offset < -0x80 || offset > 0x7F) {
opcode = TclGetUInt1AtPtr(envPtr->codeStart
+ bbPtr->jumpOffset);
++opcode;
TclStoreInt1AtPtr(opcode,
envPtr->codeStart + bbPtr->jumpOffset);
motion += 3;
bbPtr->flags &= ~BB_JUMP1;
|
| ︙ | ︙ | |||
2910 2911 2912 2913 2914 2915 2916 |
* Look up every jump target in the jump hash.
*/
DEBUG_PRINT("check jump table labels %p {\n", bbPtr);
for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search);
symEntryPtr != NULL;
symEntryPtr = Tcl_NextHashEntry(&search)) {
| | | 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 |
* Look up every jump target in the jump hash.
*/
DEBUG_PRINT("check jump table labels %p {\n", bbPtr);
for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search);
symEntryPtr != NULL;
symEntryPtr = Tcl_NextHashEntry(&search)) {
symbolObj = (Tcl_Obj*)Tcl_GetHashValue(symEntryPtr);
valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
TclGetString(symbolObj));
DEBUG_PRINT(" %s -> %s (%d)\n",
(char*) Tcl_GetHashKey(symHash, symEntryPtr),
TclGetString(symbolObj), (valEntryPtr != NULL));
if (valEntryPtr == NULL) {
ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj);
|
| ︙ | ︙ | |||
3039 3040 3041 3042 3043 3044 3045 |
for (bbPtr = assemEnvPtr->head_bb;
bbPtr != NULL;
bbPtr = bbPtr->successor1) {
if (bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
TclGetString(bbPtr->jumpTarget));
| | | 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 |
for (bbPtr = assemEnvPtr->head_bb;
bbPtr != NULL;
bbPtr = bbPtr->successor1) {
if (bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
TclGetString(bbPtr->jumpTarget));
jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
fromOffset = bbPtr->jumpOffset;
targetOffset = jumpTarget->startOffset;
if (bbPtr->flags & BB_JUMP1) {
TclStoreInt1AtPtr(targetOffset - fromOffset,
envPtr->codeStart + fromOffset + 1);
} else {
TclStoreInt4AtPtr(targetOffset - fromOffset,
|
| ︙ | ︙ | |||
3098 3099 3100 3101 3102 3103 3104 |
BasicBlock* jumpTargetBBPtr;
/* Basic block that the jump proceeds to */
int junk;
auxDataIndex = TclGetInt4AtPtr(envPtr->codeStart + bbPtr->jumpOffset + 1);
DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n",
bbPtr, bbPtr->jumpOffset, auxDataIndex);
| | | | | 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 |
BasicBlock* jumpTargetBBPtr;
/* Basic block that the jump proceeds to */
int junk;
auxDataIndex = TclGetInt4AtPtr(envPtr->codeStart + bbPtr->jumpOffset + 1);
DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n",
bbPtr, bbPtr->jumpOffset, auxDataIndex);
realJumpTablePtr = (JumptableInfo*)TclFetchAuxData(envPtr, auxDataIndex);
realJumpHashPtr = &realJumpTablePtr->hashTable;
/*
* Look up every jump target in the jump hash.
*/
DEBUG_PRINT("resolve jump table {\n");
for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search);
symEntryPtr != NULL;
symEntryPtr = Tcl_NextHashEntry(&search)) {
symbolObj = (Tcl_Obj*)Tcl_GetHashValue(symEntryPtr);
DEBUG_PRINT(" symbol %s\n", TclGetString(symbolObj));
valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
TclGetString(symbolObj));
jumpTargetBBPtr = (BasicBlock*)Tcl_GetHashValue(valEntryPtr);
realJumpEntryPtr = Tcl_CreateHashEntry(realJumpHashPtr,
Tcl_GetHashKey(symHash, symEntryPtr), &junk);
DEBUG_PRINT(" %s -> %s -> bb %p (pc %d) hash entry %p\n",
(char*) Tcl_GetHashKey(symHash, symEntryPtr),
TclGetString(symbolObj), jumpTargetBBPtr,
jumpTargetBBPtr->startOffset, realJumpEntryPtr);
|
| ︙ | ︙ | |||
3493 3494 3495 3496 3497 3498 3499 |
result = StackCheckBasicBlock(assemEnvPtr, blockPtr->successor1,
blockPtr, stackDepth);
}
if (result == TCL_OK && blockPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
TclGetString(blockPtr->jumpTarget));
| | | | | 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 |
result = StackCheckBasicBlock(assemEnvPtr, blockPtr->successor1,
blockPtr, stackDepth);
}
if (result == TCL_OK && blockPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
TclGetString(blockPtr->jumpTarget));
jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr,
stackDepth);
}
/*
* All blocks referenced in a jump table are successors.
*/
if (blockPtr->flags & BB_JUMPTABLE) {
for (jtEntry = Tcl_FirstHashEntry(&blockPtr->jtPtr->hashTable,
&jtSearch);
result == TCL_OK && jtEntry != NULL;
jtEntry = Tcl_NextHashEntry(&jtSearch)) {
targetLabel = (Tcl_Obj*)Tcl_GetHashValue(jtEntry);
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
TclGetString(targetLabel));
jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
result = StackCheckBasicBlock(assemEnvPtr, jumpTarget,
blockPtr, stackDepth);
}
}
return result;
}
|
| ︙ | ︙ | |||
3815 3816 3817 3818 3819 3820 3821 |
if (bbPtr->flags & BB_FALLTHRU) {
result = ProcessCatchesInBasicBlock(assemEnvPtr, bbPtr->successor1,
fallThruEnclosing, fallThruState, catchDepth);
}
if (result == TCL_OK && bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
TclGetString(bbPtr->jumpTarget));
| | | | | 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 |
if (bbPtr->flags & BB_FALLTHRU) {
result = ProcessCatchesInBasicBlock(assemEnvPtr, bbPtr->successor1,
fallThruEnclosing, fallThruState, catchDepth);
}
if (result == TCL_OK && bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
TclGetString(bbPtr->jumpTarget));
jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
jumpEnclosing, jumpState, catchDepth);
}
/*
* All blocks referenced in a jump table are successors.
*/
if (bbPtr->flags & BB_JUMPTABLE) {
for (jtEntry = Tcl_FirstHashEntry(&bbPtr->jtPtr->hashTable,&jtSearch);
result == TCL_OK && jtEntry != NULL;
jtEntry = Tcl_NextHashEntry(&jtSearch)) {
targetLabel = (Tcl_Obj*)Tcl_GetHashValue(jtEntry);
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
TclGetString(targetLabel));
jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry);
result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
jumpEnclosing, jumpState, catchDepth);
}
}
return result;
}
|
| ︙ | ︙ | |||
3930 3931 3932 3933 3934 3935 3936 |
}
}
/*
* Allocate memory for a stack of active catches.
*/
| | | | 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 |
}
}
/*
* Allocate memory for a stack of active catches.
*/
catches = (BasicBlock**)ckalloc(maxCatchDepth * sizeof(BasicBlock*));
catchIndices = (int *)ckalloc(maxCatchDepth * sizeof(int));
for (i = 0; i < maxCatchDepth; ++i) {
catches[i] = NULL;
catchIndices[i] = -1;
}
/*
* Walk through the basic blocks and manage exception ranges.
|
| ︙ | ︙ | |||
3970 3971 3972 3973 3974 3975 3976 |
if (catchDepth != 0) {
Tcl_Panic("unclosed catch at end of code in "
"tclAssembly.c:BuildExceptionRanges, can't happen");
}
/* Free temp storage */
| | | | 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 |
if (catchDepth != 0) {
Tcl_Panic("unclosed catch at end of code in "
"tclAssembly.c:BuildExceptionRanges, can't happen");
}
/* Free temp storage */
ckfree(catchIndices);
ckfree(catches);
return TCL_OK;
}
/*
*-----------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3999 4000 4001 4002 4003 4004 4005 |
int catchDepth, /* Depth of nesting of catches prior to entry
* to this block */
BasicBlock** catches, /* Array of catch contexts */
int* catchIndices) /* Indices of the exception ranges
* corresponding to the catch contexts */
{
ExceptionRange* range; /* Exception range for a specific catch */
| | | 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 |
int catchDepth, /* Depth of nesting of catches prior to entry
* to this block */
BasicBlock** catches, /* Array of catch contexts */
int* catchIndices) /* Indices of the exception ranges
* corresponding to the catch contexts */
{
ExceptionRange* range; /* Exception range for a specific catch */
BasicBlock* block; /* Catch block being examined */
BasicBlockCatchState catchState;
/* State of the code relative to the catch
* block being examined ("in catch" or
* "caught"). */
/*
* Unstack any catches that are deeper than the nesting level of the basic
|
| ︙ | ︙ | |||
4027 4028 4029 4030 4031 4032 4033 |
/*
* Unstack any catches that don't match the basic block being entered,
* either because they are no longer part of the context, or because the
* context has changed from INCATCH to CAUGHT.
*/
catchState = bbPtr->catchState;
| | | | | | 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 |
/*
* Unstack any catches that don't match the basic block being entered,
* either because they are no longer part of the context, or because the
* context has changed from INCATCH to CAUGHT.
*/
catchState = bbPtr->catchState;
block = bbPtr->enclosingCatch;
while (catchDepth > 0) {
--catchDepth;
if (catches[catchDepth] != NULL) {
if (catches[catchDepth] != block || catchState >= BBCS_CAUGHT) {
range = envPtr->exceptArrayPtr + catchIndices[catchDepth];
range->numCodeBytes = bbPtr->startOffset - range->codeOffset;
catches[catchDepth] = NULL;
catchIndices[catchDepth] = -1;
}
catchState = block->catchState;
block = block->enclosingCatch;
}
}
}
/*
*-----------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4067 4068 4069 4070 4071 4072 4073 |
BasicBlock* bbPtr, /* Basic block being entered */
BasicBlock** catches) /* Array of catch contexts that are already
* entered */
{
BasicBlockCatchState catchState;
/* State ("in catch" or "caught") of the
* current catch. */
| | | | | | | | 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 |
BasicBlock* bbPtr, /* Basic block being entered */
BasicBlock** catches) /* Array of catch contexts that are already
* entered */
{
BasicBlockCatchState catchState;
/* State ("in catch" or "caught") of the
* current catch. */
BasicBlock* block; /* Current enclosing catch */
int catchDepth; /* Nesting depth of the current catch */
catchState = bbPtr->catchState;
block = bbPtr->enclosingCatch;
catchDepth = bbPtr->catchDepth;
while (catchDepth > 0) {
--catchDepth;
if (catches[catchDepth] != block && catchState < BBCS_CAUGHT) {
catches[catchDepth] = block;
}
catchState = block->catchState;
block = block->enclosingCatch;
}
}
/*
*-----------------------------------------------------------------------------
*
* StackFreshCatches --
|
| ︙ | ︙ | |||
4107 4108 4109 4110 4111 4112 4113 |
BasicBlock** catches, /* Array of catch contexts */
int* catchIndices) /* Indices of the exception ranges
* corresponding to the catch contexts */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
ExceptionRange* range; /* Exception range for a specific catch */
| | | | | | 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 |
BasicBlock** catches, /* Array of catch contexts */
int* catchIndices) /* Indices of the exception ranges
* corresponding to the catch contexts */
{
CompileEnv* envPtr = assemEnvPtr->envPtr;
/* Compilation environment */
ExceptionRange* range; /* Exception range for a specific catch */
BasicBlock* block; /* Catch block being examined */
BasicBlock* errorExit; /* Error exit from the catch block */
Tcl_HashEntry* entryPtr;
catchDepth = 0;
/*
* Iterate through the enclosing catch blocks from the outside in,
* looking for ones that don't have exception ranges (and are uncaught)
*/
for (catchDepth = 0; catchDepth < bbPtr->catchDepth; ++catchDepth) {
if (catchIndices[catchDepth] == -1 && catches[catchDepth] != NULL) {
/*
* Create an exception range for a block that needs one.
*/
block = catches[catchDepth];
catchIndices[catchDepth] =
TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
range = envPtr->exceptArrayPtr + catchIndices[catchDepth];
range->nestingLevel = envPtr->exceptDepth + catchDepth;
envPtr->maxExceptDepth =
TclMax(range->nestingLevel + 1, envPtr->maxExceptDepth);
range->codeOffset = bbPtr->startOffset;
entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
TclGetString(block->jumpTarget));
if (entryPtr == NULL) {
Tcl_Panic("undefined label in tclAssembly.c:"
"BuildExceptionRanges, can't happen");
}
errorExit = (BasicBlock*)Tcl_GetHashValue(entryPtr);
range->catchOffset = errorExit->startOffset;
}
}
}
/*
*-----------------------------------------------------------------------------
|
| ︙ | ︙ | |||
4313 4314 4315 4316 4317 4318 4319 | * None. * *----------------------------------------------------------------------------- */ static void DupAssembleCodeInternalRep( | | | | 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 |
* None.
*
*-----------------------------------------------------------------------------
*/
static void
DupAssembleCodeInternalRep(
TCL_UNUSED(Tcl_Obj *),
TCL_UNUSED(Tcl_Obj *))
{
return;
}
/*
*-----------------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to generic/tclAsync.c.
| ︙ | ︙ | |||
114 115 116 117 118 119 120 |
Tcl_AsyncProc *proc, /* Procedure to call when handler is
* invoked. */
ClientData clientData) /* Argument to pass to handler. */
{
AsyncHandler *asyncPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| | | 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 |
Tcl_AsyncProc *proc, /* Procedure to call when handler is
* invoked. */
ClientData clientData) /* Argument to pass to handler. */
{
AsyncHandler *asyncPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
asyncPtr = (AsyncHandler*)ckalloc(sizeof(AsyncHandler));
asyncPtr->ready = 0;
asyncPtr->nextPtr = NULL;
asyncPtr->proc = proc;
asyncPtr->clientData = clientData;
asyncPtr->originTsd = tsdPtr;
asyncPtr->originThrdId = Tcl_GetCurrentThread();
|
| ︙ | ︙ | |||
306 307 308 309 310 311 312 |
prevPtr->nextPtr = asyncPtr->nextPtr;
}
if (asyncPtr == tsdPtr->lastHandler) {
tsdPtr->lastHandler = prevPtr;
}
}
Tcl_MutexUnlock(&tsdPtr->asyncMutex);
| | | 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 |
prevPtr->nextPtr = asyncPtr->nextPtr;
}
if (asyncPtr == tsdPtr->lastHandler) {
tsdPtr->lastHandler = prevPtr;
}
}
Tcl_MutexUnlock(&tsdPtr->asyncMutex);
ckfree(asyncPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_AsyncReady --
*
|
| ︙ | ︙ |
Changes to generic/tclBasic.c.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclOOInt.h" #include "tclCompile.h" | | > | > < | | > > > | | | > > > > | | > > > > > | | > > > > > > > > > > > > | | | 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 |
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclOOInt.h"
#include "tclCompile.h"
#include "tclTomMath.h"
#include <math.h>
#include <assert.h>
/*
* TCL_FPCLASSIFY_MODE:
* 0 - fpclassify
* 1 - _fpclass
* 2 - simulate
* 3 - __builtin_fpclassify
*/
#ifndef TCL_FPCLASSIFY_MODE
#if defined(__MINGW32__) && defined(_X86_) /* mingw 32-bit */
/*
* MINGW x86 (tested up to gcc 8.1) seems to have a bug in fpclassify,
* [fpclassify 1e-314], x86 => normal, x64 => subnormal, so switch to using a
* version using a compiler built-in.
*/
#define TCL_FPCLASSIFY_MODE 1
#elif defined(fpclassify) /* fpclassify */
/*
* This is the C99 standard.
*/
#include <float.h>
#define TCL_FPCLASSIFY_MODE 0
#elif defined(_FPCLASS_NN) /* _fpclass */
/*
* This case handles newer MSVC on Windows, which doesn't have the standard
* operation but does have something that can tell us the same thing.
*/
#define TCL_FPCLASSIFY_MODE 1
#else /* !fpclassify && !_fpclass (older MSVC), simulate */
/*
* Older MSVC on Windows. So broken that we just have to do it our way. This
* assumes that we're on x86 (or at least a system with classic little-endian
* double layout and a 32-bit 'int' type).
*/
#define TCL_FPCLASSIFY_MODE 2
#endif /* !fpclassify */
/* actually there is no fallback to builtin fpclassify */
#endif /* !TCL_FPCLASSIFY_MODE */
#define INTERP_STACK_INITIAL_SIZE 2000
#define CORO_STACK_INITIAL_SIZE 200
/*
* Determine whether we're using IEEE floating point
*/
#if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024)
# define IEEE_FLOATING_POINT
/* Largest odd integer that can be represented exactly in a double */
# define MAX_EXACT 9007199254740991.0
#endif
/*
* The following structure defines the client data for a math function
* registered with Tcl_CreateMathFunc
*/
typedef struct OldMathFuncData {
Tcl_MathProc *proc; /* Handler function */
int numArgs; /* Number of args expected */
Tcl_ValueType *argTypes; /* Types of the args */
ClientData clientData; /* Client data for the handler function */
} OldMathFuncData;
/*
* This is the script cancellation struct and hash table. The hash table is
* used to keep track of the information necessary to process script
* cancellation requests, including the original interp, asynchronous handler
* tokens (created by Tcl_AsyncCreate), and the clientData and flags arguments
* passed to Tcl_CancelEval on a per-interp basis. The cancelLock mutex is
* used for protecting calls to Tcl_CancelEval as well as protecting access to
* the hash table below.
*/
typedef struct {
Tcl_Interp *interp; /* Interp this struct belongs to. */
Tcl_AsyncHandler async; /* Async handler token for script
* cancellation. */
char *result; /* The script cancellation result or NULL for
* a default result. */
int length; /* Length of the above error message. */
ClientData clientData; /* Not used. */
int flags; /* Additional flags */
} CancelInfo;
static Tcl_HashTable cancelTable;
static int cancelTableInitialized = 0; /* 0 means not yet initialized. */
TCL_DECLARE_MUTEX(cancelLock);
/*
|
| ︙ | ︙ | |||
161 162 163 164 165 166 167 168 169 170 171 172 173 174 | static Tcl_ObjCmdProc FloatClassifyObjCmd; static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static Tcl_NRPostProc NRCommand; static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode); static int RewindCoroutine(CoroutineData *corPtr, int result); static void TEOV_SwitchVarFrame(Tcl_Interp *interp); static void TEOV_PushExceptionHandlers(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); static inline Command * TEOV_LookupCmdFromObj(Tcl_Interp *interp, | > > > > | 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 | static Tcl_ObjCmdProc FloatClassifyObjCmd; static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static Tcl_NRPostProc NRCommand; #if !defined(TCL_NO_DEPRECATED) static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); #endif /* !defined(TCL_NO_DEPRECATED) */ static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode); static int RewindCoroutine(CoroutineData *corPtr, int result); static void TEOV_SwitchVarFrame(Tcl_Interp *interp); static void TEOV_PushExceptionHandlers(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); static inline Command * TEOV_LookupCmdFromObj(Tcl_Interp *interp, |
| ︙ | ︙ | |||
255 256 257 258 259 260 261 262 263 264 265 266 267 268 |
/*
* Commands in the generic core.
*/
{"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE},
{"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE},
{"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE},
{"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE},
{"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE},
{"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE},
{"coroinject", NULL, NULL, TclNRCoroInjectObjCmd, CMD_IS_SAFE},
{"coroprobe", NULL, NULL, TclNRCoroProbeObjCmd, CMD_IS_SAFE},
{"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE},
{"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE},
| > > > | 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 |
/*
* Commands in the generic core.
*/
{"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE},
{"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE},
{"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE},
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
{"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE},
#endif
{"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE},
{"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE},
{"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE},
{"coroinject", NULL, NULL, TclNRCoroInjectObjCmd, CMD_IS_SAFE},
{"coroprobe", NULL, NULL, TclNRCoroProbeObjCmd, CMD_IS_SAFE},
{"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE},
{"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE},
|
| ︙ | ︙ | |||
417 418 419 420 421 422 423 |
* Math functions. All are safe.
*/
typedef struct {
const char *name; /* Name of the function. The full name is
* "::tcl::mathfunc::<name>". */
Tcl_ObjCmdProc *objCmdProc; /* Function that evaluates the function */
| | | | | | | | | | | | | | | | | | | 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 |
* Math functions. All are safe.
*/
typedef struct {
const char *name; /* Name of the function. The full name is
* "::tcl::mathfunc::<name>". */
Tcl_ObjCmdProc *objCmdProc; /* Function that evaluates the function */
double (*fn)(double x); /* Real function pointer */
} BuiltinFuncDef;
static const BuiltinFuncDef BuiltinFuncTable[] = {
{ "abs", ExprAbsFunc, NULL },
{ "acos", ExprUnaryFunc, acos },
{ "asin", ExprUnaryFunc, asin },
{ "atan", ExprUnaryFunc, atan },
{ "atan2", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) atan2},
{ "bool", ExprBoolFunc, NULL },
{ "ceil", ExprCeilFunc, NULL },
{ "cos", ExprUnaryFunc, cos },
{ "cosh", ExprUnaryFunc, cosh },
{ "double", ExprDoubleFunc, NULL },
{ "entier", ExprIntFunc, NULL },
{ "exp", ExprUnaryFunc, exp },
{ "floor", ExprFloorFunc, NULL },
{ "fmod", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) fmod},
{ "hypot", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) hypot},
{ "int", ExprIntFunc, NULL },
{ "isfinite", ExprIsFiniteFunc, NULL },
{ "isinf", ExprIsInfinityFunc, NULL },
{ "isnan", ExprIsNaNFunc, NULL },
{ "isnormal", ExprIsNormalFunc, NULL },
{ "isqrt", ExprIsqrtFunc, NULL },
{ "issubnormal", ExprIsSubnormalFunc, NULL, },
{ "isunordered", ExprIsUnorderedFunc, NULL, },
{ "log", ExprUnaryFunc, log },
{ "log10", ExprUnaryFunc, log10 },
{ "max", ExprMaxFunc, NULL },
{ "min", ExprMinFunc, NULL },
{ "pow", ExprBinaryFunc, (double (*)(double))(void *)(double (*)(double, double)) pow},
{ "rand", ExprRandFunc, NULL },
{ "round", ExprRoundFunc, NULL },
{ "sin", ExprUnaryFunc, sin },
{ "sinh", ExprUnaryFunc, sinh },
{ "sqrt", ExprSqrtFunc, NULL },
{ "srand", ExprSrandFunc, NULL },
{ "tan", ExprUnaryFunc, tan },
{ "tanh", ExprUnaryFunc, tanh },
{ "wide", ExprWideFunc, NULL },
{ NULL, NULL, NULL }
};
/*
* TIP#174's math operators. All are safe.
*/
|
| ︙ | ︙ | |||
609 610 611 612 613 614 615 |
} order;
#ifdef TCL_COMPILE_STATS
ByteCodeStats *statsPtr;
#endif /* TCL_COMPILE_STATS */
char mathFuncName[32];
CallFrame *framePtr;
| | < | | < | < > > > > < | 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 |
} order;
#ifdef TCL_COMPILE_STATS
ByteCodeStats *statsPtr;
#endif /* TCL_COMPILE_STATS */
char mathFuncName[32];
CallFrame *framePtr;
Tcl_InitSubsystems();
/*
* Panic if someone updated the CallFrame structure without also updating
* the Tcl_CallFrame structure (or vice versa).
*/
if (sizeof(Tcl_CallFrame) < sizeof(CallFrame)) {
Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame");
}
#if defined(_WIN32) && !defined(_WIN64) && !defined(_USE_64BIT_TIME_T)
/* If Tcl is compiled on Win32 using -D_USE_64BIT_TIME_T
* the result is a binary incompatible with the 'standard' build of
* Tcl: All extensions using Tcl_StatBuf need to be recompiled in
* the same way. Therefore, this is not officially supported.
* In stead, it is recommended to use Win64 or Tcl 9.0 (not released yet)
*/
if ((offsetof(Tcl_StatBuf,st_atime) != 32)
|| (offsetof(Tcl_StatBuf,st_ctime) != 40)) {
Tcl_Panic("<sys/stat.h> is not compatible with MSVC");
}
#endif
if (cancelTableInitialized == 0) {
Tcl_MutexLock(&cancelLock);
if (cancelTableInitialized == 0) {
|
| ︙ | ︙ | |||
662 663 664 665 666 667 668 |
/*
* Initialize support for namespaces and create the global namespace
* (whose name is ""; an alias is "::"). This also initializes the Tcl
* object type table and other object management code.
*/
| | > | > | < > | < > | | | | | | 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 |
/*
* Initialize support for namespaces and create the global namespace
* (whose name is ""; an alias is "::"). This also initializes the Tcl
* object type table and other object management code.
*/
iPtr = (Interp *)ckalloc(sizeof(Interp));
interp = (Tcl_Interp *) iPtr;
#ifdef TCL_NO_DEPRECATED
iPtr->result = &tclEmptyString;
#else
iPtr->result = iPtr->resultSpace;
#endif
iPtr->freeProc = NULL;
iPtr->errorLine = 0;
iPtr->objResultPtr = Tcl_NewObj();
Tcl_IncrRefCount(iPtr->objResultPtr);
iPtr->handle = TclHandleCreate(iPtr);
iPtr->globalNsPtr = NULL;
iPtr->hiddenCmdTablePtr = NULL;
iPtr->interpInfo = NULL;
TCL_CT_ASSERT(sizeof(iPtr->extra) <= sizeof(Tcl_HashTable));
iPtr->extra.optimizer = TclOptimizeBytecode;
iPtr->numLevels = 0;
iPtr->maxNestingDepth = MAX_NESTING_DEPTH;
iPtr->framePtr = NULL; /* Initialise as soon as :: is available */
iPtr->varFramePtr = NULL; /* Initialise as soon as :: is available */
/*
* TIP #280 - Initialize the arrays used to extend the ByteCode and Proc
* structures.
*/
iPtr->cmdFramePtr = NULL;
iPtr->linePBodyPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
iPtr->lineBCPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
iPtr->lineLAPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
iPtr->lineLABCPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(iPtr->lineLABCPtr, TCL_ONE_WORD_KEYS);
iPtr->scriptCLLocPtr = NULL;
iPtr->activeVarTracePtr = NULL;
|
| ︙ | ︙ | |||
726 727 728 729 730 731 732 733 734 735 736 737 738 739 |
TclNewLiteralStringObj(iPtr->ecVar, "::errorCode");
Tcl_IncrRefCount(iPtr->ecVar);
iPtr->returnLevel = 1;
iPtr->returnCode = TCL_OK;
iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */
iPtr->lookupNsPtr = NULL;
Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
iPtr->packageUnknown = NULL;
/* TIP #268 */
#if (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE)
if (getenv("TCL_PKG_PREFER_LATEST") == NULL) {
| > > > > > > | 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 |
TclNewLiteralStringObj(iPtr->ecVar, "::errorCode");
Tcl_IncrRefCount(iPtr->ecVar);
iPtr->returnLevel = 1;
iPtr->returnCode = TCL_OK;
iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */
iPtr->lookupNsPtr = NULL;
#ifndef TCL_NO_DEPRECATED
iPtr->appendResult = NULL;
iPtr->appendAvl = 0;
iPtr->appendUsed = 0;
#endif
Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
iPtr->packageUnknown = NULL;
/* TIP #268 */
#if (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE)
if (getenv("TCL_PKG_PREFER_LATEST") == NULL) {
|
| ︙ | ︙ | |||
755 756 757 758 759 760 761 762 763 764 765 766 767 768 |
iPtr->activeCmdTracePtr = NULL;
iPtr->activeInterpTracePtr = NULL;
iPtr->assocData = NULL;
iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */
iPtr->emptyObjPtr = Tcl_NewObj();
/* Another empty object. */
Tcl_IncrRefCount(iPtr->emptyObjPtr);
iPtr->threadId = Tcl_GetCurrentThread();
/* TIP #378 */
#ifdef TCL_INTERP_DEBUG_FRAME
iPtr->flags |= INTERP_DEBUG_FRAME;
#else
if (getenv("TCL_INTERP_DEBUG_FRAME") != NULL) {
| > > > | 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 |
iPtr->activeCmdTracePtr = NULL;
iPtr->activeInterpTracePtr = NULL;
iPtr->assocData = NULL;
iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */
iPtr->emptyObjPtr = Tcl_NewObj();
/* Another empty object. */
Tcl_IncrRefCount(iPtr->emptyObjPtr);
#ifndef TCL_NO_DEPRECATED
iPtr->resultSpace[0] = 0;
#endif
iPtr->threadId = Tcl_GetCurrentThread();
/* TIP #378 */
#ifdef TCL_INTERP_DEBUG_FRAME
iPtr->flags |= INTERP_DEBUG_FRAME;
#else
if (getenv("TCL_INTERP_DEBUG_FRAME") != NULL) {
|
| ︙ | ︙ | |||
788 789 790 791 792 793 794 |
/*
* Initialise the rootCallframe. It cannot be allocated on the stack, as
* it has to be in place before TclCreateExecEnv tries to use a variable.
*/
/* This is needed to satisfy GCC 3.3's strict aliasing rules */
| | | 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 |
/*
* Initialise the rootCallframe. It cannot be allocated on the stack, as
* it has to be in place before TclCreateExecEnv tries to use a variable.
*/
/* This is needed to satisfy GCC 3.3's strict aliasing rules */
framePtr = (CallFrame *)ckalloc(sizeof(CallFrame));
(void) Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
(Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0);
framePtr->objc = 0;
iPtr->framePtr = framePtr;
iPtr->varFramePtr = framePtr;
iPtr->rootFramePtr = framePtr;
|
| ︙ | ︙ | |||
818 819 820 821 822 823 824 |
/*
* TIP #285, Script cancellation support.
*/
iPtr->asyncCancelMsg = Tcl_NewObj();
| | | 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 |
/*
* TIP #285, Script cancellation support.
*/
iPtr->asyncCancelMsg = Tcl_NewObj();
cancelInfo = (CancelInfo *)ckalloc(sizeof(CancelInfo));
cancelInfo->interp = interp;
iPtr->asyncCancel = Tcl_AsyncCreate(CancelEvalProc, cancelInfo);
cancelInfo->async = iPtr->asyncCancel;
cancelInfo->result = NULL;
cancelInfo->length = 0;
|
| ︙ | ︙ | |||
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 |
statsPtr->numLiteralsCreated = 0;
statsPtr->totalLitStringBytes = 0.0;
statsPtr->currentLitStringBytes = 0.0;
memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount));
#endif /* TCL_COMPILE_STATS */
/*
* Initialize the ensemble error message rewriting support.
*/
TclResetRewriteEnsemble(interp, 1);
/*
* TIP#143: Initialise the resource limit support.
*/
TclInitLimitSupport(interp);
/*
* Initialise the thread-specific data ekeko. Note that the thread's alloc
* cache was already initialised by the call to alloc the interp struct.
*/
#if TCL_THREADS && defined(USE_THREAD_ALLOC)
| > > > > > > | | 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 |
statsPtr->numLiteralsCreated = 0;
statsPtr->totalLitStringBytes = 0.0;
statsPtr->currentLitStringBytes = 0.0;
memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount));
#endif /* TCL_COMPILE_STATS */
/*
* Initialise the stub table pointer.
*/
iPtr->stubTable = &tclStubs;
/*
* Initialize the ensemble error message rewriting support.
*/
TclResetRewriteEnsemble(interp, 1);
/*
* TIP#143: Initialise the resource limit support.
*/
TclInitLimitSupport(interp);
/*
* Initialise the thread-specific data ekeko. Note that the thread's alloc
* cache was already initialised by the call to alloc the interp struct.
*/
#if TCL_THREADS && defined(USE_THREAD_ALLOC)
iPtr->allocCache = (AllocCache *)TclpGetAllocCache();
#else
iPtr->allocCache = NULL;
#endif
iPtr->pendingObjDataPtr = NULL;
iPtr->asyncReadyPtr = TclGetAsyncReadyPtr();
iPtr->deferredCallbacks = NULL;
|
| ︙ | ︙ | |||
911 912 913 914 915 916 917 |
&& (cmdInfoPtr->nreProc == NULL)) {
Tcl_Panic("builtin command with NULL object command proc and a NULL compile proc");
}
hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
cmdInfoPtr->name, &isNew);
if (isNew) {
| | | 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 |
&& (cmdInfoPtr->nreProc == NULL)) {
Tcl_Panic("builtin command with NULL object command proc and a NULL compile proc");
}
hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
cmdInfoPtr->name, &isNew);
if (isNew) {
cmdPtr = (Command *)ckalloc(sizeof(Command));
cmdPtr->hPtr = hPtr;
cmdPtr->nsPtr = iPtr->globalNsPtr;
cmdPtr->refCount = 1;
cmdPtr->cmdEpoch = 0;
cmdPtr->compileProc = cmdInfoPtr->compileProc;
cmdPtr->proc = TclInvokeObjectCommand;
cmdPtr->clientData = cmdPtr;
|
| ︙ | ︙ | |||
1025 1026 1027 1028 1029 1030 1031 |
}
#define MATH_FUNC_PREFIX_LEN 17 /* == strlen("::tcl::mathfunc::") */
memcpy(mathFuncName, "::tcl::mathfunc::", MATH_FUNC_PREFIX_LEN);
for (builtinFuncPtr = BuiltinFuncTable; builtinFuncPtr->name != NULL;
builtinFuncPtr++) {
strcpy(mathFuncName+MATH_FUNC_PREFIX_LEN, builtinFuncPtr->name);
Tcl_CreateObjCommand(interp, mathFuncName,
| | | | 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 |
}
#define MATH_FUNC_PREFIX_LEN 17 /* == strlen("::tcl::mathfunc::") */
memcpy(mathFuncName, "::tcl::mathfunc::", MATH_FUNC_PREFIX_LEN);
for (builtinFuncPtr = BuiltinFuncTable; builtinFuncPtr->name != NULL;
builtinFuncPtr++) {
strcpy(mathFuncName+MATH_FUNC_PREFIX_LEN, builtinFuncPtr->name);
Tcl_CreateObjCommand(interp, mathFuncName,
builtinFuncPtr->objCmdProc, (void *)builtinFuncPtr->fn, NULL);
Tcl_Export(interp, nsPtr, builtinFuncPtr->name, 0);
}
/*
* Register the mathematical "operator" commands. [TIP #174]
*/
nsPtr = Tcl_CreateNamespace(interp, "::tcl::mathop", NULL, NULL);
if (nsPtr == NULL) {
Tcl_Panic("can't create math operator namespace");
}
Tcl_Export(interp, nsPtr, "*", 1);
#define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */
memcpy(mathFuncName, "::tcl::mathop::", MATH_OP_PREFIX_LEN);
for (opcmdInfoPtr=mathOpCmds ; opcmdInfoPtr->name!=NULL ; opcmdInfoPtr++){
TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)ckalloc(sizeof(TclOpCmdClientData));
occdPtr->op = opcmdInfoPtr->name;
occdPtr->i.numArgs = opcmdInfoPtr->i.numArgs;
occdPtr->expected = opcmdInfoPtr->expected;
strcpy(mathFuncName + MATH_OP_PREFIX_LEN, opcmdInfoPtr->name);
cmdPtr = (Command *) Tcl_CreateObjCommand(interp, mathFuncName,
opcmdInfoPtr->objProc, occdPtr, DeleteOpCmdClientData);
|
| ︙ | ︙ | |||
1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 |
/*
* Set up other variables such as tcl_version and tcl_library
*/
Tcl_SetVar2(interp, "tcl_patchLevel", NULL, TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tcl_version", NULL, TCL_VERSION, TCL_GLOBAL_ONLY);
TclpSetVariables(interp);
#if TCL_THREADS
/*
* The existence of the "threaded" element of the tcl_platform array
* indicates that this particular Tcl shell has been compiled with threads
* turned on. Using "info exists tcl_platform(threaded)" a Tcl script can
| > > > > > | 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 |
/*
* Set up other variables such as tcl_version and tcl_library
*/
Tcl_SetVar2(interp, "tcl_patchLevel", NULL, TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tcl_version", NULL, TCL_VERSION, TCL_GLOBAL_ONLY);
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
Tcl_TraceVar2(interp, "tcl_precision", NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
TclPrecTraceProc, NULL);
#endif /* !TCL_NO_DEPRECATED */
TclpSetVariables(interp);
#if TCL_THREADS
/*
* The existence of the "threaded" element of the tcl_platform array
* indicates that this particular Tcl shell has been compiled with threads
* turned on. Using "info exists tcl_platform(threaded)" a Tcl script can
|
| ︙ | ︙ | |||
1120 1121 1122 1123 1124 1125 1126 |
* Register Tcl's version number.
* TIP #268: Full patchlevel instead of just major.minor
*/
Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs);
if (TclTommath_Init(interp) != TCL_OK) {
| | | | | | | | 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 |
* Register Tcl's version number.
* TIP #268: Full patchlevel instead of just major.minor
*/
Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs);
if (TclTommath_Init(interp) != TCL_OK) {
Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
}
if (TclOOInit(interp) != TCL_OK) {
Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
}
/*
* Only build in zlib support if we've successfully detected a library to
* compile and link against.
*/
#ifdef HAVE_ZLIB
if (TclZlibInit(interp) != TCL_OK) {
Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
}
if (TclZipfs_Init(interp) != TCL_OK) {
Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
}
#endif
TOP_CB(iPtr) = NULL;
return interp;
}
static void
DeleteOpCmdClientData(
ClientData clientData)
{
TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
ckfree(occdPtr);
}
/*
* ---------------------------------------------------------------------
*
* TclRegisterCommandTypeName, TclGetCommandTypeName --
*
|
| ︙ | ︙ | |||
1200 1201 1202 1203 1204 1205 1206 |
}
const char *
TclGetCommandTypeName(
Tcl_Command command)
{
Command *cmdPtr = (Command *) command;
| | | 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 |
}
const char *
TclGetCommandTypeName(
Tcl_Command command)
{
Command *cmdPtr = (Command *) command;
Tcl_ObjCmdProc *procPtr = cmdPtr->objProc;
const char *name = "native";
if (procPtr == NULL) {
procPtr = cmdPtr->nreProc;
}
Tcl_MutexLock(&commandTypeLock);
if (commandTypeInit) {
|
| ︙ | ︙ | |||
1239 1240 1241 1242 1243 1244 1245 |
*----------------------------------------------------------------------
*/
int
TclHideUnsafeCommands(
Tcl_Interp *interp) /* Hide commands in this interpreter. */
{
| | | | 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 |
*----------------------------------------------------------------------
*/
int
TclHideUnsafeCommands(
Tcl_Interp *interp) /* Hide commands in this interpreter. */
{
const CmdInfo *cmdInfoPtr;
const UnsafeEnsembleInfo *unsafePtr;
if (interp == NULL) {
return TCL_ERROR;
}
for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) {
if (!(cmdInfoPtr->flags & CMD_IS_SAFE)) {
Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
|
| ︙ | ︙ | |||
1269 1270 1271 1272 1273 1274 1275 |
if (TclRenameCommand(interp, TclGetString(cmdName),
"___tmp") != TCL_OK
|| Tcl_HideCommand(interp, "___tmp",
TclGetString(hideName)) != TCL_OK) {
Tcl_Panic("problem making '%s %s' safe: %s",
unsafePtr->ensembleNsName, unsafePtr->commandName,
| | | | | 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 |
if (TclRenameCommand(interp, TclGetString(cmdName),
"___tmp") != TCL_OK
|| Tcl_HideCommand(interp, "___tmp",
TclGetString(hideName)) != TCL_OK) {
Tcl_Panic("problem making '%s %s' safe: %s",
unsafePtr->ensembleNsName, unsafePtr->commandName,
Tcl_GetString(Tcl_GetObjResult(interp)));
}
Tcl_CreateObjCommand(interp, TclGetString(cmdName),
BadEnsembleSubcommand, (void *)unsafePtr, NULL);
TclDecrRefCount(cmdName);
TclDecrRefCount(hideName);
} else {
/*
* Hide an ensemble main command (for compatibility).
*/
if (Tcl_HideCommand(interp, unsafePtr->ensembleNsName,
unsafePtr->ensembleNsName) != TCL_OK) {
Tcl_Panic("problem making '%s' safe: %s",
unsafePtr->ensembleNsName,
Tcl_GetString(Tcl_GetObjResult(interp)));
}
}
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
1314 1315 1316 1317 1318 1319 1320 |
*----------------------------------------------------------------------
*/
static int
BadEnsembleSubcommand(
ClientData clientData,
Tcl_Interp *interp,
| | | | | 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 |
*----------------------------------------------------------------------
*/
static int
BadEnsembleSubcommand(
ClientData clientData,
Tcl_Interp *interp,
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /* objv */)
{
const UnsafeEnsembleInfo *infoPtr = (const UnsafeEnsembleInfo *)clientData;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"not allowed to invoke subcommand %s of %s",
infoPtr->commandName, infoPtr->ensembleNsName));
Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1357 1358 1359 1360 1361 1362 1363 |
Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about
* to be deleted. */
ClientData clientData) /* One-word value to pass to proc. */
{
Interp *iPtr = (Interp *) interp;
static Tcl_ThreadDataKey assocDataCounterKey;
int *assocDataCounterPtr =
| | | | | 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 |
Tcl_InterpDeleteProc *proc, /* Function to call when interpreter is about
* to be deleted. */
ClientData clientData) /* One-word value to pass to proc. */
{
Interp *iPtr = (Interp *) interp;
static Tcl_ThreadDataKey assocDataCounterKey;
int *assocDataCounterPtr =
(int *)Tcl_GetThreadData(&assocDataCounterKey, sizeof(int));
int isNew;
char buffer[32 + TCL_INTEGER_SPACE];
AssocData *dPtr = (AssocData *)ckalloc(sizeof(AssocData));
Tcl_HashEntry *hPtr;
sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr);
(*assocDataCounterPtr)++;
if (iPtr->assocData == NULL) {
iPtr->assocData = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
}
hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &isNew);
dPtr->proc = proc;
dPtr->clientData = clientData;
Tcl_SetHashValue(hPtr, dPtr);
}
|
| ︙ | ︙ | |||
1414 1415 1416 1417 1418 1419 1420 |
hTablePtr = iPtr->assocData;
if (hTablePtr == NULL) {
return;
}
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
| | | | 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 |
hTablePtr = iPtr->assocData;
if (hTablePtr == NULL) {
return;
}
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &hSearch); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
dPtr = (AssocData *)Tcl_GetHashValue(hPtr);
if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
ckfree(dPtr);
Tcl_DeleteHashEntry(hPtr);
return;
}
}
}
/*
|
| ︙ | ︙ | |||
1456 1457 1458 1459 1460 1461 1462 |
{
Interp *iPtr = (Interp *) interp;
AssocData *dPtr;
Tcl_HashEntry *hPtr;
int isNew;
if (iPtr->assocData == NULL) {
| | | | | 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 |
{
Interp *iPtr = (Interp *) interp;
AssocData *dPtr;
Tcl_HashEntry *hPtr;
int isNew;
if (iPtr->assocData == NULL) {
iPtr->assocData = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
}
hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &isNew);
if (isNew == 0) {
dPtr = (AssocData *)Tcl_GetHashValue(hPtr);
} else {
dPtr = (AssocData *)ckalloc(sizeof(AssocData));
}
dPtr->proc = proc;
dPtr->clientData = clientData;
Tcl_SetHashValue(hPtr, dPtr);
}
|
| ︙ | ︙ | |||
1504 1505 1506 1507 1508 1509 1510 |
if (iPtr->assocData == NULL) {
return;
}
hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
if (hPtr == NULL) {
return;
}
| | | | 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 |
if (iPtr->assocData == NULL) {
return;
}
hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
if (hPtr == NULL) {
return;
}
dPtr = (AssocData *)Tcl_GetHashValue(hPtr);
if (dPtr->proc != NULL) {
dPtr->proc(dPtr->clientData, interp);
}
ckfree(dPtr);
Tcl_DeleteHashEntry(hPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetAssocData --
|
| ︙ | ︙ | |||
1549 1550 1551 1552 1553 1554 1555 |
if (iPtr->assocData == NULL) {
return NULL;
}
hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
if (hPtr == NULL) {
return NULL;
}
| | | 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 |
if (iPtr->assocData == NULL) {
return NULL;
}
hPtr = Tcl_FindHashEntry(iPtr->assocData, name);
if (hPtr == NULL) {
return NULL;
}
dPtr = (AssocData *)Tcl_GetHashValue(hPtr);
if (procPtr != NULL) {
*procPtr = dPtr->proc;
}
return dPtr->clientData;
}
/*
|
| ︙ | ︙ | |||
1700 1701 1702 1703 1704 1705 1706 |
* TIP #285, Script cancellation support. Delete this interp from the
* global hash table of CancelInfo structs.
*/
Tcl_MutexLock(&cancelLock);
hPtr = Tcl_FindHashEntry(&cancelTable, (char *) iPtr);
if (hPtr != NULL) {
| | | | | 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 |
* TIP #285, Script cancellation support. Delete this interp from the
* global hash table of CancelInfo structs.
*/
Tcl_MutexLock(&cancelLock);
hPtr = Tcl_FindHashEntry(&cancelTable, (char *) iPtr);
if (hPtr != NULL) {
CancelInfo *cancelInfo = (CancelInfo *)Tcl_GetHashValue(hPtr);
if (cancelInfo != NULL) {
if (cancelInfo->result != NULL) {
ckfree(cancelInfo->result);
}
ckfree(cancelInfo);
}
Tcl_DeleteHashEntry(hPtr);
}
if (iPtr->asyncCancel != NULL) {
Tcl_AsyncDelete(iPtr->asyncCancel);
|
| ︙ | ︙ | |||
1758 1759 1760 1761 1762 1763 1764 |
* to create any new hidden or non-hidden commands.
* Tcl_DeleteCommandFromToken will remove the entry from the
* hiddenCmdTablePtr.
*/
hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
| | | | | | | > > > | 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 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 |
* to create any new hidden or non-hidden commands.
* Tcl_DeleteCommandFromToken will remove the entry from the
* hiddenCmdTablePtr.
*/
hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
for (; hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Tcl_DeleteCommandFromToken(interp, (Tcl_Command)Tcl_GetHashValue(hPtr));
}
Tcl_DeleteHashTable(hTablePtr);
ckfree(hTablePtr);
}
/*
* Invoke deletion callbacks; note that a callback can create new
* callbacks, so we iterate.
*/
while (iPtr->assocData != NULL) {
AssocData *dPtr;
hTablePtr = iPtr->assocData;
iPtr->assocData = NULL;
for (hPtr = Tcl_FirstHashEntry(hTablePtr, &search);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(hTablePtr, &search)) {
dPtr = (AssocData *)Tcl_GetHashValue(hPtr);
Tcl_DeleteHashEntry(hPtr);
if (dPtr->proc != NULL) {
dPtr->proc(dPtr->clientData, interp);
}
ckfree(dPtr);
}
Tcl_DeleteHashTable(hTablePtr);
ckfree(hTablePtr);
}
/*
* Pop the root frame pointer and finish deleting the global
* namespace. The order is important [Bug 1658572].
*/
if ((iPtr->framePtr != iPtr->rootFramePtr) && !TclInExit()) {
Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top");
}
Tcl_PopCallFrame(interp);
ckfree(iPtr->rootFramePtr);
iPtr->rootFramePtr = NULL;
Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr);
/*
* Free up the result *after* deleting variables, since variable deletion
* could have transferred ownership of the result string to Tcl.
*/
#ifndef TCL_NO_DEPRECATED
Tcl_FreeResult(interp);
iPtr->result = NULL;
#endif
Tcl_DecrRefCount(iPtr->objResultPtr);
iPtr->objResultPtr = NULL;
Tcl_DecrRefCount(iPtr->ecVar);
if (iPtr->errorCode) {
Tcl_DecrRefCount(iPtr->errorCode);
iPtr->errorCode = NULL;
}
|
| ︙ | ︙ | |||
1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 |
Tcl_DecrRefCount(iPtr->upLiteral);
Tcl_DecrRefCount(iPtr->callLiteral);
Tcl_DecrRefCount(iPtr->innerLiteral);
Tcl_DecrRefCount(iPtr->innerContext);
if (iPtr->returnOpts) {
Tcl_DecrRefCount(iPtr->returnOpts);
}
TclFreePackageInfo(iPtr);
while (iPtr->tracePtr != NULL) {
Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr);
}
if (iPtr->execEnvPtr != NULL) {
TclDeleteExecEnv(iPtr->execEnvPtr);
}
if (iPtr->scriptFile) {
Tcl_DecrRefCount(iPtr->scriptFile);
iPtr->scriptFile = NULL;
}
Tcl_DecrRefCount(iPtr->emptyObjPtr);
iPtr->emptyObjPtr = NULL;
resPtr = iPtr->resolverPtr;
while (resPtr) {
nextResPtr = resPtr->nextPtr;
| > > > > > > | | | | | | | | | | | | | | | 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 |
Tcl_DecrRefCount(iPtr->upLiteral);
Tcl_DecrRefCount(iPtr->callLiteral);
Tcl_DecrRefCount(iPtr->innerLiteral);
Tcl_DecrRefCount(iPtr->innerContext);
if (iPtr->returnOpts) {
Tcl_DecrRefCount(iPtr->returnOpts);
}
#ifndef TCL_NO_DEPRECATED
if (iPtr->appendResult != NULL) {
ckfree(iPtr->appendResult);
iPtr->appendResult = NULL;
}
#endif
TclFreePackageInfo(iPtr);
while (iPtr->tracePtr != NULL) {
Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr);
}
if (iPtr->execEnvPtr != NULL) {
TclDeleteExecEnv(iPtr->execEnvPtr);
}
if (iPtr->scriptFile) {
Tcl_DecrRefCount(iPtr->scriptFile);
iPtr->scriptFile = NULL;
}
Tcl_DecrRefCount(iPtr->emptyObjPtr);
iPtr->emptyObjPtr = NULL;
resPtr = iPtr->resolverPtr;
while (resPtr) {
nextResPtr = resPtr->nextPtr;
ckfree(resPtr->name);
ckfree(resPtr);
resPtr = nextResPtr;
}
/*
* Free up literal objects created for scripts compiled by the
* interpreter.
*/
TclDeleteLiteralTable(interp, &iPtr->literalTable);
/*
* TIP #280 - Release the arrays for ByteCode/Proc extension, and
* contents.
*/
for (hPtr = Tcl_FirstHashEntry(iPtr->linePBodyPtr, &search);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
CmdFrame *cfPtr = (CmdFrame *)Tcl_GetHashValue(hPtr);
Proc *procPtr = (Proc *) Tcl_GetHashKey(iPtr->linePBodyPtr, hPtr);
procPtr->iPtr = NULL;
if (cfPtr) {
if (cfPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(cfPtr->data.eval.path);
}
ckfree(cfPtr->line);
ckfree(cfPtr);
}
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(iPtr->linePBodyPtr);
ckfree(iPtr->linePBodyPtr);
iPtr->linePBodyPtr = NULL;
/*
* See also tclCompile.c, TclCleanupByteCode
*/
for (hPtr = Tcl_FirstHashEntry(iPtr->lineBCPtr, &search);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
ExtCmdLoc *eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hPtr);
if (eclPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(eclPtr->path);
}
for (i=0; i< eclPtr->nuloc; i++) {
ckfree(eclPtr->loc[i].line);
}
if (eclPtr->loc != NULL) {
ckfree(eclPtr->loc);
}
ckfree(eclPtr);
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(iPtr->lineBCPtr);
ckfree(iPtr->lineBCPtr);
iPtr->lineBCPtr = NULL;
/*
* Location stack for uplevel/eval/... scripts which were passed through
* proc arguments. Actually we track all arguments as we do not and cannot
* know which arguments will be used as scripts and which will not.
*/
if (iPtr->lineLAPtr->numEntries && !TclInExit()) {
/*
* When the interp goes away we have nothing on the stack, so there
* are no arguments, so this table has to be empty.
*/
Tcl_Panic("Argument location tracking table not empty");
}
Tcl_DeleteHashTable(iPtr->lineLAPtr);
ckfree(iPtr->lineLAPtr);
iPtr->lineLAPtr = NULL;
if (iPtr->lineLABCPtr->numEntries && !TclInExit()) {
/*
* When the interp goes away we have nothing on the stack, so there
* are no arguments, so this table has to be empty.
*/
Tcl_Panic("Argument location tracking table not empty");
}
Tcl_DeleteHashTable(iPtr->lineLABCPtr);
ckfree(iPtr->lineLABCPtr);
iPtr->lineLABCPtr = NULL;
/*
* Squelch the tables of traces on variables and searches over arrays in
* the in the interpreter.
*/
Tcl_DeleteHashTable(&iPtr->varTraces);
Tcl_DeleteHashTable(&iPtr->varSearches);
ckfree(iPtr);
}
/*
*---------------------------------------------------------------------------
*
* Tcl_HideCommand --
*
|
| ︙ | ︙ | |||
2053 2054 2055 2056 2057 2058 2059 |
/*
* Initialize the hidden command table if necessary.
*/
hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
if (hiddenCmdTablePtr == NULL) {
| | | 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 |
/*
* Initialize the hidden command table if necessary.
*/
hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
if (hiddenCmdTablePtr == NULL) {
hiddenCmdTablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS);
iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr;
}
/*
* It is an error to move an exposed command to a hidden command with
* hiddenCmdToken if a hidden command with the name hiddenCmdToken already
|
| ︙ | ︙ | |||
2193 2194 2195 2196 2197 2198 2199 |
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown hidden command \"%s\"", hiddenCmdToken));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN",
hiddenCmdToken, NULL);
return TCL_ERROR;
}
| | | 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 |
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown hidden command \"%s\"", hiddenCmdToken));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN",
hiddenCmdToken, NULL);
return TCL_ERROR;
}
cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
/*
* Check that we have a true global namespace command (enforced by
* Tcl_HideCommand but let's double check. (If it was not, we would not
* really know how to handle it).
*/
|
| ︙ | ︙ | |||
2389 2390 2391 2392 2393 2394 2395 |
break;
}
/*
* An existing command conflicts. Try to delete it...
*/
| | | 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 |
break;
}
/*
* An existing command conflicts. Try to delete it...
*/
cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
/*
* Be careful to preserve any existing import links so we can restore
* them down below. That way, you can redefine a command and its
* import status will remain intact.
*/
|
| ︙ | ︙ | |||
2419 2420 2421 2422 2423 2424 2425 |
if (!isNew) {
/*
* If the deletion callback recreated the command, just throw away the
* new command (if we try to delete it again, we could get stuck in an
* infinite loop).
*/
| | | 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 |
if (!isNew) {
/*
* If the deletion callback recreated the command, just throw away the
* new command (if we try to delete it again, we could get stuck in an
* infinite loop).
*/
ckfree(Tcl_GetHashValue(hPtr));
}
if (!deleted) {
/*
* Command resolvers (per-interp, per-namespace) might have resolved
* to a command for the given namespace scope with this command not
* being registered with the namespace's command table. During BC
|
| ︙ | ︙ | |||
2444 2445 2446 2447 2448 2449 2450 |
* However, we do not need to recompute this just yet; next time we
* need the info will be soon enough.
*/
TclInvalidateNsCmdLookup(nsPtr);
TclInvalidateNsPath(nsPtr);
}
| | | 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 |
* However, we do not need to recompute this just yet; next time we
* need the info will be soon enough.
*/
TclInvalidateNsCmdLookup(nsPtr);
TclInvalidateNsPath(nsPtr);
}
cmdPtr = (Command *)ckalloc(sizeof(Command));
Tcl_SetHashValue(hPtr, cmdPtr);
cmdPtr->hPtr = hPtr;
cmdPtr->nsPtr = nsPtr;
cmdPtr->refCount = 1;
cmdPtr->cmdEpoch = 0;
cmdPtr->compileProc = NULL;
cmdPtr->objProc = TclInvokeStringCommand;
|
| ︙ | ︙ | |||
2471 2472 2473 2474 2475 2476 2477 |
* all of these references to point to the new command.
*/
if (oldRefPtr != NULL) {
cmdPtr->importRefPtr = oldRefPtr;
while (oldRefPtr != NULL) {
Command *refCmdPtr = oldRefPtr->importedCmdPtr;
| | | 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 |
* all of these references to point to the new command.
*/
if (oldRefPtr != NULL) {
cmdPtr->importRefPtr = oldRefPtr;
while (oldRefPtr != NULL) {
Command *refCmdPtr = oldRefPtr->importedCmdPtr;
dataPtr = (ImportedCmdData *)refCmdPtr->objClientData;
dataPtr->realCmdPtr = cmdPtr;
oldRefPtr = oldRefPtr->nextPtr;
}
}
/*
* We just created a command, so in its namespace and all of its parent
|
| ︙ | ︙ | |||
2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 | * Results: * The return value is a token for the command, which can be used in * future calls to Tcl_GetCommandName. * * Side effects: * If a command named "cmdName" already exists for interp, it is * first deleted. Then the new command is created from the arguments. * * In the future, during bytecode evaluation when "cmdName" is seen as * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based * Tcl_ObjCmdProc proc will be called. When the command is deleted from * the table, deleteProc will be called. See the manual entry for details * on the calling sequence. * | > | 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 | * Results: * The return value is a token for the command, which can be used in * future calls to Tcl_GetCommandName. * * Side effects: * If a command named "cmdName" already exists for interp, it is * first deleted. Then the new command is created from the arguments. * [***] (See below for exception). * * In the future, during bytecode evaluation when "cmdName" is seen as * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based * Tcl_ObjCmdProc proc will be called. When the command is deleted from * the table, deleteProc will be called. See the manual entry for details * on the calling sequence. * |
| ︙ | ︙ | |||
2569 2570 2571 2572 2573 2574 2575 |
}
Tcl_Command
TclCreateObjCommandInNs(
Tcl_Interp *interp,
const char *cmdName, /* Name of command, without any namespace
* components. */
| | | | 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 |
}
Tcl_Command
TclCreateObjCommandInNs(
Tcl_Interp *interp,
const char *cmdName, /* Name of command, without any namespace
* components. */
Tcl_Namespace *namesp, /* The namespace to create the command in */
Tcl_ObjCmdProc *proc, /* Object-based function to associate with
* name. */
ClientData clientData, /* Arbitrary value to pass to object
* function. */
Tcl_CmdDeleteProc *deleteProc)
/* If not NULL, gives a function to call when
* this command is deleted. */
{
int deleted = 0, isNew = 0;
Command *cmdPtr;
ImportRef *oldRefPtr = NULL;
ImportedCmdData *dataPtr;
Tcl_HashEntry *hPtr;
Namespace *nsPtr = (Namespace *) namesp;
/*
* If the command name we seek to create already exists, we need to delete
* that first. That can be tricky in the presence of traces. Loop until we
* no longer find an existing command in the way, or until we've deleted
* one command and that didn't finish the job.
*/
|
| ︙ | ︙ | |||
2607 2608 2609 2610 2611 2612 2613 |
break;
}
/*
* An existing command conflicts. Try to delete it...
*/
| | > > > > > > > > > > > > > > > > > | | 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 |
break;
}
/*
* An existing command conflicts. Try to delete it...
*/
cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
/*
* [***] This is wrong. See Tcl Bug a16752c252.
* However, this buggy behavior is kept under particular circumstances
* to accommodate deployed binaries of the "tclcompiler" program
* <http://sourceforge.net/projects/tclpro/> that crash if the bug is
* fixed.
*/
if (cmdPtr->objProc == TclInvokeStringCommand
&& cmdPtr->clientData == clientData
&& cmdPtr->deleteData == clientData
&& cmdPtr->deleteProc == deleteProc) {
cmdPtr->objProc = proc;
cmdPtr->objClientData = clientData;
return (Tcl_Command) cmdPtr;
}
/*
* Otherwise, we delete the old command. Be careful to preserve any
* existing import links so we can restore them down below. That way,
* you can redefine a command and its import status will remain
* intact.
*/
cmdPtr->refCount++;
if (cmdPtr->importRefPtr) {
|
| ︙ | ︙ | |||
2646 2647 2648 2649 2650 2651 2652 |
if (!isNew) {
/*
* If the deletion callback recreated the command, just throw away the
* new command (if we try to delete it again, we could get stuck in an
* infinite loop).
*/
| | | 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 |
if (!isNew) {
/*
* If the deletion callback recreated the command, just throw away the
* new command (if we try to delete it again, we could get stuck in an
* infinite loop).
*/
ckfree(Tcl_GetHashValue(hPtr));
}
if (!deleted) {
/*
* Command resolvers (per-interp, per-namespace) might have resolved
* to a command for the given namespace scope with this command not
* being registered with the namespace's command table. During BC
|
| ︙ | ︙ | |||
2671 2672 2673 2674 2675 2676 2677 |
* However, we do not need to recompute this just yet; next time we
* need the info will be soon enough.
*/
TclInvalidateNsCmdLookup(nsPtr);
TclInvalidateNsPath(nsPtr);
}
| | | 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 |
* However, we do not need to recompute this just yet; next time we
* need the info will be soon enough.
*/
TclInvalidateNsCmdLookup(nsPtr);
TclInvalidateNsPath(nsPtr);
}
cmdPtr = (Command *)ckalloc(sizeof(Command));
Tcl_SetHashValue(hPtr, cmdPtr);
cmdPtr->hPtr = hPtr;
cmdPtr->nsPtr = nsPtr;
cmdPtr->refCount = 1;
cmdPtr->cmdEpoch = 0;
cmdPtr->compileProc = NULL;
cmdPtr->objProc = proc;
|
| ︙ | ︙ | |||
2699 2700 2701 2702 2703 2704 2705 |
*/
if (oldRefPtr != NULL) {
cmdPtr->importRefPtr = oldRefPtr;
while (oldRefPtr != NULL) {
Command *refCmdPtr = oldRefPtr->importedCmdPtr;
| | | 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 |
*/
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
|
| ︙ | ︙ | |||
2741 2742 2743 2744 2745 2746 2747 |
*----------------------------------------------------------------------
*/
int
TclInvokeStringCommand(
ClientData clientData, /* Points to command's Command structure. */
Tcl_Interp *interp, /* Current interpreter. */
| | | | | 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 |
*----------------------------------------------------------------------
*/
int
TclInvokeStringCommand(
ClientData clientData, /* Points to command's Command structure. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Command *cmdPtr = (Command *)clientData;
int i, result;
const char **argv = (const char **)
TclStackAlloc(interp, (objc + 1) * sizeof(char *));
for (i = 0; i < objc; i++) {
argv[i] = TclGetString(objv[i]);
}
argv[objc] = 0;
|
| ︙ | ︙ | |||
2790 2791 2792 2793 2794 2795 2796 |
*/
int
TclInvokeObjectCommand(
ClientData clientData, /* Points to command's Command structure. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
| | | | > > > > > > > | 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 |
*/
int
TclInvokeObjectCommand(
ClientData clientData, /* Points to command's Command structure. */
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Command *cmdPtr = ( Command *) clientData;
Tcl_Obj *objPtr;
int i, length, result;
Tcl_Obj **objv = (Tcl_Obj **)
TclStackAlloc(interp, (argc * sizeof(Tcl_Obj *)));
for (i = 0; i < argc; i++) {
length = strlen(argv[i]);
TclNewStringObj(objPtr, argv[i], length);
Tcl_IncrRefCount(objPtr);
objv[i] = objPtr;
}
/*
* Invoke the command's object-based Tcl_ObjCmdProc.
*/
if (cmdPtr->objProc != NULL) {
result = cmdPtr->objProc(cmdPtr->objClientData, interp, argc, objv);
} else {
result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc,
cmdPtr->objClientData, argc, objv);
}
/*
* Move the interpreter's object result to the string result, then reset
* the object result.
*/
(void) Tcl_GetStringResult(interp);
/*
* Decrement the ref counts for the argument objects created above, then
* free the objv array if malloc'ed storage was used.
*/
for (i = 0; i < argc; i++) {
objPtr = objv[i];
|
| ︙ | ︙ | |||
3223 3224 3225 3226 3227 3228 3229 | * None. * *---------------------------------------------------------------------- */ const char * Tcl_GetCommandName( | | | | 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 |
* None.
*
*----------------------------------------------------------------------
*/
const char *
Tcl_GetCommandName(
TCL_UNUSED(Tcl_Interp *),
Tcl_Command command) /* Token for command returned by a previous
* call to Tcl_CreateCommand. The command must
* not have been deleted. */
{
Command *cmdPtr = (Command *) command;
if ((cmdPtr == NULL) || (cmdPtr->hPtr == NULL)) {
/*
* This should only happen if command was "created" after the
* interpreter began to be deleted, so there isn't really any command.
* Just return an empty string.
*/
return "";
}
return (const char *)Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetCommandFullName --
*
|
| ︙ | ︙ | |||
3274 3275 3276 3277 3278 3279 3280 |
* call to Tcl_CreateCommand. The command must
* not have been deleted. */
Tcl_Obj *objPtr) /* Points to the object onto which the
* command's full name is appended. */
{
Interp *iPtr = (Interp *) interp;
| | | | 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 |
* call to Tcl_CreateCommand. The command must
* not have been deleted. */
Tcl_Obj *objPtr) /* Points to the object onto which the
* command's full name is appended. */
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = (Command *) command;
char *name;
/*
* Add the full name of the containing namespace, followed by the "::"
* separator, and the command name.
*/
if (cmdPtr != NULL) {
if (cmdPtr->nsPtr != NULL) {
Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1);
if (cmdPtr->nsPtr != iPtr->globalNsPtr) {
Tcl_AppendToObj(objPtr, "::", 2);
}
}
if (cmdPtr->hPtr != NULL) {
name = (char *)Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
Tcl_AppendToObj(objPtr, name, -1);
}
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
3426 3427 3428 3429 3430 3431 3432 |
*/
tracePtr = cmdPtr->tracePtr;
while (tracePtr != NULL) {
CommandTrace *nextPtr = tracePtr->nextPtr;
if (tracePtr->refCount-- <= 1) {
| | | 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 |
*/
tracePtr = cmdPtr->tracePtr;
while (tracePtr != NULL) {
CommandTrace *nextPtr = tracePtr->nextPtr;
if (tracePtr->refCount-- <= 1) {
ckfree(tracePtr);
}
tracePtr = nextPtr;
}
cmdPtr->tracePtr = NULL;
}
/*
|
| ︙ | ︙ | |||
3465 3466 3467 3468 3469 3470 3471 | * created when a command was imported into a namespace, this client * data will be a pointer to a ImportedCmdData structure describing * the "real" command that this imported command refers to. * * If you are getting a crash during the call to deleteProc and * cmdPtr->deleteProc is a pointer to the function free(), the most * likely cause is that your extension allocated memory for the | | | | | 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 |
* created when a command was imported into a namespace, this client
* data will be a pointer to a ImportedCmdData structure describing
* the "real" command that this imported command refers to.
*
* If you are getting a crash during the call to deleteProc and
* cmdPtr->deleteProc is a pointer to the function free(), the most
* likely cause is that your extension allocated memory for the
* clientData argument to Tcl_CreateObjCommand with the ckalloc()
* macro and you are now trying to deallocate this memory with free()
* instead of ckfree(). You should pass a pointer to your own method
* that calls ckfree().
*/
cmdPtr->deleteProc(cmdPtr->deleteData);
}
/*
* If this command was imported into other namespaces, then imported
|
| ︙ | ︙ | |||
3558 3559 3560 3561 3562 3563 3564 |
* the name from cmdPtr */
const char *newName, /* Command's new name, or NULL if the command
* is not being renamed */
int flags) /* Flags indicating the type of traces to
* trigger, either TCL_TRACE_DELETE or
* TCL_TRACE_RENAME. */
{
| | | 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 |
* the name from cmdPtr */
const char *newName, /* Command's new name, or NULL if the command
* is not being renamed */
int flags) /* Flags indicating the type of traces to
* trigger, either TCL_TRACE_DELETE or
* TCL_TRACE_RENAME. */
{
CommandTrace *tracePtr;
ActiveCommandTrace active;
char *result;
Tcl_Obj *oldNamePtr = NULL;
Tcl_InterpState state = NULL;
if (cmdPtr->flags & CMD_TRACE_ACTIVE) {
/*
|
| ︙ | ︙ | |||
3620 3621 3622 3623 3624 3625 3626 |
if (state == NULL) {
state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, TCL_OK);
}
tracePtr->traceProc(tracePtr->clientData, (Tcl_Interp *) iPtr,
oldName, newName, flags);
cmdPtr->flags &= ~tracePtr->flags;
if (tracePtr->refCount-- <= 1) {
| | | 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 |
if (state == NULL) {
state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, TCL_OK);
}
tracePtr->traceProc(tracePtr->clientData, (Tcl_Interp *) iPtr,
oldName, newName, flags);
cmdPtr->flags &= ~tracePtr->flags;
if (tracePtr->refCount-- <= 1) {
ckfree(tracePtr);
}
}
if (state) {
Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state);
}
|
| ︙ | ︙ | |||
3671 3672 3673 3674 3675 3676 3677 |
*
*----------------------------------------------------------------------
*/
static int
CancelEvalProc(
ClientData clientData, /* Interp to cancel the script in progress. */
| | | | 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 |
*
*----------------------------------------------------------------------
*/
static int
CancelEvalProc(
ClientData clientData, /* Interp to cancel the script in progress. */
TCL_UNUSED(Tcl_Interp *),
int code) /* Current return code from command. */
{
CancelInfo *cancelInfo = (CancelInfo *)clientData;
Interp *iPtr;
if (cancelInfo != NULL) {
Tcl_MutexLock(&cancelLock);
iPtr = (Interp *) cancelInfo->interp;
if (iPtr != NULL) {
|
| ︙ | ︙ | |||
3748 3749 3750 3751 3752 3753 3754 | * deleted or when the last ByteCode referring to it is freed. * *---------------------------------------------------------------------- */ void TclCleanupCommand( | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 |
* deleted or when the last ByteCode referring to it is freed.
*
*----------------------------------------------------------------------
*/
void
TclCleanupCommand(
Command *cmdPtr) /* Points to the Command structure to
* be freed. */
{
if (cmdPtr->refCount-- <= 1) {
ckfree(cmdPtr);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateMathFunc --
*
* Creates a new math function for expressions in a given interpreter.
*
* Results:
* None.
*
* Side effects:
* The Tcl function defined by "name" is created or redefined. If the
* function already exists then its definition is replaced; this includes
* the builtin functions. Redefining a builtin function forces all
* existing code to be invalidated since that code may be compiled using
* an instruction specific to the replaced function. In addition,
* redefioning a non-builtin function will force existing code to be
* invalidated if the number of arguments has changed.
*
*----------------------------------------------------------------------
*/
#if !defined(TCL_NO_DEPRECATED)
void
Tcl_CreateMathFunc(
Tcl_Interp *interp, /* Interpreter in which function is to be
* available. */
const char *name, /* Name of function (e.g. "sin"). */
int numArgs, /* Nnumber of arguments required by
* function. */
Tcl_ValueType *argTypes, /* Array of types acceptable for each
* argument. */
Tcl_MathProc *proc, /* C function that implements the math
* function. */
ClientData clientData) /* Additional value to pass to the
* function. */
{
Tcl_DString bigName;
OldMathFuncData *data = (OldMathFuncData *)ckalloc(sizeof(OldMathFuncData));
data->proc = proc;
data->numArgs = numArgs;
data->argTypes = (Tcl_ValueType *)ckalloc(numArgs * sizeof(Tcl_ValueType));
memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType));
data->clientData = clientData;
Tcl_DStringInit(&bigName);
TclDStringAppendLiteral(&bigName, "::tcl::mathfunc::");
Tcl_DStringAppend(&bigName, name, -1);
Tcl_CreateObjCommand(interp, Tcl_DStringValue(&bigName),
OldMathFuncProc, data, OldMathFuncDeleteProc);
Tcl_DStringFree(&bigName);
}
/*
*----------------------------------------------------------------------
*
* OldMathFuncProc --
*
* Dispatch to a math function created with Tcl_CreateMathFunc
*
* Results:
* Returns a standard Tcl result.
*
* Side effects:
* Whatever the math function does.
*
*----------------------------------------------------------------------
*/
static int
OldMathFuncProc(
ClientData clientData, /* Pointer to OldMathFuncData describing the
* function being called */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Actual parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
Tcl_Obj *valuePtr;
OldMathFuncData *dataPtr = (OldMathFuncData *)clientData;
Tcl_Value funcResult, *args;
int result;
int j, k;
double d;
/*
* Check argument count.
*/
if (objc != dataPtr->numArgs + 1) {
MathFuncWrongNumArgs(interp, dataPtr->numArgs+1, objc, objv);
return TCL_ERROR;
}
/*
* Convert arguments from Tcl_Obj's to Tcl_Value's.
*/
args = (Tcl_Value *)ckalloc(dataPtr->numArgs * sizeof(Tcl_Value));
for (j = 1, k = 0; j < objc; ++j, ++k) {
/* TODO: Convert to TclGetNumberFromObj? */
valuePtr = objv[j];
result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d);
#ifdef ACCEPT_NAN
if (result != TCL_OK) {
const Tcl_ObjIntRep *irPtr
= TclFetchIntRep(valuePtr, &tclDoubleType);
if (irPtr) {
d = irPtr->doubleValue;
result = TCL_OK;
}
}
#endif
if (result != TCL_OK) {
/*
* We have a non-numeric argument.
*/
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"argument to math function didn't have numeric value",
-1));
TclCheckBadOctal(interp, TclGetString(valuePtr));
ckfree(args);
return TCL_ERROR;
}
/*
* Copy the object's numeric value to the argument record, converting
* it if necessary.
*
* NOTE: no bignum support; use the new mathfunc interface for that.
*/
args[k].type = dataPtr->argTypes[k];
switch (args[k].type) {
case TCL_EITHER:
if (Tcl_GetLongFromObj(NULL, valuePtr, &args[k].intValue)
== TCL_OK) {
args[k].type = TCL_INT;
break;
}
if (TclGetWideIntFromObj(interp, valuePtr, &args[k].wideValue)
== TCL_OK) {
args[k].type = TCL_WIDE_INT;
break;
}
args[k].type = TCL_DOUBLE;
/* FALLTHROUGH */
case TCL_DOUBLE:
args[k].doubleValue = d;
break;
case TCL_INT:
if (ExprIntFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) {
ckfree(args);
return TCL_ERROR;
}
valuePtr = Tcl_GetObjResult(interp);
Tcl_GetLongFromObj(NULL, valuePtr, &args[k].intValue);
Tcl_ResetResult(interp);
break;
case TCL_WIDE_INT:
if (ExprWideFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) {
ckfree(args);
return TCL_ERROR;
}
valuePtr = Tcl_GetObjResult(interp);
TclGetWideIntFromObj(NULL, valuePtr, &args[k].wideValue);
Tcl_ResetResult(interp);
break;
}
}
/*
* Call the function.
*/
errno = 0;
result = dataPtr->proc(dataPtr->clientData, interp, args, &funcResult);
ckfree(args);
if (result != TCL_OK) {
return result;
}
/*
* Return the result of the call.
*/
if (funcResult.type == TCL_INT) {
TclNewIntObj(valuePtr, funcResult.intValue);
} else if (funcResult.type == TCL_WIDE_INT) {
valuePtr = Tcl_NewWideIntObj(funcResult.wideValue);
} else {
return CheckDoubleResult(interp, funcResult.doubleValue);
}
Tcl_SetObjResult(interp, valuePtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* OldMathFuncDeleteProc --
*
* Cleans up after deleting a math function registered with
* Tcl_CreateMathFunc
*
* Results:
* None.
*
* Side effects:
* Frees allocated memory.
*
*----------------------------------------------------------------------
*/
static void
OldMathFuncDeleteProc(
ClientData clientData)
{
OldMathFuncData *dataPtr = (OldMathFuncData *)clientData;
ckfree(dataPtr->argTypes);
ckfree(dataPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetMathFuncInfo --
*
* Discovers how a particular math function was created in a given
* interpreter.
*
* Results:
* TCL_OK if it succeeds, TCL_ERROR else (leaving an error message in the
* interpreter result if that happens.)
*
* Side effects:
* If this function succeeds, the variables pointed to by the numArgsPtr
* and argTypePtr arguments will be updated to detail the arguments
* allowed by the function. The variable pointed to by the procPtr
* argument will be set to NULL if the function is a builtin function,
* and will be set to the address of the C function used to implement the
* math function otherwise (in which case the variable pointed to by the
* clientDataPtr argument will also be updated.)
*
*----------------------------------------------------------------------
*/
int
Tcl_GetMathFuncInfo(
Tcl_Interp *interp,
const char *name,
int *numArgsPtr,
Tcl_ValueType **argTypesPtr,
Tcl_MathProc **procPtr,
ClientData *clientDataPtr)
{
Tcl_Obj *cmdNameObj;
Command *cmdPtr;
/*
* Get the command that implements the math function.
*/
TclNewLiteralStringObj(cmdNameObj, "tcl::mathfunc::");
Tcl_AppendToObj(cmdNameObj, name, -1);
Tcl_IncrRefCount(cmdNameObj);
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdNameObj);
Tcl_DecrRefCount(cmdNameObj);
/*
* Report unknown functions.
*/
if (cmdPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown math function \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "MATHFUNC", name, NULL);
*numArgsPtr = -1;
*argTypesPtr = NULL;
*procPtr = NULL;
*clientDataPtr = NULL;
return TCL_ERROR;
}
/*
* Retrieve function info for user defined functions; return dummy
* information for builtins.
*/
if (cmdPtr->objProc == &OldMathFuncProc) {
OldMathFuncData *dataPtr = (OldMathFuncData *)cmdPtr->clientData;
*procPtr = dataPtr->proc;
*numArgsPtr = dataPtr->numArgs;
*argTypesPtr = dataPtr->argTypes;
*clientDataPtr = dataPtr->clientData;
} else {
*procPtr = NULL;
*numArgsPtr = -1;
*argTypesPtr = NULL;
*procPtr = NULL;
*clientDataPtr = NULL;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListMathFuncs --
*
* Produces a list of all the math functions defined in a given
* interpreter.
*
* Results:
* A pointer to a Tcl_Obj structure with a reference count of zero, or
* NULL in the case of an error (in which case a suitable error message
* will be left in the interpreter result.)
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_ListMathFuncs(
Tcl_Interp *interp,
const char *pattern)
{
Tcl_Obj *script = Tcl_NewStringObj("::info functions ", -1);
Tcl_Obj *result;
Tcl_InterpState state;
if (pattern) {
Tcl_Obj *patternObj = Tcl_NewStringObj(pattern, -1);
Tcl_Obj *arg = Tcl_NewListObj(1, &patternObj);
Tcl_AppendObjToObj(script, arg);
Tcl_DecrRefCount(arg); /* Should tear down patternObj too */
}
state = Tcl_SaveInterpState(interp, TCL_OK);
Tcl_IncrRefCount(script);
if (TCL_OK == Tcl_EvalObjEx(interp, script, 0)) {
result = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
} else {
result = Tcl_NewObj();
}
Tcl_DecrRefCount(script);
Tcl_RestoreInterpState(interp, state);
return result;
}
#endif /* !defined(TCL_NO_DEPRECATED) */
/*
*----------------------------------------------------------------------
*
* TclInterpReady --
*
* Check if an interpreter is ready to eval commands or scripts, i.e., if
* it was not deleted and if the nesting level is not too high.
*
* Results:
* The return value is TCL_OK if it the interpreter is ready, TCL_ERROR
* otherwise.
*
* Side effects:
* The interpreters object and string results are cleared.
*
*----------------------------------------------------------------------
*/
int
TclInterpReady(
Tcl_Interp *interp)
{
Interp *iPtr = (Interp *) interp;
/*
* Reset both the interpreter's string and object results and clear out
* any previous error information.
*/
Tcl_ResetResult(interp);
/*
* If the interpreter has been deleted, return an error.
*/
|
| ︙ | ︙ | |||
3850 3851 3852 3853 3854 3855 3856 |
*/
int
TclResetCancellation(
Tcl_Interp *interp,
int force)
{
| | | 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 |
*/
int
TclResetCancellation(
Tcl_Interp *interp,
int force)
{
Interp *iPtr = (Interp *) interp;
if (iPtr == NULL) {
return TCL_ERROR;
}
if (force || (iPtr->numLevels == 0)) {
TclUnsetCancelFlags(iPtr);
|
| ︙ | ︙ | |||
3892 3893 3894 3895 3896 3897 3898 |
*/
int
Tcl_Canceled(
Tcl_Interp *interp,
int flags)
{
| | | 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 |
*/
int
Tcl_Canceled(
Tcl_Interp *interp,
int flags)
{
Interp *iPtr = (Interp *) interp;
/*
* Has the current script in progress for this interpreter been canceled
* or is the stack being unwound due to the previous script cancellation?
*/
if (!TclCanceled(iPtr)) {
|
| ︙ | ︙ | |||
3931 3932 3933 3934 3935 3936 3937 |
/*
* If the TCL_LEAVE_ERR_MSG flags bit is set, place an error in the
* interp's result; otherwise, we leave it alone.
*/
if (flags & TCL_LEAVE_ERR_MSG) {
const char *id, *message = NULL;
| | | 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 |
/*
* If the TCL_LEAVE_ERR_MSG flags bit is set, place an error in the
* interp's result; otherwise, we leave it alone.
*/
if (flags & TCL_LEAVE_ERR_MSG) {
const char *id, *message = NULL;
int length;
/*
* Setup errorCode variables so that we can differentiate between
* being canceled and unwound.
*/
if (iPtr->asyncCancelMsg != NULL) {
|
| ︙ | ︙ | |||
4027 4028 4029 4030 4031 4032 4033 |
if (hPtr == NULL) {
/*
* No CancelInfo record for this interpreter.
*/
goto done;
}
| | | | 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 |
if (hPtr == NULL) {
/*
* No CancelInfo record for this interpreter.
*/
goto done;
}
cancelInfo = (CancelInfo *)Tcl_GetHashValue(hPtr);
/*
* Populate information needed by the interpreter thread to fulfill the
* cancellation request. Currently, clientData is ignored. If the
* TCL_CANCEL_UNWIND flags bit is set, the script in progress is not
* allowed to catch the script cancellation because the evaluation stack
* for the interp is completely unwound.
*/
if (resultObjPtr != NULL) {
result = TclGetStringFromObj(resultObjPtr, &cancelInfo->length);
cancelInfo->result = (char *)ckrealloc(cancelInfo->result,cancelInfo->length);
memcpy(cancelInfo->result, result, cancelInfo->length);
TclDecrRefCount(resultObjPtr); /* Discard their result object. */
} else {
cancelInfo->result = NULL;
cancelInfo->length = 0;
}
cancelInfo->clientData = clientData;
|
| ︙ | ︙ | |||
4157 4158 4159 4160 4161 4162 4163 |
return TCL_OK;
}
static int
EvalObjvCore(
ClientData data[],
Tcl_Interp *interp,
| | | | | 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 |
return TCL_OK;
}
static int
EvalObjvCore(
ClientData data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
Command *cmdPtr = NULL, *preCmdPtr = (Command *)data[0];
int flags = PTR2INT(data[1]);
int objc = PTR2INT(data[2]);
Tcl_Obj **objv = (Tcl_Obj **)data[3];
Interp *iPtr = (Interp *) interp;
Namespace *lookupNsPtr = NULL;
int enterTracesDone = 0;
/*
* Push records for task to be done on return, in INVERSE order. First, if
* needed, the exception handlers (as they should happen last).
|
| ︙ | ︙ | |||
4317 4318 4319 4320 4321 4322 4323 |
return TCL_OK;
}
static int
Dispatch(
ClientData data[],
Tcl_Interp *interp,
| | | | | 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 |
return TCL_OK;
}
static int
Dispatch(
ClientData data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
Tcl_ObjCmdProc *objProc = (Tcl_ObjCmdProc *)data[0];
ClientData clientData = data[1];
int objc = PTR2INT(data[2]);
Tcl_Obj **objv = (Tcl_Obj **)data[3];
Interp *iPtr = (Interp *) interp;
#ifdef USE_DTRACE
if (TCL_DTRACE_CMD_ARGS_ENABLED()) {
const char *a[10];
int i = 0;
|
| ︙ | ︙ | |||
4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 |
TclNRRunCallbacks(
Tcl_Interp *interp,
int result,
struct NRE_callback *rootPtr)
/* All callbacks down to rootPtr not inclusive
* are to be run. */
{
while (TOP_CB(interp) != rootPtr) {
NRE_callback *callbackPtr = TOP_CB(interp);
Tcl_NRPostProc *procPtr = callbackPtr->procPtr;
TOP_CB(interp) = callbackPtr->nextPtr;
result = procPtr(callbackPtr->data, interp, result);
TCLNR_FREE(interp, callbackPtr);
| > > > > > > > > > > > > > > > > > > > > > > > > | 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 |
TclNRRunCallbacks(
Tcl_Interp *interp,
int result,
struct NRE_callback *rootPtr)
/* All callbacks down to rootPtr not inclusive
* are to be run. */
{
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
Interp *iPtr = (Interp *) interp;
#endif /* !defined(TCL_NO_DEPRECATED) */
/*
* If the interpreter has a non-empty string result, the result object is
* either empty or stale because some function set interp->result
* directly. If so, move the string result to the result object, then
* reset the string result.
*
* This only needs to be done for the first item in the list: all other
* are for NR function calls, and those are Tcl_Obj based.
*/
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
if (*(iPtr->result) != 0) {
(void) Tcl_GetObjResult(interp);
}
#endif /* !defined(TCL_NO_DEPRECATED) */
/*
* This is the trampoline.
*/
while (TOP_CB(interp) != rootPtr) {
NRE_callback *callbackPtr = TOP_CB(interp);
Tcl_NRPostProc *procPtr = callbackPtr->procPtr;
TOP_CB(interp) = callbackPtr->nextPtr;
result = procPtr(callbackPtr->data, interp, result);
TCLNR_FREE(interp, callbackPtr);
|
| ︙ | ︙ | |||
4483 4484 4485 4486 4487 4488 4489 |
static int
TEOV_RestoreVarFrame(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 |
static int
TEOV_RestoreVarFrame(
ClientData data[],
Tcl_Interp *interp,
int result)
{
((Interp *) interp)->varFramePtr = (CallFrame *)data[0];
return result;
}
static int
TEOV_Exception(
ClientData data[],
Tcl_Interp *interp,
|
| ︙ | ︙ | |||
4525 4526 4527 4528 4529 4530 4531 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr;
const char *cmdString;
| | | | 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr;
const char *cmdString;
int cmdLen;
int objc = PTR2INT(data[0]);
Tcl_Obj **objv = (Tcl_Obj **)data[1];
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
/*
* If there was an error, a command string will be needed for the
* error log: get it out of the itemPtr. The details depend on the
* type.
*/
|
| ︙ | ︙ | |||
4589 4590 4591 4592 4593 4594 4595 |
* to hold both the handler prefix and all words of the command invokation
* itself.
*/
Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr,
&handlerObjc, &handlerObjv);
newObjc = objc + handlerObjc;
| | | 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 |
* to hold both the handler prefix and all words of the command invokation
* itself.
*/
Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr,
&handlerObjc, &handlerObjv);
newObjc = objc + handlerObjc;
newObjv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * newObjc);
/*
* Copy command prefix from unknown handler and add on the real command's
* full argument list. Note that we only use memcpy() once because we have
* to increment the reference count of all the handler arguments anyway.
*/
|
| ︙ | ︙ | |||
4650 4651 4652 4653 4654 4655 4656 |
TEOV_NotFoundCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
int objc = PTR2INT(data[0]);
| | | | 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 |
TEOV_NotFoundCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
int objc = PTR2INT(data[0]);
Tcl_Obj **objv = (Tcl_Obj **)data[1];
Namespace *savedNsPtr = (Namespace *)data[2];
int i;
if (savedNsPtr) {
iPtr->varFramePtr->nsPtr = savedNsPtr;
}
|
| ︙ | ︙ | |||
4681 4682 4683 4684 4685 4686 4687 |
Command **cmdPtrPtr,
Tcl_Obj *commandPtr,
int objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = *cmdPtrPtr;
| | | | 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 |
Command **cmdPtrPtr,
Tcl_Obj *commandPtr,
int objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = *cmdPtrPtr;
unsigned int newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
int length, traceCode = TCL_OK;
const char *command = TclGetStringFromObj(commandPtr, &length);
/*
* Call trace functions.
* Execute any command or execution traces. Note that we bump up the
* command's reference count for the duration of the calling of the
* traces so that the structure doesn't go away underneath our feet.
|
| ︙ | ︙ | |||
4731 4732 4733 4734 4735 4736 4737 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
int traceCode = TCL_OK;
int objc = PTR2INT(data[0]);
| | | | | | 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
int traceCode = TCL_OK;
int objc = PTR2INT(data[0]);
Tcl_Obj *commandPtr = (Tcl_Obj *)data[1];
Command *cmdPtr = (Command *)data[2];
Tcl_Obj **objv = (Tcl_Obj **)data[3];
int length;
const char *command = TclGetStringFromObj(commandPtr, &length);
if (!(cmdPtr->flags & CMD_IS_DELETED)) {
if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) {
traceCode = TclCheckExecutionTraces(interp, command, length,
cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv);
}
|
| ︙ | ︙ | |||
4817 4818 4819 4820 4821 4822 4823 |
int
Tcl_EvalTokensStandard(
Tcl_Interp *interp, /* Interpreter in which to lookup variables,
* execute nested commands, and report
* errors. */
Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to
* evaluate and concatenate. */
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 |
int
Tcl_EvalTokensStandard(
Tcl_Interp *interp, /* Interpreter in which to lookup variables,
* execute nested commands, and report
* errors. */
Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to
* evaluate and concatenate. */
int count) /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
{
return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1,
NULL, NULL);
}
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
*----------------------------------------------------------------------
*
* Tcl_EvalTokens --
*
* Given an array of tokens parsed from a Tcl command (e.g., the tokens
* that make up a word or the index for an array variable) this function
* evaluates the tokens and concatenates their values to form a single
* result value.
*
* Results:
* The return value is a pointer to a newly allocated Tcl_Obj containing
* the value of the array of tokens. The reference count of the returned
* object has been incremented. If an error occurs in evaluating the
* tokens then a NULL value is returned and an error message is left in
* interp's result.
*
* Side effects:
* A new object is allocated to hold the result.
*
*----------------------------------------------------------------------
*
* This uses a non-standard return convention; its use is now deprecated. It
* is a wrapper for the new function Tcl_EvalTokensStandard, and is not used
* in the core any longer. It is only kept for backward compatibility.
*/
Tcl_Obj *
Tcl_EvalTokens(
Tcl_Interp *interp, /* Interpreter in which to lookup variables,
* execute nested commands, and report
* errors. */
Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to
* evaluate and concatenate. */
int count) /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
{
Tcl_Obj *resPtr;
if (Tcl_EvalTokensStandard(interp, tokenPtr, count) != TCL_OK) {
return NULL;
}
resPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resPtr);
Tcl_ResetResult(interp);
return resPtr;
}
#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_EvalEx, TclEvalEx --
*
* This function evaluates a Tcl script without using the compiler or
|
| ︙ | ︙ | |||
4850 4851 4852 4853 4854 4855 4856 |
*/
int
Tcl_EvalEx(
Tcl_Interp *interp, /* Interpreter in which to evaluate the
* script. Also used for error reporting. */
const char *script, /* First character of script to evaluate. */
| | | | 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 |
*/
int
Tcl_EvalEx(
Tcl_Interp *interp, /* Interpreter in which to evaluate the
* script. Also used for error reporting. */
const char *script, /* First character of script to evaluate. */
int numBytes, /* Number of bytes in script. If < 0, the
* script consists of all bytes up to the
* first null character. */
int flags) /* Collection of OR-ed bits that control the
* evaluation of the script. Only
* TCL_EVAL_GLOBAL is currently supported. */
{
return TclEvalEx(interp, script, numBytes, flags, 1, NULL, script);
}
int
TclEvalEx(
Tcl_Interp *interp, /* Interpreter in which to evaluate the
* script. Also used for error reporting. */
const char *script, /* First character of script to evaluate. */
int numBytes, /* Number of bytes in script. If < 0, the
* script consists of all bytes up to the
* first NUL character. */
int flags, /* Collection of OR-ed bits that control the
* evaluation of the script. Only
* TCL_EVAL_GLOBAL is currently supported. */
int line, /* The line the script starts on. */
int *clNextOuter, /* Information about an outer context for */
|
| ︙ | ︙ | |||
4896 4897 4898 4899 4900 4901 4902 |
{
Interp *iPtr = (Interp *) interp;
const char *p, *next;
const unsigned int minObjs = 20;
Tcl_Obj **objv, **objvSpace;
int *expand, *lines, *lineSpace;
Tcl_Token *tokenPtr;
| | < | | | | | | | 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 5451 5452 5453 5454 5455 5456 5457 5458 5459 5460 5461 5462 5463 5464 5465 5466 5467 |
{
Interp *iPtr = (Interp *) interp;
const char *p, *next;
const unsigned int minObjs = 20;
Tcl_Obj **objv, **objvSpace;
int *expand, *lines, *lineSpace;
Tcl_Token *tokenPtr;
int commandLength, bytesLeft, expandRequested, code = TCL_OK;
CallFrame *savedVarFramePtr;/* Saves old copy of iPtr->varFramePtr in case
* TCL_EVAL_GLOBAL was set. */
int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS);
int gotParse = 0;
unsigned int i, objectsUsed = 0;
/* These variables keep track of how much
* state has been allocated while evaluating
* the script, so that it can be freed
* properly if an error occurs. */
Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
CmdFrame *eeFramePtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
Tcl_Obj **stackObjArray = (Tcl_Obj **)
TclStackAlloc(interp, minObjs * sizeof(Tcl_Obj *));
int *expandStack = (int *)TclStackAlloc(interp, minObjs * sizeof(int));
int *linesStack = (int *)TclStackAlloc(interp, minObjs * sizeof(int));
/* TIP #280 Structures for tracking of command
* locations. */
int *clNext = NULL; /* Pointer for the tracking of invisible
* continuation lines. Initialized only if the
* caller gave us a table of locations to
* track, via scriptCLLocPtr. It always refers
* to the table entry holding the location of
* the next invisible continuation line to
* look for, while parsing the script. */
if (iPtr->scriptCLLocPtr) {
if (clNextOuter) {
clNext = clNextOuter;
} else {
clNext = &iPtr->scriptCLLocPtr->loc[0];
}
}
if (numBytes < 0) {
numBytes = strlen(script);
}
Tcl_ResetResult(interp);
savedVarFramePtr = iPtr->varFramePtr;
if (flags & TCL_EVAL_GLOBAL) {
iPtr->varFramePtr = iPtr->rootFramePtr;
|
| ︙ | ︙ | |||
5048 5049 5050 5051 5052 5053 5054 |
unsigned int numWords = parsePtr->numWords;
/*
* Generate an array of objects for the words of the command.
*/
if (numWords > minObjs) {
| | | | | 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 |
unsigned int numWords = parsePtr->numWords;
/*
* Generate an array of objects for the words of the command.
*/
if (numWords > minObjs) {
expand = (int *)ckalloc(numWords * sizeof(int));
objvSpace = (Tcl_Obj **)ckalloc(numWords * sizeof(Tcl_Obj *));
lineSpace = (int *)ckalloc(numWords * sizeof(int));
}
expandRequested = 0;
objv = objvSpace;
lines = lineSpace;
iPtr->cmdFramePtr = eeFramePtr->nextPtr;
for (objectsUsed = 0, tokenPtr = parsePtr->tokenPtr;
|
| ︙ | ︙ | |||
5136 5137 5138 5139 5140 5141 5142 |
Tcl_Obj **copy = objvSpace;
int *lcopy = lineSpace;
int wordIdx = numWords;
int objIdx = objectsNeeded - 1;
if ((numWords > minObjs) || (objectsNeeded > minObjs)) {
objv = objvSpace =
| | | | 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 |
Tcl_Obj **copy = objvSpace;
int *lcopy = lineSpace;
int wordIdx = numWords;
int objIdx = objectsNeeded - 1;
if ((numWords > minObjs) || (objectsNeeded > minObjs)) {
objv = objvSpace =
(Tcl_Obj **)ckalloc(objectsNeeded * sizeof(Tcl_Obj *));
lines = lineSpace = (int *)ckalloc(objectsNeeded * sizeof(int));
}
objectsUsed = 0;
while (wordIdx--) {
if (expand[wordIdx]) {
int numElements;
Tcl_Obj **elements, *temp = copy[wordIdx];
|
| ︙ | ︙ | |||
5164 5165 5166 5167 5168 5169 5170 |
objv[objIdx--] = copy[wordIdx];
objectsUsed++;
}
}
objv += objIdx+1;
if (copy != stackObjArray) {
| | | | 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 |
objv[objIdx--] = copy[wordIdx];
objectsUsed++;
}
}
objv += objIdx+1;
if (copy != stackObjArray) {
ckfree(copy);
}
if (lcopy != linesStack) {
ckfree(lcopy);
}
}
/*
* Execute the command and free the objects for its words.
*
* TIP #280: Remember the command itself for 'info frame'. We
|
| ︙ | ︙ | |||
5212 5213 5214 5215 5216 5217 5218 |
goto error;
}
for (i = 0; i < objectsUsed; i++) {
Tcl_DecrRefCount(objv[i]);
}
objectsUsed = 0;
if (objvSpace != stackObjArray) {
| | | | | 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 |
goto error;
}
for (i = 0; i < objectsUsed; i++) {
Tcl_DecrRefCount(objv[i]);
}
objectsUsed = 0;
if (objvSpace != stackObjArray) {
ckfree(objvSpace);
objvSpace = stackObjArray;
ckfree(lineSpace);
lineSpace = linesStack;
}
/*
* Free expand separately since objvSpace could have been
* reallocated above.
*/
if (expand != expandStack) {
ckfree(expand);
expand = expandStack;
}
}
/*
* Advance to the next command in the script.
*
|
| ︙ | ︙ | |||
5290 5291 5292 5293 5294 5295 5296 |
for (i = 0; i < objectsUsed; i++) {
Tcl_DecrRefCount(objv[i]);
}
if (gotParse) {
Tcl_FreeParse(parsePtr);
}
if (objvSpace != stackObjArray) {
| | | | | 5812 5813 5814 5815 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 |
for (i = 0; i < objectsUsed; i++) {
Tcl_DecrRefCount(objv[i]);
}
if (gotParse) {
Tcl_FreeParse(parsePtr);
}
if (objvSpace != stackObjArray) {
ckfree(objvSpace);
ckfree(lineSpace);
}
if (expand != expandStack) {
ckfree(expand);
}
iPtr->varFramePtr = savedVarFramePtr;
cleanup_return:
/*
* TIP #280. Release the local CmdFrame, and its contents.
*/
|
| ︙ | ︙ | |||
5340 5341 5342 5343 5344 5345 5346 |
void
TclAdvanceLines(
int *line,
const char *start,
const char *end)
{
| | | 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 |
void
TclAdvanceLines(
int *line,
const char *start,
const char *end)
{
const char *p;
for (p = start; p < end; p++) {
if (*p == '\n') {
(*line)++;
}
}
}
|
| ︙ | ︙ | |||
5435 5436 5437 5438 5439 5440 5441 |
TclArgumentEnter(
Tcl_Interp *interp,
Tcl_Obj **objv,
int objc,
CmdFrame *cfPtr)
{
Interp *iPtr = (Interp *) interp;
| | | | | | | 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 |
TclArgumentEnter(
Tcl_Interp *interp,
Tcl_Obj **objv,
int objc,
CmdFrame *cfPtr)
{
Interp *iPtr = (Interp *) interp;
int isNew, i;
Tcl_HashEntry *hPtr;
CFWord *cfwPtr;
for (i = 1; i < objc; i++) {
/*
* Ignore argument words without line information (= dynamic). If they
* are variables they may have location information associated with
* that, either through globally recorded 'set' invokations, or
* literals in bytecode. Eitehr way there is no need to record
* something here.
*/
if (cfPtr->line[i] < 0) {
continue;
}
hPtr = Tcl_CreateHashEntry(iPtr->lineLAPtr, objv[i], &isNew);
if (isNew) {
/*
* The word is not on the stack yet, remember the current location
* and initialize references.
*/
cfwPtr = (CFWord *)ckalloc(sizeof(CFWord));
cfwPtr->framePtr = cfPtr;
cfwPtr->word = i;
cfwPtr->refCount = 1;
Tcl_SetHashValue(hPtr, cfwPtr);
} else {
/*
* The word is already on the stack, its current location is not
* relevant. Just remember the reference to prevent early removal.
*/
cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr);
cfwPtr->refCount++;
}
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
5512 5513 5514 5515 5516 5517 5518 |
CFWord *cfwPtr;
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) objv[i]);
if (!hPtr) {
continue;
}
| | | | 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 |
CFWord *cfwPtr;
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) objv[i]);
if (!hPtr) {
continue;
}
cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr);
if (cfwPtr->refCount-- > 1) {
continue;
}
ckfree(cfwPtr);
Tcl_DeleteHashEntry(hPtr);
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
5551 5552 5553 5554 5555 5556 5557 |
TclArgumentBCEnter(
Tcl_Interp *interp,
Tcl_Obj *objv[],
int objc,
void *codePtr,
CmdFrame *cfPtr,
int cmd,
| | | | 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 |
TclArgumentBCEnter(
Tcl_Interp *interp,
Tcl_Obj *objv[],
int objc,
void *codePtr,
CmdFrame *cfPtr,
int cmd,
int pc)
{
ExtCmdLoc *eclPtr;
int word;
ECL *ePtr;
CFWordBC *lastPtr = NULL;
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hePtr =
Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr);
if (!hePtr) {
return;
}
eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr);
ePtr = &eclPtr->loc[cmd];
/*
* ePtr->nline is the number of words originally parsed.
*
* objc is the number of elements getting invoked.
*
|
| ︙ | ︙ | |||
5597 5598 5599 5600 5601 5602 5603 |
*
* Item (2) is why we can use objv to get the literals, and do not
* have to save them at compile time.
*/
for (word = 1; word < objc; word++) {
if (ePtr->line[word] >= 0) {
| | | | | | | 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 |
*
* Item (2) is why we can use objv to get the literals, and do not
* have to save them at compile time.
*/
for (word = 1; word < objc; word++) {
if (ePtr->line[word] >= 0) {
int isNew;
Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr,
objv[word], &isNew);
CFWordBC *cfwPtr = (CFWordBC *)ckalloc(sizeof(CFWordBC));
cfwPtr->framePtr = cfPtr;
cfwPtr->obj = objv[word];
cfwPtr->pc = pc;
cfwPtr->word = word;
cfwPtr->nextPtr = lastPtr;
lastPtr = cfwPtr;
if (isNew) {
/*
* The word is not on the stack yet, remember the current
* location and initialize references.
*/
cfwPtr->prevPtr = NULL;
} else {
/*
* The object is already on the stack, however it may have
* a different location now (literal sharing may map
* multiple location to a single Tcl_Obj*. Save the old
* information in the new structure.
*/
cfwPtr->prevPtr = (CFWordBC *)Tcl_GetHashValue(hPtr);
}
Tcl_SetHashValue(hPtr, cfwPtr);
}
} /* for */
cfPtr->litarg = lastPtr;
|
| ︙ | ︙ | |||
5666 5667 5668 5669 5670 5671 5672 |
Interp *iPtr = (Interp *) interp;
CFWordBC *cfwPtr = (CFWordBC *) cfPtr->litarg;
while (cfwPtr) {
CFWordBC *nextPtr = cfwPtr->nextPtr;
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) cfwPtr->obj);
| | | | 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 |
Interp *iPtr = (Interp *) interp;
CFWordBC *cfwPtr = (CFWordBC *) cfPtr->litarg;
while (cfwPtr) {
CFWordBC *nextPtr = cfwPtr->nextPtr;
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) cfwPtr->obj);
CFWordBC *xPtr = (CFWordBC *)Tcl_GetHashValue(hPtr);
if (xPtr != cfwPtr) {
Tcl_Panic("TclArgumentBC Enter/Release Mismatch");
}
if (cfwPtr->prevPtr) {
Tcl_SetHashValue(hPtr, cfwPtr->prevPtr);
} else {
Tcl_DeleteHashEntry(hPtr);
}
ckfree(cfwPtr);
cfwPtr = nextPtr;
}
cfPtr->litarg = NULL;
}
/*
|
| ︙ | ︙ | |||
5732 5733 5734 5735 5736 5737 5738 |
/*
* First look for location information recorded in the argument
* stack. That is nearest.
*/
hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) obj);
if (hPtr) {
| | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 6254 6255 6256 6257 6258 6259 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 6351 6352 6353 6354 6355 6356 6357 6358 6359 6360 6361 6362 6363 6364 6365 6366 6367 6368 6369 |
/*
* First look for location information recorded in the argument
* stack. That is nearest.
*/
hPtr = Tcl_FindHashEntry(iPtr->lineLAPtr, (char *) obj);
if (hPtr) {
CFWord *cfwPtr = (CFWord *)Tcl_GetHashValue(hPtr);
*wordPtr = cfwPtr->word;
*cfPtrPtr = cfwPtr->framePtr;
return;
}
/*
* Check if the Tcl_Obj has location information as a bytecode literal, in
* that stack.
*/
hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) obj);
if (hPtr) {
CFWordBC *cfwPtr = (CFWordBC *)Tcl_GetHashValue(hPtr);
framePtr = cfwPtr->framePtr;
framePtr->data.tebc.pc = (char *) (((ByteCode *)
framePtr->data.tebc.codePtr)->codeStart + cfwPtr->pc);
*cfPtrPtr = cfwPtr->framePtr;
*wordPtr = cfwPtr->word;
return;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_Eval --
*
* Execute a Tcl command in a string. This function executes the script
* directly, rather than compiling it to bytecodes. Before the arrival of
* the bytecode compiler in Tcl 8.0 Tcl_Eval was the main function used
* for executing Tcl commands, but nowadays it isn't used much.
*
* Results:
* The return value is one of the return codes defined in tcl.h (such as
* TCL_OK), and interp's result contains a value to supplement the return
* code. The value of the result will persist only until the next call to
* Tcl_Eval or Tcl_EvalObj: you must copy it or lose it!
*
* Side effects:
* Can be almost arbitrary, depending on the commands in the script.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
#undef Tcl_Eval
int
Tcl_Eval(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* previous call to Tcl_CreateInterp). */
const char *script) /* Pointer to TCL command to execute. */
{
int code = Tcl_EvalEx(interp, script, -1, 0);
/*
* For backwards compatibility with old C code that predates the object
* system in Tcl 8.0, we have to mirror the object result back into the
* string result (some callers may expect it there).
*/
(void) Tcl_GetStringResult(interp);
return code;
}
/*
*----------------------------------------------------------------------
*
* Tcl_EvalObj, Tcl_GlobalEvalObj --
*
* These functions are deprecated but we keep them around for backwards
* compatibility reasons.
*
* Results:
* See the functions they call.
*
* Side effects:
* See the functions they call.
*
*----------------------------------------------------------------------
*/
#undef Tcl_EvalObj
int
Tcl_EvalObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
return Tcl_EvalObjEx(interp, objPtr, 0);
}
#undef Tcl_GlobalEvalObj
int
Tcl_GlobalEvalObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_EvalObjEx, TclEvalObjEx --
*
* Execute Tcl commands stored in a Tcl object. These commands are
* compiled into bytecodes if necessary, unless TCL_EVAL_DIRECT is
|
| ︙ | ︙ | |||
5789 5790 5791 5792 5793 5794 5795 |
*----------------------------------------------------------------------
*/
int
Tcl_EvalObjEx(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* a previous call to Tcl_CreateInterp). */
| | | | | 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 |
*----------------------------------------------------------------------
*/
int
Tcl_EvalObjEx(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* a previous call to Tcl_CreateInterp). */
Tcl_Obj *objPtr, /* Pointer to object containing commands to
* execute. */
int flags) /* Collection of OR-ed bits that control the
* evaluation of the script. Supported values
* are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */
{
return TclEvalObjEx(interp, objPtr, flags, NULL, 0);
}
int
TclEvalObjEx(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* a previous call to Tcl_CreateInterp). */
Tcl_Obj *objPtr, /* Pointer to object containing commands to
* execute. */
int flags, /* Collection of OR-ed bits that control the
* evaluation of the script. Supported values
* are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */
const CmdFrame *invoker, /* Frame of the command doing the eval. */
int word) /* Index of the word which is in objPtr. */
{
int result = TCL_OK;
NRE_callback *rootPtr = TOP_CB(interp);
result = TclNREvalObjEx(interp, objPtr, flags, invoker, word);
return TclNRRunCallbacks(interp, result, rootPtr);
}
int
TclNREvalObjEx(
Tcl_Interp *interp, /* Token for command interpreter (returned by
* a previous call to Tcl_CreateInterp). */
Tcl_Obj *objPtr, /* Pointer to object containing commands to
* execute. */
int flags, /* Collection of OR-ed bits that control the
* evaluation of the script. Supported values
* are TCL_EVAL_GLOBAL and TCL_EVAL_DIRECT. */
const CmdFrame *invoker, /* Frame of the command doing the eval. */
int word) /* Index of the word which is in objPtr. */
{
|
| ︙ | ︙ | |||
5885 5886 5887 5888 5889 5890 5891 | * and TclInitCompileEnv), are special-cased to use the proper * line number directly instead of accessing the 'line' array. * * Note that we use (word==INTMIN) to signal that no command frame * should be pushed, as needed by alias and ensemble redirections. */ | | | 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 | * and TclInitCompileEnv), are special-cased to use the proper * line number directly instead of accessing the 'line' array. * * Note that we use (word==INTMIN) to signal that no command frame * should be pushed, as needed by alias and ensemble redirections. */ eoFramePtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame)); eoFramePtr->nline = 0; eoFramePtr->line = NULL; eoFramePtr->type = TCL_LOCATION_EVAL; eoFramePtr->level = (iPtr->cmdFramePtr == NULL? 1 : iPtr->cmdFramePtr->level + 1); eoFramePtr->framePtr = iPtr->framePtr; |
| ︙ | ︙ | |||
5950 5951 5952 5953 5954 5955 5956 | /* * We're not supposed to use the compiler or byte-code * interpreter. Let Tcl_EvalEx evaluate the command directly (and * probably more slowly). */ const char *script; | | | 6549 6550 6551 6552 6553 6554 6555 6556 6557 6558 6559 6560 6561 6562 6563 | /* * We're not supposed to use the compiler or byte-code * interpreter. Let Tcl_EvalEx evaluate the command directly (and * probably more slowly). */ const char *script; int numSrcBytes; /* * Now we check if we have data about invisible continuation lines for * the script, and make it available to the direct script parser and * evaluator we are about to call, if so. * * It may be possible that the script Tcl_Obj* can be free'd while the |
| ︙ | ︙ | |||
5994 5995 5996 5997 5998 5999 6000 |
static int
TEOEx_ByteCodeCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | | | 6593 6594 6595 6596 6597 6598 6599 6600 6601 6602 6603 6604 6605 6606 6607 6608 6609 6610 6611 6612 6613 6614 6615 6616 6617 |
static int
TEOEx_ByteCodeCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
CallFrame *savedVarFramePtr = (CallFrame *)data[0];
Tcl_Obj *objPtr = (Tcl_Obj *)data[1];
int allowExceptions = PTR2INT(data[2]);
if (iPtr->numLevels == 0) {
if (result == TCL_RETURN) {
result = TclUpdateReturnInfo(iPtr);
}
if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) {
const char *script;
int numSrcBytes;
ProcessUnexpectedResult(interp, result);
result = TCL_ERROR;
script = TclGetStringFromObj(objPtr, &numSrcBytes);
Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
}
|
| ︙ | ︙ | |||
6040 6041 6042 6043 6044 6045 6046 |
static int
TEOEx_ListCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | | | 6639 6640 6641 6642 6643 6644 6645 6646 6647 6648 6649 6650 6651 6652 6653 6654 6655 |
static int
TEOEx_ListCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr = (Tcl_Obj *)data[0];
CmdFrame *eoFramePtr = (CmdFrame *)data[1];
Tcl_Obj *objPtr = (Tcl_Obj *)data[2];
/*
* Remove the cmdFrame
*/
if (eoFramePtr) {
iPtr->cmdFramePtr = eoFramePtr->nextPtr;
|
| ︙ | ︙ | |||
6129 6130 6131 6132 6133 6134 6135 |
int
Tcl_ExprLong(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
const char *exprstring, /* Expression to evaluate. */
long *ptr) /* Where to store result. */
{
| | > > > | > > > | 6728 6729 6730 6731 6732 6733 6734 6735 6736 6737 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 6753 6754 6755 6756 6757 6758 6759 6760 6761 6762 6763 6764 6765 6766 6767 6768 6769 6770 6771 6772 6773 6774 6775 6776 6777 6778 6779 6780 6781 6782 6783 6784 6785 6786 |
int
Tcl_ExprLong(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
const char *exprstring, /* Expression to evaluate. */
long *ptr) /* Where to store result. */
{
Tcl_Obj *exprPtr;
int result = TCL_OK;
if (*exprstring == '\0') {
/*
* Legacy compatibility - return 0 for the zero-length string.
*/
*ptr = 0;
} else {
exprPtr = Tcl_NewStringObj(exprstring, -1);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprLongObj(interp, exprPtr, ptr);
Tcl_DecrRefCount(exprPtr);
if (result != TCL_OK) {
(void) Tcl_GetStringResult(interp);
}
}
return result;
}
int
Tcl_ExprDouble(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
const char *exprstring, /* Expression to evaluate. */
double *ptr) /* Where to store result. */
{
Tcl_Obj *exprPtr;
int result = TCL_OK;
if (*exprstring == '\0') {
/*
* Legacy compatibility - return 0 for the zero-length string.
*/
*ptr = 0.0;
} else {
exprPtr = Tcl_NewStringObj(exprstring, -1);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprDoubleObj(interp, exprPtr, ptr);
Tcl_DecrRefCount(exprPtr);
/* Discard the expression object. */
if (result != TCL_OK) {
(void) Tcl_GetStringResult(interp);
}
}
return result;
}
int
Tcl_ExprBoolean(
Tcl_Interp *interp, /* Context in which to evaluate the
|
| ︙ | ︙ | |||
6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 |
} else {
int result;
Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, -1);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprBooleanObj(interp, exprPtr, ptr);
Tcl_DecrRefCount(exprPtr);
return result;
}
}
/*
*--------------------------------------------------------------
*
| > > > > > > > > | 6798 6799 6800 6801 6802 6803 6804 6805 6806 6807 6808 6809 6810 6811 6812 6813 6814 6815 6816 6817 6818 6819 |
} else {
int result;
Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, -1);
Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprBooleanObj(interp, exprPtr, ptr);
Tcl_DecrRefCount(exprPtr);
if (result != TCL_OK) {
/*
* Move the interpreter's object result to the string result, then
* reset the object result.
*/
(void) Tcl_GetStringResult(interp);
}
return result;
}
}
/*
*--------------------------------------------------------------
*
|
| ︙ | ︙ | |||
6222 6223 6224 6225 6226 6227 6228 |
*--------------------------------------------------------------
*/
int
Tcl_ExprLongObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
| | | 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 6846 6847 6848 6849 |
*--------------------------------------------------------------
*/
int
Tcl_ExprLongObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
Tcl_Obj *objPtr, /* Expression to evaluate. */
long *ptr) /* Where to store long result. */
{
Tcl_Obj *resultPtr;
int result, type;
double d;
ClientData internalPtr;
|
| ︙ | ︙ | |||
6249 6250 6251 6252 6253 6254 6255 |
d = *((const double *) internalPtr);
Tcl_DecrRefCount(resultPtr);
if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) {
return TCL_ERROR;
}
resultPtr = Tcl_NewBignumObj(&big);
| < > | | 6862 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 6886 6887 6888 6889 6890 6891 6892 6893 6894 6895 6896 |
d = *((const double *) internalPtr);
Tcl_DecrRefCount(resultPtr);
if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) {
return TCL_ERROR;
}
resultPtr = Tcl_NewBignumObj(&big);
}
/* FALLTHRU */
case TCL_NUMBER_INT:
case TCL_NUMBER_BIG:
result = TclGetLongFromObj(interp, resultPtr, ptr);
break;
case TCL_NUMBER_NAN:
Tcl_GetDoubleFromObj(interp, resultPtr, &d);
result = TCL_ERROR;
}
Tcl_DecrRefCount(resultPtr);/* Discard the result object. */
return result;
}
int
Tcl_ExprDoubleObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
Tcl_Obj *objPtr, /* Expression to evaluate. */
double *ptr) /* Where to store double result. */
{
Tcl_Obj *resultPtr;
int result, type;
ClientData internalPtr;
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
|
| ︙ | ︙ | |||
6305 6306 6307 6308 6309 6310 6311 |
return result;
}
int
Tcl_ExprBooleanObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
| | | 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 6928 6929 6930 6931 6932 |
return result;
}
int
Tcl_ExprBooleanObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
Tcl_Obj *objPtr, /* Expression to evaluate. */
int *ptr) /* Where to store 0/1 result. */
{
Tcl_Obj *resultPtr;
int result;
result = Tcl_ExprObj(interp, objPtr, &resultPtr);
if (result == TCL_OK) {
|
| ︙ | ︙ | |||
6412 6413 6414 6415 6416 6417 6418 |
Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN");
}
return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv);
}
int
TclNRInvoke(
| | | | | > | 7025 7026 7027 7028 7029 7030 7031 7032 7033 7034 7035 7036 7037 7038 7039 7040 7041 7042 7043 7044 7045 7046 7047 7048 7049 7050 7051 7052 7053 7054 7055 7056 7057 7058 7059 7060 7061 7062 7063 7064 7065 7066 7067 7068 7069 7070 7071 7072 7073 7074 7075 7076 7077 7078 7079 7080 7081 7082 7083 7084 7085 7086 7087 |
Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN");
}
return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv);
}
int
TclNRInvoke(
TCL_UNUSED(ClientData),
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]. */
Tcl_HashEntry *hPtr = NULL;
Command *cmdPtr;
cmdName = TclGetString(objv[0]);
hTblPtr = iPtr->hiddenCmdTablePtr;
if (hTblPtr != NULL) {
hPtr = Tcl_FindHashEntry(hTblPtr, cmdName);
}
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid hidden command name \"%s\"", cmdName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "HIDDENTOKEN", cmdName,
NULL);
return TCL_ERROR;
}
cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
/*
* Avoid the exception-handling brain damage when numLevels == 0
*/
iPtr->numLevels++;
Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL);
/*
* Normal command resolution of objv[0] isn't going to find cmdPtr.
* That's the whole point of **hidden** commands. So tell the Eval core
* machinery not to even try (and risk finding something wrong).
*/
return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr);
}
static int
NRPostInvoke(
TCL_UNUSED(ClientData *),
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *)interp;
iPtr->numLevels--;
return result;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
6509 6510 6511 6512 6513 6514 6515 6516 6517 6518 6519 6520 6521 6522 |
code = Tcl_ExprObj(interp, exprObj, &resultPtr);
Tcl_DecrRefCount(exprObj);
if (code == TCL_OK) {
Tcl_SetObjResult(interp, resultPtr);
Tcl_DecrRefCount(resultPtr);
}
}
return code;
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendObjToErrorInfo --
| > > > > > > | 7123 7124 7125 7126 7127 7128 7129 7130 7131 7132 7133 7134 7135 7136 7137 7138 7139 7140 7141 7142 |
code = Tcl_ExprObj(interp, exprObj, &resultPtr);
Tcl_DecrRefCount(exprObj);
if (code == TCL_OK) {
Tcl_SetObjResult(interp, resultPtr);
Tcl_DecrRefCount(resultPtr);
}
}
/*
* Force the string rep of the interp result.
*/
(void) Tcl_GetStringResult(interp);
return code;
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendObjToErrorInfo --
|
| ︙ | ︙ | |||
6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 6543 |
* The value of the Tcl_obj is appended to the errorInfo field. If we are
* just starting to log an error, errorInfo is initialized from the error
* message in the interpreter's result.
*
*----------------------------------------------------------------------
*/
void
Tcl_AppendObjToErrorInfo(
Tcl_Interp *interp, /* Interpreter to which error information
* pertains. */
Tcl_Obj *objPtr) /* Message to record. */
{
| > < | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < | | | | | | | | < < > < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 7151 7152 7153 7154 7155 7156 7157 7158 7159 7160 7161 7162 7163 7164 7165 7166 7167 7168 7169 7170 7171 7172 7173 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 7187 7188 7189 7190 7191 7192 7193 7194 7195 7196 7197 7198 7199 7200 7201 7202 7203 7204 7205 7206 7207 7208 7209 7210 7211 7212 7213 7214 7215 7216 7217 7218 7219 7220 7221 7222 7223 7224 7225 7226 7227 7228 7229 7230 7231 7232 7233 7234 7235 7236 7237 7238 7239 7240 7241 7242 7243 7244 7245 7246 7247 7248 7249 7250 7251 7252 7253 7254 7255 7256 7257 7258 7259 7260 7261 7262 7263 7264 7265 7266 7267 7268 7269 7270 7271 7272 7273 7274 7275 7276 7277 7278 7279 7280 7281 7282 7283 7284 7285 7286 7287 7288 7289 7290 7291 7292 7293 7294 7295 7296 7297 7298 7299 7300 7301 7302 7303 7304 7305 7306 7307 7308 7309 7310 7311 7312 7313 7314 7315 7316 7317 7318 7319 7320 7321 7322 7323 7324 7325 7326 7327 7328 7329 7330 7331 7332 7333 7334 7335 7336 7337 7338 7339 7340 7341 7342 7343 7344 7345 7346 7347 7348 7349 7350 7351 7352 7353 7354 7355 7356 7357 7358 7359 7360 7361 7362 7363 7364 7365 7366 7367 7368 7369 7370 7371 7372 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 7387 7388 7389 7390 7391 7392 7393 7394 7395 7396 7397 7398 7399 7400 |
* The value of the Tcl_obj is appended to the errorInfo field. If we are
* just starting to log an error, errorInfo is initialized from the error
* message in the interpreter's result.
*
*----------------------------------------------------------------------
*/
#undef Tcl_AddObjErrorInfo
void
Tcl_AppendObjToErrorInfo(
Tcl_Interp *interp, /* Interpreter to which error information
* pertains. */
Tcl_Obj *objPtr) /* Message to record. */
{
const char *message = TclGetString(objPtr);
Tcl_IncrRefCount(objPtr);
Tcl_AddObjErrorInfo(interp, message, objPtr->length);
Tcl_DecrRefCount(objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_AddErrorInfo --
*
* Add information to the errorInfo field that describes the current
* error.
*
* Results:
* None.
*
* Side effects:
* The contents of message are appended to the errorInfo field. If we are
* just starting to log an error, errorInfo is initialized from the error
* message in the interpreter's result.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
#undef Tcl_AddErrorInfo
void
Tcl_AddErrorInfo(
Tcl_Interp *interp, /* Interpreter to which error information
* pertains. */
const char *message) /* Message to record. */
{
Tcl_AddObjErrorInfo(interp, message, -1);
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_AddObjErrorInfo --
*
* Add information to the errorInfo field that describes the current
* error. This routine differs from Tcl_AddErrorInfo by taking a byte
* pointer and length.
*
* Results:
* None.
*
* Side effects:
* "length" bytes from "message" are appended to the errorInfo field. If
* "length" is negative, use bytes up to the first NULL byte. If we are
* just starting to log an error, errorInfo is initialized from the error
* message in the interpreter's result.
*
*----------------------------------------------------------------------
*/
void
Tcl_AddObjErrorInfo(
Tcl_Interp *interp, /* Interpreter to which error information
* pertains. */
const char *message, /* Points to the first byte of an array of
* bytes of the message. */
int length) /* The number of bytes in the message. If < 0,
* then append all bytes up to a NULL byte. */
{
Interp *iPtr = (Interp *) interp;
/*
* If we are just starting to log an error, errorInfo is initialized from
* the error message in the interpreter's result.
*/
iPtr->flags |= ERR_LEGACY_COPY;
if (iPtr->errorInfo == NULL) {
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
if (*(iPtr->result) != 0) {
/*
* The interp's string result is set, apparently by some extension
* making a deprecated direct write to it. That extension may
* expect interp->result to continue to be set, so we'll take
* special pains to avoid clearing it, until we drop support for
* interp->result completely.
*/
iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1);
} else
#endif /* !defined(TCL_NO_DEPRECATED) */
iPtr->errorInfo = iPtr->objResultPtr;
Tcl_IncrRefCount(iPtr->errorInfo);
if (!iPtr->errorCode) {
Tcl_SetErrorCode(interp, "NONE", NULL);
}
}
/*
* Now append "message" to the end of errorInfo.
*/
if (length != 0) {
if (Tcl_IsShared(iPtr->errorInfo)) {
Tcl_DecrRefCount(iPtr->errorInfo);
iPtr->errorInfo = Tcl_DuplicateObj(iPtr->errorInfo);
Tcl_IncrRefCount(iPtr->errorInfo);
}
Tcl_AppendToObj(iPtr->errorInfo, message, length);
}
}
/*
*---------------------------------------------------------------------------
*
* Tcl_VarEvalVA --
*
* Given a variable number of string arguments, concatenate them all
* together and execute the result as a Tcl command.
*
* Results:
* A standard Tcl return result. An error message or other result may be
* left in the interp's result.
*
* Side effects:
* Depends on what was done by the command.
*
*---------------------------------------------------------------------------
*/
int
Tcl_VarEvalVA(
Tcl_Interp *interp, /* Interpreter in which to evaluate command */
va_list argList) /* Variable argument list. */
{
Tcl_DString buf;
char *string;
int result;
/*
* Copy the strings one after the other into a single larger string. Use
* stack-allocated space for small commands, but if the command gets too
* large than call ckalloc to create the space.
*/
Tcl_DStringInit(&buf);
while (1) {
string = va_arg(argList, char *);
if (string == NULL) {
break;
}
Tcl_DStringAppend(&buf, string, -1);
}
result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0);
Tcl_DStringFree(&buf);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_VarEval --
*
* Given a variable number of string arguments, concatenate them all
* together and execute the result as a Tcl command.
*
* Results:
* A standard Tcl return result. An error message or other result may be
* left in interp->result.
*
* Side effects:
* Depends on what was done by the command.
*
*----------------------------------------------------------------------
*/
int
Tcl_VarEval(
Tcl_Interp *interp,
...)
{
va_list argList;
int result;
va_start(argList, interp);
result = Tcl_VarEvalVA(interp, argList);
va_end(argList);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GlobalEval --
*
* Evaluate a command at global level in an interpreter.
*
* Results:
* A standard Tcl result is returned, and the interp's result is modified
* accordingly.
*
* Side effects:
* The command string is executed in interp, and the execution is carried
* out in the variable context of global level (no functions active),
* just as if an "uplevel #0" command were being executed.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
#undef Tcl_GlobalEval
int
Tcl_GlobalEval(
Tcl_Interp *interp, /* Interpreter in which to evaluate
* command. */
const char *command) /* Command to evaluate. */
{
Interp *iPtr = (Interp *) interp;
int result;
CallFrame *savedVarFramePtr;
savedVarFramePtr = iPtr->varFramePtr;
iPtr->varFramePtr = iPtr->rootFramePtr;
result = Tcl_EvalEx(interp, command, -1, 0);
iPtr->varFramePtr = savedVarFramePtr;
return result;
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_SetRecursionLimit --
*
* Set the maximum number of recursive calls that may be active for an
* interpreter at once.
|
| ︙ | ︙ | |||
6741 6742 6743 6744 6745 6746 6747 | * None. * *---------------------------------------------------------------------- */ static int ExprCeilFunc( | | | 7507 7508 7509 7510 7511 7512 7513 7514 7515 7516 7517 7518 7519 7520 7521 |
* None.
*
*----------------------------------------------------------------------
*/
static int
ExprCeilFunc(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
6781 6782 6783 6784 6785 6786 6787 |
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(ceil(d)));
}
return TCL_OK;
}
static int
ExprFloorFunc(
| | | 7547 7548 7549 7550 7551 7552 7553 7554 7555 7556 7557 7558 7559 7560 7561 |
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(ceil(d)));
}
return TCL_OK;
}
static int
ExprFloorFunc(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
6821 6822 6823 6824 6825 6826 6827 |
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(floor(d)));
}
return TCL_OK;
}
static int
ExprIsqrtFunc(
| | | 7587 7588 7589 7590 7591 7592 7593 7594 7595 7596 7597 7598 7599 7600 7601 |
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(floor(d)));
}
return TCL_OK;
}
static int
ExprIsqrtFunc(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
6875 6876 6877 6878 6879 6880 6881 |
}
}
break;
case TCL_NUMBER_BIG:
if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) {
return TCL_ERROR;
}
| | | 7641 7642 7643 7644 7645 7646 7647 7648 7649 7650 7651 7652 7653 7654 7655 |
}
}
break;
case TCL_NUMBER_BIG:
if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) {
return TCL_ERROR;
}
if (mp_isneg(&big)) {
mp_clear(&big);
goto negarg;
}
break;
default:
if (TclGetWideIntFromObj(interp, objv[1], &w) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
6903 6904 6905 6906 6907 6908 6909 6910 |
break;
}
if (exact) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) sqrt(d)));
} else {
mp_int root;
| > | > | > > > > | | 7669 7670 7671 7672 7673 7674 7675 7676 7677 7678 7679 7680 7681 7682 7683 7684 7685 7686 7687 7688 7689 7690 7691 7692 7693 7694 7695 7696 7697 7698 7699 7700 7701 7702 7703 7704 7705 7706 7707 |
break;
}
if (exact) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt) sqrt(d)));
} else {
mp_int root;
mp_err err;
err = mp_init(&root);
if (err == MP_OKAY) {
err = mp_sqrt(&big, &root);
}
mp_clear(&big);
if (err != MP_OKAY) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&root));
}
return TCL_OK;
negarg:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"square root of negative argument", -1));
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"domain error: argument not in valid range", NULL);
return TCL_ERROR;
}
static int
ExprSqrtFunc(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
6952 6953 6954 6955 6956 6957 6958 6959 |
#endif
if (code != TCL_OK) {
return TCL_ERROR;
}
if ((d >= 0.0) && TclIsInfinite(d)
&& (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK)) {
mp_int root;
| > | > | > > > > > | 7724 7725 7726 7727 7728 7729 7730 7731 7732 7733 7734 7735 7736 7737 7738 7739 7740 7741 7742 7743 7744 7745 7746 7747 7748 |
#endif
if (code != TCL_OK) {
return TCL_ERROR;
}
if ((d >= 0.0) && TclIsInfinite(d)
&& (Tcl_GetBignumFromObj(NULL, objv[1], &big) == TCL_OK)) {
mp_int root;
mp_err err;
err = mp_init(&root);
if (err == MP_OKAY) {
err = mp_sqrt(&big, &root);
}
mp_clear(&big);
if (err != MP_OKAY) {
mp_clear(&root);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(TclBignumToDouble(&root)));
mp_clear(&root);
} else {
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(sqrt(d)));
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
7082 7083 7084 7085 7086 7087 7088 |
}
errno = 0;
return CheckDoubleResult(interp, func(d1, d2));
}
static int
ExprAbsFunc(
| | | 7861 7862 7863 7864 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 7875 |
}
errno = 0;
return CheckDoubleResult(interp, func(d1, d2));
}
static int
ExprAbsFunc(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
7108 7109 7110 7111 7112 7113 7114 |
if (type == TCL_NUMBER_INT) {
Tcl_WideInt l = *((const Tcl_WideInt *) ptr);
if (l > 0) {
goto unChanged;
} else if (l == 0) {
if (TclHasStringRep(objv[1])) {
| | | > > | 7887 7888 7889 7890 7891 7892 7893 7894 7895 7896 7897 7898 7899 7900 7901 7902 7903 7904 7905 7906 7907 7908 7909 7910 7911 7912 7913 7914 7915 7916 |
if (type == TCL_NUMBER_INT) {
Tcl_WideInt l = *((const Tcl_WideInt *) ptr);
if (l > 0) {
goto unChanged;
} else if (l == 0) {
if (TclHasStringRep(objv[1])) {
int numBytes;
const char *bytes = TclGetStringFromObj(objv[1], &numBytes);
while (numBytes) {
if (*bytes == '-') {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0));
return TCL_OK;
}
bytes++; numBytes--;
}
}
goto unChanged;
} else if (l == WIDE_MIN) {
if (mp_init_i64(&big, l) != MP_OKAY) {
return TCL_ERROR;
}
goto tooLarge;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-l));
return TCL_OK;
}
if (type == TCL_NUMBER_DOUBLE) {
|
| ︙ | ︙ | |||
7149 7150 7151 7152 7153 7154 7155 |
goto unChanged;
}
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d));
return TCL_OK;
}
if (type == TCL_NUMBER_BIG) {
| | | > > | 7930 7931 7932 7933 7934 7935 7936 7937 7938 7939 7940 7941 7942 7943 7944 7945 7946 7947 7948 7949 |
goto unChanged;
}
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d));
return TCL_OK;
}
if (type == TCL_NUMBER_BIG) {
if (mp_isneg((const mp_int *) ptr)) {
Tcl_GetBignumFromObj(NULL, objv[1], &big);
tooLarge:
if (mp_neg(&big, &big) != MP_OKAY) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
} else {
unChanged:
Tcl_SetObjResult(interp, objv[1]);
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
7177 7178 7179 7180 7181 7182 7183 |
#endif
}
return TCL_OK;
}
static int
ExprBoolFunc(
| | | | 7960 7961 7962 7963 7964 7965 7966 7967 7968 7969 7970 7971 7972 7973 7974 7975 7976 7977 7978 7979 7980 7981 7982 7983 7984 7985 7986 7987 7988 7989 7990 7991 7992 7993 7994 7995 |
#endif
}
return TCL_OK;
}
static int
ExprBoolFunc(
TCL_UNUSED(ClientData),
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(ClientData),
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;
|
| ︙ | ︙ | |||
7225 7226 7227 7228 7229 7230 7231 |
}
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult));
return TCL_OK;
}
static int
ExprIntFunc(
| | | 8008 8009 8010 8011 8012 8013 8014 8015 8016 8017 8018 8019 8020 8021 8022 |
}
Tcl_SetObjResult(interp, Tcl_NewDoubleObj(dResult));
return TCL_OK;
}
static int
ExprIntFunc(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
7281 7282 7283 7284 7285 7286 7287 |
Tcl_GetDoubleFromObj(interp, objv[1], &d);
return TCL_ERROR;
}
static int
ExprWideFunc(
| | | | 8064 8065 8066 8067 8068 8069 8070 8071 8072 8073 8074 8075 8076 8077 8078 8079 8080 8081 8082 8083 8084 8085 8086 8087 8088 8089 8090 8091 8092 8093 8094 8095 8096 8097 8098 8099 |
Tcl_GetDoubleFromObj(interp, objv[1], &d);
return TCL_ERROR;
}
static int
ExprWideFunc(
TCL_UNUSED(ClientData),
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(ClientData),
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;
|
| ︙ | ︙ | |||
7342 7343 7344 7345 7346 7347 7348 |
Tcl_SetObjResult(interp, res);
return TCL_OK;
}
static int
ExprMaxFunc(
| | | | | | | 8125 8126 8127 8128 8129 8130 8131 8132 8133 8134 8135 8136 8137 8138 8139 8140 8141 8142 8143 8144 8145 8146 8147 8148 8149 8150 8151 8152 8153 8154 8155 8156 8157 8158 8159 8160 8161 |
Tcl_SetObjResult(interp, res);
return TCL_OK;
}
static int
ExprMaxFunc(
TCL_UNUSED(ClientData),
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(ClientData),
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(ClientData),
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;
|
| ︙ | ︙ | |||
7395 7396 7397 7398 7399 7400 7401 | iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12); /* * Make sure 1 <= randSeed <= (2^31) - 2. See below. */ | | | | 8178 8179 8180 8181 8182 8183 8184 8185 8186 8187 8188 8189 8190 8191 8192 8193 |
iPtr->randSeed = TclpGetClicks() + (PTR2INT(Tcl_GetCurrentThread())<<12);
/*
* Make sure 1 <= randSeed <= (2^31) - 2. See below.
*/
iPtr->randSeed &= 0x7FFFFFFF;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7FFFFFFF)) {
iPtr->randSeed ^= 123459876;
}
}
/*
* Generate the random number using the linear congruential generator
* defined by the following recurrence:
|
| ︙ | ︙ | |||
7457 7458 7459 7460 7461 7462 7463 |
TclNewDoubleObj(oResult, dResult);
Tcl_SetObjResult(interp, oResult);
return TCL_OK;
}
static int
ExprRoundFunc(
| | | 8240 8241 8242 8243 8244 8245 8246 8247 8248 8249 8250 8251 8252 8253 8254 |
TclNewDoubleObj(oResult, dResult);
Tcl_SetObjResult(interp, oResult);
return TCL_OK;
}
static int
ExprRoundFunc(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
7488 7489 7490 7491 7492 7493 7494 7495 7496 7497 7498 7499 7500 |
if (fractPart <= -0.5) {
min++;
} else if (fractPart >= 0.5) {
max--;
}
if ((intPart >= (double)max) || (intPart <= (double)min)) {
mp_int big;
if (Tcl_InitBignumFromDouble(interp, intPart, &big) != TCL_OK) {
/* Infinity */
return TCL_ERROR;
}
if (fractPart <= -0.5) {
| > | | > > > | 8271 8272 8273 8274 8275 8276 8277 8278 8279 8280 8281 8282 8283 8284 8285 8286 8287 8288 8289 8290 8291 8292 8293 8294 8295 8296 8297 |
if (fractPart <= -0.5) {
min++;
} else if (fractPart >= 0.5) {
max--;
}
if ((intPart >= (double)max) || (intPart <= (double)min)) {
mp_int big;
mp_err err = MP_OKAY;
if (Tcl_InitBignumFromDouble(interp, intPart, &big) != TCL_OK) {
/* Infinity */
return TCL_ERROR;
}
if (fractPart <= -0.5) {
err = mp_sub_d(&big, 1, &big);
} else if (fractPart >= 0.5) {
err = mp_add_d(&big, 1, &big);
}
if (err != MP_OKAY) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big));
return TCL_OK;
} else {
Tcl_WideInt result = (Tcl_WideInt)intPart;
if (fractPart <= -0.5) {
|
| ︙ | ︙ | |||
7532 7533 7534 7535 7536 7537 7538 |
Tcl_GetDoubleFromObj(interp, objv[1], &d);
return TCL_ERROR;
}
static int
ExprSrandFunc(
| | | | | | | 8319 8320 8321 8322 8323 8324 8325 8326 8327 8328 8329 8330 8331 8332 8333 8334 8335 8336 8337 8338 8339 8340 8341 8342 8343 8344 8345 8346 8347 8348 8349 8350 8351 8352 8353 8354 8355 8356 8357 8358 8359 8360 8361 8362 8363 8364 8365 8366 8367 8368 8369 8370 8371 8372 |
Tcl_GetDoubleFromObj(interp, objv[1], &d);
return TCL_ERROR;
}
static int
ExprSrandFunc(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* The interpreter in which to execute the
* function. */
int objc, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Parameter vector. */
{
Interp *iPtr = (Interp *) interp;
Tcl_WideInt w = 0; /* Initialized to avoid compiler warning. */
/*
* Convert argument and use it to reset the seed.
*/
if (objc != 2) {
MathFuncWrongNumArgs(interp, 2, objc, objv);
return TCL_ERROR;
}
if (TclGetWideBitsFromObj(NULL, objv[1], &w) != TCL_OK) {
return TCL_ERROR;
}
/*
* Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. See comments in
* ExprRandFunc for more details.
*/
iPtr->flags |= RAND_SEED_INITIALIZED;
iPtr->randSeed = (long) w & 0x7FFFFFFF;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7FFFFFFF)) {
iPtr->randSeed ^= 123459876;
}
/*
* To avoid duplicating the random number generation code we simply clean
* up our state and call the real random number function. That function
* will always succeed.
*/
return ExprRandFunc(NULL, interp, 1, objv);
}
/*
*----------------------------------------------------------------------
*
* Double Classification Functions --
*
|
| ︙ | ︙ | |||
7611 7612 7613 7614 7615 7616 7617 |
static inline int
ClassifyDouble(
double d)
{
#if TCL_FPCLASSIFY_MODE == 0
return fpclassify(d);
| | | | | > | | | 8398 8399 8400 8401 8402 8403 8404 8405 8406 8407 8408 8409 8410 8411 8412 8413 8414 8415 8416 8417 8418 8419 8420 8421 8422 8423 8424 8425 8426 8427 8428 |
static inline int
ClassifyDouble(
double d)
{
#if TCL_FPCLASSIFY_MODE == 0
return fpclassify(d);
#else /* TCL_FPCLASSIFY_MODE != 0 */
/*
* If we don't have fpclassify(), we also don't have the values it returns.
* Hence we define those here.
*/
#ifndef FP_NAN
# define FP_NAN 1 /* Value is NaN */
# define FP_INFINITE 2 /* Value is an infinity */
# define FP_ZERO 3 /* Value is a zero */
# define FP_NORMAL 4 /* Value is a normal float */
# define FP_SUBNORMAL 5 /* Value has lost accuracy */
#endif /* !FP_NAN */
#if TCL_FPCLASSIFY_MODE == 3
return __builtin_fpclassify(
FP_NAN, FP_INFINITE, FP_NORMAL, FP_SUBNORMAL, FP_ZERO, d);
#elif TCL_FPCLASSIFY_MODE == 2
/*
* We assume this hack is only needed on little-endian systems.
* Specifically, x86 running Windows. It's fairly easy to enable for
* others if they need it (because their libc/libm is broken) but we'll
* jump that hurdle when requred. We can solve the word ordering then.
*/
|
| ︙ | ︙ | |||
7653 7654 7655 7656 7657 7658 7659 |
/* The pieces extracted from the double. */
int zeroMantissa; /* Was the mantissa zero? That's special. */
/*
* Shifts and masks to use with the doubleMeaning variable above.
*/
| | | | | 8441 8442 8443 8444 8445 8446 8447 8448 8449 8450 8451 8452 8453 8454 8455 8456 8457 |
/* The pieces extracted from the double. */
int zeroMantissa; /* Was the mantissa zero? That's special. */
/*
* Shifts and masks to use with the doubleMeaning variable above.
*/
#define EXPONENT_MASK 0x7FF /* 11 bits (after shifting) */
#define EXPONENT_SHIFT 20 /* Moves exponent to bottom of word */
#define MANTISSA_MASK 0xFFFFF /* 20 bits (plus 32 from other word) */
/*
* Extract the exponent (11 bits) and mantissa (52 bits). Note that we
* totally ignore the sign bit.
*/
doubleMeaning.d = d;
|
| ︙ | ︙ | |||
7692 7693 7694 7695 7696 7697 7698 |
default:
/*
* Everything else is a NORMAL double precision float.
*/
return FP_NORMAL;
}
| | | | | | | 8480 8481 8482 8483 8484 8485 8486 8487 8488 8489 8490 8491 8492 8493 8494 8495 8496 8497 8498 8499 8500 8501 8502 8503 8504 8505 8506 8507 8508 8509 8510 8511 8512 8513 8514 8515 8516 8517 8518 8519 8520 8521 8522 |
default:
/*
* Everything else is a NORMAL double precision float.
*/
return FP_NORMAL;
}
#elif TCL_FPCLASSIFY_MODE == 1
switch (_fpclass(d)) {
case _FPCLASS_NZ:
case _FPCLASS_PZ:
return FP_ZERO;
case _FPCLASS_NN:
case _FPCLASS_PN:
return FP_NORMAL;
case _FPCLASS_ND:
case _FPCLASS_PD:
return FP_SUBNORMAL;
case _FPCLASS_NINF:
case _FPCLASS_PINF:
return FP_INFINITE;
default:
Tcl_Panic("result of _fpclass() outside documented range!");
case _FPCLASS_QNAN:
case _FPCLASS_SNAN:
return FP_NAN;
}
#else /* TCL_FPCLASSIFY_MODE not in (0..3) */
#error "unknown or unexpected TCL_FPCLASSIFY_MODE"
#endif /* TCL_FPCLASSIFY_MODE */
#endif /* !fpclassify */
}
static int
ExprIsFiniteFunc(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
7751 7752 7753 7754 7755 7756 7757 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsInfinityFunc(
| | | 8539 8540 8541 8542 8543 8544 8545 8546 8547 8548 8549 8550 8551 8552 8553 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsInfinityFunc(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
7781 7782 7783 7784 7785 7786 7787 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsNaNFunc(
| | | 8569 8570 8571 8572 8573 8574 8575 8576 8577 8578 8579 8580 8581 8582 8583 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsNaNFunc(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
7811 7812 7813 7814 7815 7816 7817 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsNormalFunc(
| | | 8599 8600 8601 8602 8603 8604 8605 8606 8607 8608 8609 8610 8611 8612 8613 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsNormalFunc(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
7841 7842 7843 7844 7845 7846 7847 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsSubnormalFunc(
| | | 8629 8630 8631 8632 8633 8634 8635 8636 8637 8638 8639 8640 8641 8642 8643 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsSubnormalFunc(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
7871 7872 7873 7874 7875 7876 7877 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsUnorderedFunc(
| | | 8659 8660 8661 8662 8663 8664 8665 8666 8667 8668 8669 8670 8671 8672 8673 |
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
ExprIsUnorderedFunc(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
7912 7913 7914 7915 7916 7917 7918 |
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
FloatClassifyObjCmd(
| | | 8700 8701 8702 8703 8704 8705 8706 8707 8708 8709 8710 8711 8712 8713 8714 |
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
static int
FloatClassifyObjCmd(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
8021 8022 8023 8024 8025 8026 8027 | * The 'tcl-probe' DTrace probe is triggered (if it is enabled). * *---------------------------------------------------------------------- */ static int DTraceObjCmd( | | | | 8809 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(ClientData),
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;
|
| ︙ | ︙ | |||
8405 8406 8407 8408 8409 8410 8411 | * updated so that its data[1] field contains the tailcall list. * *---------------------------------------------------------------------- */ int TclNRTailcallObjCmd( | | | 9193 9194 9195 9196 9197 9198 9199 9200 9201 9202 9203 9204 9205 9206 9207 |
* updated so that its data[1] field contains the tailcall list.
*
*----------------------------------------------------------------------
*/
int
TclNRTailcallObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
if (objc < 1) {
|
| ︙ | ︙ | |||
8475 8476 8477 8478 8479 8480 8481 |
int
TclNRTailcallEval(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | 9263 9264 9265 9266 9267 9268 9269 9270 9271 9272 9273 9274 9275 9276 9277 |
int
TclNRTailcallEval(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *listPtr = (Tcl_Obj *)data[0], *nsObjPtr;
Tcl_Namespace *nsPtr;
int objc;
Tcl_Obj **objv;
Tcl_ListObjGetElements(interp, listPtr, &objc, &objv);
nsObjPtr = objv[0];
|
| ︙ | ︙ | |||
8510 8511 8512 8513 8514 8515 8516 |
iPtr->lookupNsPtr = (Namespace *) nsPtr;
return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL);
}
int
TclNRReleaseValues(
ClientData data[],
| | > | 9298 9299 9300 9301 9302 9303 9304 9305 9306 9307 9308 9309 9310 9311 9312 9313 9314 9315 9316 |
iPtr->lookupNsPtr = (Namespace *) nsPtr;
return TclNREvalObjv(interp, objc-1, objv+1, 0, NULL);
}
int
TclNRReleaseValues(
ClientData data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
int i = 0;
while (i < 4) {
if (data[i]) {
Tcl_DecrRefCount((Tcl_Obj *) data[i]);
} else {
break;
}
i++;
|
| ︙ | ︙ | |||
8597 8598 8599 8600 8601 8602 8603 |
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
clientData, NULL, NULL);
return TCL_OK;
}
int
TclNRYieldToObjCmd(
| | | 9386 9387 9388 9389 9390 9391 9392 9393 9394 9395 9396 9397 9398 9399 9400 |
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
clientData, NULL, NULL);
return TCL_OK;
}
int
TclNRYieldToObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
Tcl_Obj *listPtr, *nsObjPtr;
Tcl_Namespace *nsPtr = TclGetCurrentNamespace(interp);
|
| ︙ | ︙ | |||
8651 8652 8653 8654 8655 8656 8657 |
return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv);
}
static int
RewindCoroutineCallback(
ClientData data[],
Tcl_Interp *interp,
| | | | 9440 9441 9442 9443 9444 9445 9446 9447 9448 9449 9450 9451 9452 9453 9454 9455 9456 |
return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv);
}
static int
RewindCoroutineCallback(
ClientData data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
return Tcl_RestoreInterpState(interp, (Tcl_InterpState)data[0]);
}
static int
RewindCoroutine(
CoroutineData *corPtr,
int result)
{
|
| ︙ | ︙ | |||
8678 8679 8680 8681 8682 8683 8684 |
return TclNRInterpCoroutine(corPtr, interp, 0, NULL);
}
static void
DeleteCoroutine(
ClientData clientData)
{
| | | | | 9467 9468 9469 9470 9471 9472 9473 9474 9475 9476 9477 9478 9479 9480 9481 9482 9483 9484 9485 9486 9487 9488 9489 9490 9491 9492 9493 9494 9495 9496 9497 9498 9499 9500 9501 9502 9503 9504 9505 9506 9507 9508 9509 9510 9511 9512 9513 9514 9515 |
return TclNRInterpCoroutine(corPtr, interp, 0, NULL);
}
static void
DeleteCoroutine(
ClientData clientData)
{
CoroutineData *corPtr = (CoroutineData *)clientData;
Tcl_Interp *interp = corPtr->eePtr->interp;
NRE_callback *rootPtr = TOP_CB(interp);
if (COR_IS_SUSPENDED(corPtr)) {
TclNRRunCallbacks(interp, RewindCoroutine(corPtr,TCL_OK), rootPtr);
}
}
static int
NRCoroutineCallerCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
CoroutineData *corPtr = (CoroutineData *)data[0];
Command *cmdPtr = corPtr->cmdPtr;
/*
* This is the last callback in the caller execEnv, right before switching
* to the coroutine's
*/
NRE_ASSERT(iPtr->execEnvPtr == corPtr->callerEEPtr);
if (!corPtr->eePtr) {
/*
* The execEnv was wound down but not deleted for our sake. We finish
* the job here. The caller context has already been restored.
*/
NRE_ASSERT(iPtr->varFramePtr == corPtr->caller.varFramePtr);
NRE_ASSERT(iPtr->framePtr == corPtr->caller.framePtr);
NRE_ASSERT(iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr);
ckfree(corPtr);
return result;
}
NRE_ASSERT(COR_IS_SUSPENDED(corPtr));
SAVE_CONTEXT(corPtr->running);
RESTORE_CONTEXT(corPtr->caller);
|
| ︙ | ︙ | |||
8739 8740 8741 8742 8743 8744 8745 |
static int
NRCoroutineExitCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | 9528 9529 9530 9531 9532 9533 9534 9535 9536 9537 9538 9539 9540 9541 9542 |
static int
NRCoroutineExitCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
CoroutineData *corPtr = (CoroutineData *)data[0];
Command *cmdPtr = corPtr->cmdPtr;
/*
* This runs at the bottom of the Coroutine's execEnv: it will be executed
* when the coroutine returns or is wound down, but not when it yields. It
* deletes the coroutine and restores the caller's environment.
*/
|
| ︙ | ︙ | |||
8771 8772 8773 8774 8775 8776 8777 |
/*
* #280.
* Drop the coroutine-owned copy of the lineLABCPtr hashtable for literal
* command arguments in bytecode.
*/
Tcl_DeleteHashTable(corPtr->lineLABCPtr);
| | | 9560 9561 9562 9563 9564 9565 9566 9567 9568 9569 9570 9571 9572 9573 9574 |
/*
* #280.
* Drop the coroutine-owned copy of the lineLABCPtr hashtable for literal
* command arguments in bytecode.
*/
Tcl_DeleteHashTable(corPtr->lineLABCPtr);
ckfree(corPtr->lineLABCPtr);
corPtr->lineLABCPtr = NULL;
RESTORE_CONTEXT(corPtr->caller);
iPtr->execEnvPtr = corPtr->callerEEPtr;
iPtr->numLevels++;
return result;
|
| ︙ | ︙ | |||
8802 8803 8804 8805 8806 8807 8808 |
*----------------------------------------------------------------------
*/
int
TclNRCoroutineActivateCallback(
ClientData data[],
Tcl_Interp *interp,
| | | | 9591 9592 9593 9594 9595 9596 9597 9598 9599 9600 9601 9602 9603 9604 9605 9606 9607 |
*----------------------------------------------------------------------
*/
int
TclNRCoroutineActivateCallback(
ClientData data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
CoroutineData *corPtr = (CoroutineData *)data[0];
int type = PTR2INT(data[1]);
int numLevels, unused;
int *stackLevel = &unused;
if (!corPtr->stackLevel) {
/*
* -- Coroutine is suspended --
|
| ︙ | ︙ | |||
8881 8882 8883 8884 8885 8886 8887 |
*----------------------------------------------------------------------
*/
static int
TclNREvalList(
ClientData data[],
Tcl_Interp *interp,
| | | | 9670 9671 9672 9673 9674 9675 9676 9677 9678 9679 9680 9681 9682 9683 9684 9685 9686 9687 9688 |
*----------------------------------------------------------------------
*/
static int
TclNREvalList(
ClientData data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
int objc;
Tcl_Obj **objv;
Tcl_Obj *listPtr = (Tcl_Obj *)data[0];
Tcl_IncrRefCount(listPtr);
TclMarkTailcall(interp);
TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL);
TclListObjGetElements(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, 0, NULL);
|
| ︙ | ︙ | |||
8907 8908 8909 8910 8911 8912 8913 | * Implementation of [::tcl::unsupported::corotype] command. * *---------------------------------------------------------------------- */ static int CoroTypeObjCmd( | | | 9696 9697 9698 9699 9700 9701 9702 9703 9704 9705 9706 9707 9708 9709 9710 |
* Implementation of [::tcl::unsupported::corotype] command.
*
*----------------------------------------------------------------------
*/
static int
CoroTypeObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Command *cmdPtr;
CoroutineData *corPtr;
|
| ︙ | ︙ | |||
8938 8939 8940 8941 8942 8943 8944 |
}
/*
* An active coroutine is "active". Can't tell what it might do in the
* future.
*/
| | | 9727 9728 9729 9730 9731 9732 9733 9734 9735 9736 9737 9738 9739 9740 9741 |
}
/*
* An active coroutine is "active". Can't tell what it might do in the
* future.
*/
corPtr = (CoroutineData *)cmdPtr->objClientData;
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("active", -1));
return TCL_OK;
}
/*
* Inactive coroutines are classified by the (effective) command used to
|
| ︙ | ︙ | |||
8992 8993 8994 8995 8996 8997 8998 |
if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
TclGetString(objPtr), NULL);
return NULL;
}
| | | | 9781 9782 9783 9784 9785 9786 9787 9788 9789 9790 9791 9792 9793 9794 9795 9796 9797 9798 9799 9800 |
if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
TclGetString(objPtr), NULL);
return NULL;
}
return (CoroutineData *)cmdPtr->objClientData;
}
static int
TclNRCoroInjectObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
CoroutineData *corPtr;
ExecEnv *savedEEPtr = iPtr->execEnvPtr;
|
| ︙ | ︙ | |||
9042 9043 9044 9045 9046 9047 9048 |
iPtr->execEnvPtr = savedEEPtr;
return TCL_OK;
}
static int
TclNRCoroProbeObjCmd(
| | | 9831 9832 9833 9834 9835 9836 9837 9838 9839 9840 9841 9842 9843 9844 9845 |
iPtr->execEnvPtr = savedEEPtr;
return TCL_OK;
}
static int
TclNRCoroProbeObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
CoroutineData *corPtr;
ExecEnv *savedEEPtr = iPtr->execEnvPtr;
int numLevels, unused;
|
| ︙ | ︙ | |||
9141 9142 9143 9144 9145 9146 9147 |
*----------------------------------------------------------------------
*/
static int
InjectHandler(
ClientData data[],
Tcl_Interp *interp,
| | | | | 9930 9931 9932 9933 9934 9935 9936 9937 9938 9939 9940 9941 9942 9943 9944 9945 9946 9947 |
*----------------------------------------------------------------------
*/
static int
InjectHandler(
ClientData data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
CoroutineData *corPtr = (CoroutineData *)data[0];
Tcl_Obj *listPtr = (Tcl_Obj *)data[1];
int nargs = PTR2INT(data[2]);
ClientData isProbe = data[3];
int objc;
Tcl_Obj **objv;
if (!isProbe) {
/*
|
| ︙ | ︙ | |||
9189 9190 9191 9192 9193 9194 9195 |
static int
InjectHandlerPostCall(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | 9978 9979 9980 9981 9982 9983 9984 9985 9986 9987 9988 9989 9990 9991 9992 9993 |
static int
InjectHandlerPostCall(
ClientData data[],
Tcl_Interp *interp,
int result)
{
CoroutineData *corPtr = (CoroutineData *)data[0];
Tcl_Obj *listPtr = (Tcl_Obj *)data[1];
int nargs = PTR2INT(data[2]);
ClientData isProbe = data[3];
int numLevels;
/*
* Delete the command words for what we just executed.
*/
|
| ︙ | ︙ | |||
9235 9236 9237 9238 9239 9240 9241 | * Implementation of [::tcl::unsupported::inject] command. * *---------------------------------------------------------------------- */ static int NRInjectObjCmd( | | | 10024 10025 10026 10027 10028 10029 10030 10031 10032 10033 10034 10035 10036 10037 10038 |
* Implementation of [::tcl::unsupported::inject] command.
*
*----------------------------------------------------------------------
*/
static int
NRInjectObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
CoroutineData *corPtr;
ExecEnv *savedEEPtr = iPtr->execEnvPtr;
|
| ︙ | ︙ | |||
9285 9286 9287 9288 9289 9290 9291 |
int
TclNRInterpCoroutine(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | 10074 10075 10076 10077 10078 10079 10080 10081 10082 10083 10084 10085 10086 10087 10088 |
int
TclNRInterpCoroutine(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
CoroutineData *corPtr = (CoroutineData *)clientData;
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"coroutine \"%s\" is already running",
TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
9344 9345 9346 9347 9348 9349 9350 | * description of what this does. * *---------------------------------------------------------------------- */ int TclNRCoroutineObjCmd( | | | 10133 10134 10135 10136 10137 10138 10139 10140 10141 10142 10143 10144 10145 10146 10147 |
* description of what this does.
*
*----------------------------------------------------------------------
*/
int
TclNRCoroutineObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Command *cmdPtr;
CoroutineData *corPtr;
const char *procName, *simpleName;
|
| ︙ | ︙ | |||
9385 9386 9387 9388 9389 9390 9391 |
}
/*
* We ARE creating the coroutine command: allocate the corresponding
* struct and create the corresponding command.
*/
| | | 10174 10175 10176 10177 10178 10179 10180 10181 10182 10183 10184 10185 10186 10187 10188 |
}
/*
* We ARE creating the coroutine command: allocate the corresponding
* struct and create the corresponding command.
*/
corPtr = (CoroutineData *)ckalloc(sizeof(CoroutineData));
cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName,
(Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine,
corPtr, DeleteCoroutine);
corPtr->cmdPtr = cmdPtr;
cmdPtr->refCount++;
|
| ︙ | ︙ | |||
9407 9408 9409 9410 9411 9412 9413 |
* tree. Like the chain -> tree conversion of the CmdFrame stack.
*/
{
Tcl_HashSearch hSearch;
Tcl_HashEntry *hePtr;
| | | 10196 10197 10198 10199 10200 10201 10202 10203 10204 10205 10206 10207 10208 10209 10210 |
* tree. Like the chain -> tree conversion of the CmdFrame stack.
*/
{
Tcl_HashSearch hSearch;
Tcl_HashEntry *hePtr;
corPtr->lineLABCPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(corPtr->lineLABCPtr, TCL_ONE_WORD_KEYS);
for (hePtr = Tcl_FirstHashEntry(iPtr->lineLABCPtr,&hSearch);
hePtr; hePtr = Tcl_NextHashEntry(&hSearch)) {
int isNew;
Tcl_HashEntry *newPtr =
Tcl_CreateHashEntry(corPtr->lineLABCPtr,
|
| ︙ | ︙ | |||
9477 9478 9479 9480 9481 9482 9483 | /* * This is used in the [info] ensemble */ int TclInfoCoroutineCmd( | | | 10266 10267 10268 10269 10270 10271 10272 10273 10274 10275 10276 10277 10278 10279 10280 |
/*
* This is used in the [info] ensemble
*/
int
TclInfoCoroutineCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
if (objc != 1) {
|
| ︙ | ︙ |
Changes to generic/tclBinary.c.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" | | | | | 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 | * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclTomMath.h" #include <math.h> #include <assert.h> /* * The following constants are used by GetFormatSpec to indicate various * special conditions in the parsing of a format specifier. */ #define BINARY_ALL -1 /* Use all elements in the argument. */ #define BINARY_NOCOUNT -2 /* No count was specified in format. */ /* * The following flags may be ORed together and returned by GetFormatSpec */ #define BINARY_SIGNED 0 /* Field to be read as signed data */ #define BINARY_UNSIGNED 1 /* Field to be read as unsigned data */ |
| ︙ | ︙ | |||
60 61 62 63 64 65 66 | static void DupProperByteArrayInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static int FormatNumber(Tcl_Interp *interp, int type, Tcl_Obj *src, unsigned char **cursorPtr); static void FreeByteArrayInternalRep(Tcl_Obj *objPtr); static void FreeProperByteArrayInternalRep(Tcl_Obj *objPtr); static int GetFormatSpec(const char **formatPtr, char *cmdPtr, | | | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | static void DupProperByteArrayInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static int FormatNumber(Tcl_Interp *interp, int type, Tcl_Obj *src, unsigned char **cursorPtr); static void FreeByteArrayInternalRep(Tcl_Obj *objPtr); static void FreeProperByteArrayInternalRep(Tcl_Obj *objPtr); static int GetFormatSpec(const char **formatPtr, char *cmdPtr, int *countPtr, int *flagsPtr); static Tcl_Obj * ScanNumber(unsigned char *buffer, int type, int flags, Tcl_HashTable **numberCachePtr); static int SetByteArrayFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfByteArray(Tcl_Obj *listPtr); static void DeleteScanNumberCache(Tcl_HashTable *numberCachePtr); static int NeedReversing(int format); static void CopyNumber(const void *from, void *to, unsigned length, int type); /* Binary ensemble commands */ static int BinaryFormatCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int BinaryScanCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); |
| ︙ | ︙ | |||
262 263 264 265 266 267 268 | /* * The following structure is the internal rep for a ByteArray object. Keeps * track of how much memory has been used and how much has been allocated for * the byte array to enable growing and shrinking of the ByteArray object with * fewer mallocs. */ | | > > > | | | | | 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 |
/*
* The following structure is the internal rep for a ByteArray object. Keeps
* track of how much memory has been used and how much has been allocated for
* the byte array to enable growing and shrinking of the ByteArray object with
* fewer mallocs.
*/
typedef struct ByteArray {
unsigned int bad; /* Index of the character that is a nonbyte.
* If all characters are bytes, bad = used,
* though then we should never read it. */
unsigned int used; /* The number of bytes used in the byte
* array. */
unsigned int allocated; /* The amount of space actually allocated
* minus 1 byte. */
unsigned char bytes[1]; /* 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)
#define SET_BYTEARRAY(irPtr, baPtr) \
(irPtr)->twoPtrValue.ptr1 = (void *) (baPtr)
int
TclIsPureByteArray(
Tcl_Obj * objPtr)
{
return TclHasIntRep(objPtr, &properByteArrayType);
}
|
| ︙ | ︙ | |||
309 310 311 312 313 314 315 |
#undef Tcl_NewByteArrayObj
Tcl_Obj *
Tcl_NewByteArrayObj(
const unsigned char *bytes, /* The array of bytes used to initialize the
* new object. */
| | > | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 |
#undef Tcl_NewByteArrayObj
Tcl_Obj *
Tcl_NewByteArrayObj(
const unsigned char *bytes, /* The array of bytes used to initialize the
* new object. */
int length) /* Length of the array of bytes, which must be
* >= 0. */
{
#ifdef TCL_MEM_DEBUG
return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0);
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *objPtr;
TclNewObj(objPtr);
|
| ︙ | ︙ | |||
347 348 349 350 351 352 353 354 355 356 357 |
*
* Side effects:
* Memory allocated for new object and copy of byte array argument.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_DbNewByteArrayObj(
const unsigned char *bytes, /* The array of bytes used to initialize the
* new object. */
| > | > < > > > > > > > > > > < > | 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 |
*
* Side effects:
* Memory allocated for new object and copy of byte array argument.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewByteArrayObj(
const unsigned char *bytes, /* The array of bytes used to initialize the
* new object. */
int length, /* Length of the array of bytes, which must be
* >= 0. */
const char *file, /* The name of the source file calling this
* procedure; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
Tcl_SetByteArrayObj(objPtr, bytes, length);
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewByteArrayObj(
const unsigned char *bytes, /* The array of bytes used to initialize the
* new object. */
int length, /* Length of the array of bytes, which must be
* >= 0. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewByteArrayObj(bytes, length);
}
#endif /* TCL_MEM_DEBUG */
/*
*---------------------------------------------------------------------------
*
* Tcl_SetByteArrayObj --
*
* Modify an object to be a ByteArray object and to have the specified
|
| ︙ | ︙ | |||
391 392 393 394 395 396 397 |
*/
void
Tcl_SetByteArrayObj(
Tcl_Obj *objPtr, /* Object to initialize as a ByteArray. */
const unsigned char *bytes, /* The array of bytes to use as the new value.
* May be NULL even if length > 0. */
| | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
*/
void
Tcl_SetByteArrayObj(
Tcl_Obj *objPtr, /* Object to initialize as a ByteArray. */
const unsigned char *bytes, /* The array of bytes to use as the new value.
* May be NULL even if length > 0. */
int length) /* Length of the array of bytes, which must
* be >= 0. */
{
ByteArray *byteArrayPtr;
Tcl_ObjIntRep ir;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
}
TclInvalidateStringRep(objPtr);
if (length < 0) {
length = 0;
}
byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length));
byteArrayPtr->bad = length;
byteArrayPtr->used = length;
byteArrayPtr->allocated = length;
if ((bytes != NULL) && (length > 0)) {
memcpy(byteArrayPtr->bytes, bytes, length);
}
SET_BYTEARRAY(&ir, byteArrayPtr);
Tcl_StoreIntRep(objPtr, &properByteArrayType, &ir);
}
/*
*----------------------------------------------------------------------
*
* TclGetBytesFromObj --
*
* Attempt to extract the value from objPtr in the representation
* of a byte sequence. On success return the extracted byte sequence.
* On failures, return NULL and record error message and code in
* interp (if not NULL).
*
* Results:
* Pointer to array of bytes, or NULL. representing the ByteArray object.
* Writes number of bytes in array to *lengthPtr.
*
*----------------------------------------------------------------------
*/
unsigned char *
TclGetBytesFromObj(
Tcl_Interp *interp, /* For error reporting */
Tcl_Obj *objPtr, /* Value to extract from */
int *lengthPtr) /* If non-NULL, filled with length of the
* array of bytes in the ByteArray object. */
{
ByteArray *baPtr;
const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
if (irPtr == NULL) {
SetByteArrayFromAny(NULL, objPtr);
irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
if (irPtr == NULL) {
if (interp) {
const char *nonbyte;
int ucs4;
irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
baPtr = GET_BYTEARRAY(irPtr);
nonbyte = Tcl_UtfAtIndex(Tcl_GetString(objPtr), baPtr->bad);
TclUtfToUCS4(nonbyte, &ucs4);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected byte sequence but character %d "
"was '%1s' (U+%06X)", baPtr->bad, nonbyte, ucs4));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "BYTES", NULL);
}
return NULL;
}
}
baPtr = GET_BYTEARRAY(irPtr);
if (lengthPtr != NULL) {
*lengthPtr = baPtr->used;
}
return baPtr->bytes;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetByteArrayFromObj --
*
* Attempt to get the array of bytes from the Tcl object. If the object
|
| ︙ | ︙ | |||
439 440 441 442 443 444 445 |
unsigned char *
Tcl_GetByteArrayFromObj(
Tcl_Obj *objPtr, /* The ByteArray object. */
int *lengthPtr) /* If non-NULL, filled with length of the
* array of bytes in the ByteArray object. */
{
ByteArray *baPtr;
| | > | < | < < < < | | > > | | 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 |
unsigned char *
Tcl_GetByteArrayFromObj(
Tcl_Obj *objPtr, /* The ByteArray object. */
int *lengthPtr) /* If non-NULL, filled with length of the
* array of bytes in the ByteArray object. */
{
ByteArray *baPtr;
const Tcl_ObjIntRep *irPtr;
unsigned char *result = TclGetBytesFromObj(NULL, objPtr, lengthPtr);
if (result) {
return result;
}
irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
assert(irPtr != NULL);
baPtr = GET_BYTEARRAY(irPtr);
if (lengthPtr != NULL) {
*lengthPtr = baPtr->used;
}
return baPtr->bytes;
}
|
| ︙ | ︙ | |||
484 485 486 487 488 489 490 |
*
*----------------------------------------------------------------------
*/
unsigned char *
Tcl_SetByteArrayLength(
Tcl_Obj *objPtr, /* The ByteArray object. */
| | > > > > | | | > > | | 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 |
*
*----------------------------------------------------------------------
*/
unsigned char *
Tcl_SetByteArrayLength(
Tcl_Obj *objPtr, /* The ByteArray object. */
int length) /* New length for internal byte array. */
{
ByteArray *byteArrayPtr;
unsigned newLength;
Tcl_ObjIntRep *irPtr;
assert(length >= 0);
newLength = (unsigned int)length;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength");
}
irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
if (irPtr == NULL) {
irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
if (irPtr == NULL) {
SetByteArrayFromAny(NULL, objPtr);
irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
if (irPtr == NULL) {
irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
}
}
}
byteArrayPtr = GET_BYTEARRAY(irPtr);
if (newLength > byteArrayPtr->allocated) {
byteArrayPtr = (ByteArray *)ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(newLength));
byteArrayPtr->allocated = newLength;
SET_BYTEARRAY(irPtr, byteArrayPtr);
}
TclInvalidateStringRep(objPtr);
objPtr->typePtr = &properByteArrayType;
byteArrayPtr->bad = newLength;
byteArrayPtr->used = newLength;
return byteArrayPtr->bytes;
}
/*
*----------------------------------------------------------------------
*
* SetByteArrayFromAny --
|
| ︙ | ︙ | |||
534 535 536 537 538 539 540 | * A ByteArray object is stored as the internal rep of objPtr. * *---------------------------------------------------------------------- */ static int SetByteArrayFromAny( | | | < | > | | > > | > > > > > | | > | | 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 |
* A ByteArray object is stored as the internal rep of objPtr.
*
*----------------------------------------------------------------------
*/
static int
SetByteArrayFromAny(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */
{
size_t length, bad;
const char *src, *srcEnd;
unsigned char *dst;
Tcl_UniChar ch = 0;
ByteArray *byteArrayPtr;
Tcl_ObjIntRep ir;
if (TclHasIntRep(objPtr, &properByteArrayType)) {
return TCL_OK;
}
if (TclHasIntRep(objPtr, &tclByteArrayType)) {
return TCL_OK;
}
src = TclGetString(objPtr);
length = bad = objPtr->length;
srcEnd = src + length;
byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length));
for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
src += TclUtfToUniChar(src, &ch);
if ((bad == length) && (ch > 255)) {
bad = dst - byteArrayPtr->bytes;
}
*dst++ = UCHAR(ch);
}
SET_BYTEARRAY(&ir, byteArrayPtr);
byteArrayPtr->allocated = length;
byteArrayPtr->used = dst - byteArrayPtr->bytes;
if (bad == length) {
byteArrayPtr->bad = byteArrayPtr->used;
Tcl_StoreIntRep(objPtr, &properByteArrayType, &ir);
} else {
byteArrayPtr->bad = bad;
Tcl_StoreIntRep(objPtr, &tclByteArrayType, &ir);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* FreeByteArrayInternalRep --
|
| ︙ | ︙ | |||
592 593 594 595 596 597 598 |
*----------------------------------------------------------------------
*/
static void
FreeByteArrayInternalRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
| | | | 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 |
*----------------------------------------------------------------------
*/
static void
FreeByteArrayInternalRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
ckfree(GET_BYTEARRAY(TclFetchIntRep(objPtr, &tclByteArrayType)));
}
static void
FreeProperByteArrayInternalRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
ckfree(GET_BYTEARRAY(TclFetchIntRep(objPtr, &properByteArrayType)));
}
/*
*----------------------------------------------------------------------
*
* DupByteArrayInternalRep --
*
|
| ︙ | ︙ | |||
624 625 626 627 628 629 630 |
*/
static void
DupByteArrayInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
| | | > | > | 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 |
*/
static void
DupByteArrayInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
unsigned int length;
ByteArray *srcArrayPtr, *copyArrayPtr;
Tcl_ObjIntRep ir;
srcArrayPtr = GET_BYTEARRAY(TclFetchIntRep(srcPtr, &tclByteArrayType));
length = srcArrayPtr->used;
copyArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length));
copyArrayPtr->bad = srcArrayPtr->bad;
copyArrayPtr->used = length;
copyArrayPtr->allocated = length;
memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length);
SET_BYTEARRAY(&ir, copyArrayPtr);
Tcl_StoreIntRep(copyPtr, &tclByteArrayType, &ir);
}
static void
DupProperByteArrayInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
unsigned int length;
ByteArray *srcArrayPtr, *copyArrayPtr;
Tcl_ObjIntRep ir;
srcArrayPtr = GET_BYTEARRAY(TclFetchIntRep(srcPtr, &properByteArrayType));
length = srcArrayPtr->used;
copyArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length));
copyArrayPtr->bad = length;
copyArrayPtr->used = length;
copyArrayPtr->allocated = length;
memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length);
SET_BYTEARRAY(&ir, copyArrayPtr);
Tcl_StoreIntRep(copyPtr, &properByteArrayType, &ir);
}
|
| ︙ | ︙ | |||
686 687 688 689 690 691 692 |
UpdateStringOfByteArray(
Tcl_Obj *objPtr) /* ByteArray object whose string rep to
* update. */
{
const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
ByteArray *byteArrayPtr = GET_BYTEARRAY(irPtr);
unsigned char *src = byteArrayPtr->bytes;
| | | | > > > | 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 |
UpdateStringOfByteArray(
Tcl_Obj *objPtr) /* ByteArray object whose string rep to
* update. */
{
const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
ByteArray *byteArrayPtr = GET_BYTEARRAY(irPtr);
unsigned char *src = byteArrayPtr->bytes;
unsigned int i, length = byteArrayPtr->used;
unsigned int size = length;
/*
* How much space will string rep need?
*/
for (i = 0; i < length && size <= INT_MAX; i++) {
if ((src[i] == 0) || (src[i] > 127)) {
size++;
}
}
if (size > INT_MAX) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
if (size == length) {
char *dst = Tcl_InitStringRep(objPtr, (char *)src, size);
TclOOM(dst, size);
} else {
char *dst = Tcl_InitStringRep(objPtr, NULL, size);
|
| ︙ | ︙ | |||
737 738 739 740 741 742 743 |
*----------------------------------------------------------------------
*/
void
TclAppendBytesToByteArray(
Tcl_Obj *objPtr,
const unsigned char *bytes,
| | | | > > | | | | | | | | | | | | > | 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 |
*----------------------------------------------------------------------
*/
void
TclAppendBytesToByteArray(
Tcl_Obj *objPtr,
const unsigned char *bytes,
int len)
{
ByteArray *byteArrayPtr;
unsigned int length, needed;
Tcl_ObjIntRep *irPtr;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray");
}
if (len < 0) {
Tcl_Panic("%s must be called with definite number of bytes to append",
"TclAppendBytesToByteArray");
}
if (len == 0) {
/*
* Append zero bytes is a no-op.
*/
return;
}
length = (unsigned int) len;
irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
if (irPtr == NULL) {
irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
if (irPtr == NULL) {
SetByteArrayFromAny(NULL, objPtr);
irPtr = TclFetchIntRep(objPtr, &properByteArrayType);
if (irPtr == NULL) {
irPtr = TclFetchIntRep(objPtr, &tclByteArrayType);
}
}
}
byteArrayPtr = GET_BYTEARRAY(irPtr);
if (length > INT_MAX - byteArrayPtr->used) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
needed = byteArrayPtr->used + length;
/*
* If we need to, resize the allocated space in the byte array.
*/
if (needed > byteArrayPtr->allocated) {
ByteArray *ptr = NULL;
unsigned int attempt;
if (needed <= INT_MAX/2) {
/*
* Try to allocate double the total space that is needed.
*/
attempt = 2 * needed;
ptr = (ByteArray *)attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
}
if (ptr == NULL) {
/*
* Try to allocate double the increment that is needed (plus).
*/
unsigned int limit = INT_MAX - needed;
unsigned int extra = length + TCL_MIN_GROWTH;
int growth = (int) ((extra > limit) ? limit : extra);
attempt = needed + growth;
ptr = (ByteArray *)attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
}
if (ptr == NULL) {
/*
* Last chance: Try to allocate exactly what is needed.
*/
attempt = needed;
ptr = (ByteArray *)ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
}
byteArrayPtr = ptr;
byteArrayPtr->allocated = attempt;
SET_BYTEARRAY(irPtr, byteArrayPtr);
}
if (bytes) {
memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, length);
}
byteArrayPtr->used += length;
TclInvalidateStringRep(objPtr);
objPtr->typePtr = &properByteArrayType;
}
/*
*----------------------------------------------------------------------
*
* TclInitBinaryCmd --
*
|
| ︙ | ︙ | |||
871 872 873 874 875 876 877 | * See the user documentation. * *---------------------------------------------------------------------- */ static int BinaryFormatCmd( | | | | < | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
BinaryFormatCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int arg; /* Index of next argument to consume. */
int value = 0; /* Current integer value to be packed.
* Initialized to avoid compiler warning. */
char cmd; /* Current format character. */
int count; /* Count associated with current format
* character. */
int flags; /* Format field flags */
const char *format; /* Pointer to current position in format
* string. */
Tcl_Obj *resultPtr = NULL; /* Object holding result buffer. */
unsigned char *buffer; /* Start of result buffer. */
unsigned char *cursor; /* Current position within result buffer. */
unsigned char *maxPos; /* Greatest position within result buffer that
* cursor has visited.*/
const char *errorString;
const char *errorValue, *str;
int offset, size, length;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg ...?");
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
932 933 934 935 936 937 938 |
* of bytes in a single argument.
*/
if (arg >= objc) {
goto badIndex;
}
if (count == BINARY_ALL) {
| | | 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 |
* of bytes in a single argument.
*/
if (arg >= objc) {
goto badIndex;
}
if (count == BINARY_ALL) {
Tcl_GetByteArrayFromObj(objv[arg], &count);
} else if (count == BINARY_NOCOUNT) {
count = 1;
}
arg++;
if (cmd == 'a' || cmd == 'A') {
offset += count;
} else if (cmd == 'b' || cmd == 'B') {
|
| ︙ | ︙ | |||
1004 1005 1006 1007 1008 1009 1010 |
&listv) != TCL_OK) {
return TCL_ERROR;
}
arg++;
if (count == BINARY_ALL) {
count = listc;
| | | 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 |
&listv) != TCL_OK) {
return TCL_ERROR;
}
arg++;
if (count == BINARY_ALL) {
count = listc;
} else if (count > listc) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"number of elements in list does not match count",
-1));
return TCL_ERROR;
}
}
offset += count*size;
|
| ︙ | ︙ | |||
1028 1029 1030 1031 1032 1033 1034 |
}
offset += count;
break;
case 'X':
if (count == BINARY_NOCOUNT) {
count = 1;
}
| | | | | | 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 |
}
offset += count;
break;
case 'X':
if (count == BINARY_NOCOUNT) {
count = 1;
}
if ((count > offset) || (count == BINARY_ALL)) {
count = offset;
}
if (offset > length) {
length = offset;
}
offset -= count;
break;
case '@':
if (offset > length) {
length = offset;
}
if (count == BINARY_ALL) {
offset = length;
} else if (count == BINARY_NOCOUNT) {
goto badCount;
} else {
offset = count;
}
break;
default:
errorString = str;
goto badField;
}
}
if (offset > length) {
length = offset;
}
if (length == 0) {
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
1096 1097 1098 1099 1100 1101 1102 |
}
switch (cmd) {
case 'a':
case 'A': {
char pad = (char) (cmd == 'a' ? '\0' : ' ');
unsigned char *bytes;
| | | | 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 |
}
switch (cmd) {
case 'a':
case 'A': {
char pad = (char) (cmd == 'a' ? '\0' : ' ');
unsigned char *bytes;
bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length);
if (count == BINARY_ALL) {
count = length;
} else if (count == BINARY_NOCOUNT) {
count = 1;
}
if (length >= count) {
memcpy(cursor, bytes, count);
|
| ︙ | ︙ | |||
1130 1131 1132 1133 1134 1135 1136 |
last = cursor + ((count + 7) / 8);
if (count > length) {
count = length;
}
value = 0;
errorString = "binary";
if (cmd == 'B') {
| | | | 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 |
last = cursor + ((count + 7) / 8);
if (count > length) {
count = length;
}
value = 0;
errorString = "binary";
if (cmd == 'B') {
for (offset = 0; offset < count; offset++) {
value <<= 1;
if (str[offset] == '1') {
value |= 1;
} else if (str[offset] != '0') {
errorValue = str;
Tcl_DecrRefCount(resultPtr);
goto badValue;
}
if (((offset + 1) % 8) == 0) {
*cursor++ = UCHAR(value);
value = 0;
}
}
} else {
for (offset = 0; offset < count; offset++) {
value >>= 1;
if (str[offset] == '1') {
value |= 128;
} else if (str[offset] != '0') {
errorValue = str;
Tcl_DecrRefCount(resultPtr);
goto badValue;
|
| ︙ | ︙ | |||
1192 1193 1194 1195 1196 1197 1198 |
last = cursor + ((count + 1) / 2);
if (count > length) {
count = length;
}
value = 0;
errorString = "hexadecimal";
if (cmd == 'H') {
| | | | | | | 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 |
last = cursor + ((count + 1) / 2);
if (count > length) {
count = length;
}
value = 0;
errorString = "hexadecimal";
if (cmd == 'H') {
for (offset = 0; offset < count; offset++) {
value <<= 4;
if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
errorValue = str;
Tcl_DecrRefCount(resultPtr);
goto badValue;
}
c = str[offset] - '0';
if (c > 9) {
c += ('0' - 'A') + 10;
}
if (c > 16) {
c += ('A' - 'a');
}
value |= (c & 0xF);
if (offset % 2) {
*cursor++ = (char) value;
value = 0;
}
}
} else {
for (offset = 0; offset < count; offset++) {
value >>= 4;
if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
errorValue = str;
Tcl_DecrRefCount(resultPtr);
goto badValue;
}
c = str[offset] - '0';
if (c > 9) {
c += ('0' - 'A') + 10;
}
if (c > 16) {
c += ('A' - 'a');
}
value |= ((c << 4) & 0xF0);
if (offset % 2) {
*cursor++ = UCHAR(value & 0xFF);
value = 0;
}
}
}
if (offset % 2) {
if (cmd == 'H') {
value <<= 4;
|
| ︙ | ︙ | |||
1284 1285 1286 1287 1288 1289 1290 |
} else {
TclListObjGetElements(interp, objv[arg], &listc, &listv);
if (count == BINARY_ALL) {
count = listc;
}
}
arg++;
| | | 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 |
} else {
TclListObjGetElements(interp, objv[arg], &listc, &listv);
if (count == BINARY_ALL) {
count = listc;
}
}
arg++;
for (i = 0; i < count; i++) {
if (FormatNumber(interp, cmd, listv[i], &cursor) != TCL_OK) {
Tcl_DecrRefCount(resultPtr);
return TCL_ERROR;
}
}
break;
}
|
| ︙ | ︙ | |||
1306 1307 1308 1309 1310 1311 1312 |
case 'X':
if (cursor > maxPos) {
maxPos = cursor;
}
if (count == BINARY_NOCOUNT) {
count = 1;
}
| | | 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 |
case 'X':
if (cursor > maxPos) {
maxPos = cursor;
}
if (count == BINARY_NOCOUNT) {
count = 1;
}
if ((count == BINARY_ALL) || (count > (cursor - buffer))) {
cursor = buffer;
} else {
cursor -= count;
}
break;
case '@':
if (cursor > maxPos) {
|
| ︙ | ︙ | |||
1345 1346 1347 1348 1349 1350 1351 |
badIndex:
errorString = "not enough arguments for all format specifiers";
goto error;
badField:
{
Tcl_UniChar ch = 0;
| | | 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 |
badIndex:
errorString = "not enough arguments for all format specifiers";
goto error;
badField:
{
Tcl_UniChar ch = 0;
char buf[5] = "";
TclUtfToUniChar(errorString, &ch);
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad field specifier \"%s\"", buf));
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1377 1378 1379 1380 1381 1382 1383 | * See the user documentation. * *---------------------------------------------------------------------- */ int BinaryScanCmd( | | | | < < | | 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
BinaryScanCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int arg; /* Index of next argument to consume. */
int value = 0; /* Current integer value to be packed.
* Initialized to avoid compiler warning. */
char cmd; /* Current format character. */
int count; /* Count associated with current format
* character. */
int flags; /* Format field flags */
const char *format; /* Pointer to current position in format
* string. */
Tcl_Obj *resultPtr = NULL; /* Object holding result buffer. */
unsigned char *buffer; /* Start of result buffer. */
const char *errorString;
const char *str;
int offset, size, length, i;
Tcl_Obj *valuePtr, *elementPtr;
Tcl_HashTable numberCacheHash;
Tcl_HashTable *numberCachePtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
"value formatString ?varName ...?");
return TCL_ERROR;
}
numberCachePtr = &numberCacheHash;
Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS);
buffer = Tcl_GetByteArrayFromObj(objv[1], &length);
format = TclGetString(objv[2]);
arg = 3;
offset = 0;
while (*format != '\0') {
str = format;
flags = 0;
if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
|
| ︙ | ︙ | |||
1435 1436 1437 1438 1439 1440 1441 |
}
if (count == BINARY_ALL) {
count = length - offset;
} else {
if (count == BINARY_NOCOUNT) {
count = 1;
}
| | | 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 |
}
if (count == BINARY_ALL) {
count = length - offset;
} else {
if (count == BINARY_NOCOUNT) {
count = 1;
}
if (count > (length - offset)) {
goto done;
}
}
src = buffer + offset;
size = count;
|
| ︙ | ︙ | |||
1494 1495 1496 1497 1498 1499 1500 |
}
if (count == BINARY_ALL) {
count = (length - offset) * 8;
} else {
if (count == BINARY_NOCOUNT) {
count = 1;
}
| | | | | 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 |
}
if (count == BINARY_ALL) {
count = (length - offset) * 8;
} else {
if (count == BINARY_NOCOUNT) {
count = 1;
}
if (count > (length - offset) * 8) {
goto done;
}
}
src = buffer + offset;
valuePtr = Tcl_NewObj();
Tcl_SetObjLength(valuePtr, count);
dest = TclGetString(valuePtr);
if (cmd == 'b') {
for (i = 0; i < count; i++) {
if (i % 8) {
value >>= 1;
} else {
value = *src++;
}
*dest++ = (char) ((value & 1) ? '1' : '0');
}
} else {
for (i = 0; i < count; i++) {
if (i % 8) {
value <<= 1;
} else {
value = *src++;
}
*dest++ = (char) ((value & 0x80) ? '1' : '0');
}
|
| ︙ | ︙ | |||
1559 1560 1561 1562 1563 1564 1565 |
}
src = buffer + offset;
valuePtr = Tcl_NewObj();
Tcl_SetObjLength(valuePtr, count);
dest = TclGetString(valuePtr);
if (cmd == 'h') {
| | | | | | 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 |
}
src = buffer + offset;
valuePtr = Tcl_NewObj();
Tcl_SetObjLength(valuePtr, count);
dest = TclGetString(valuePtr);
if (cmd == 'h') {
for (i = 0; i < count; i++) {
if (i % 2) {
value >>= 4;
} else {
value = *src++;
}
*dest++ = hexdigit[value & 0xF];
}
} else {
for (i = 0; i < count; i++) {
if (i % 2) {
value <<= 4;
} else {
value = *src++;
}
*dest++ = hexdigit[(value >> 4) & 0xF];
}
}
resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
TCL_LEAVE_ERR_MSG);
arg++;
if (resultPtr == NULL) {
|
| ︙ | ︙ | |||
1625 1626 1627 1628 1629 1630 1631 |
scanNumber:
if (arg >= objc) {
DeleteScanNumberCache(numberCachePtr);
goto badIndex;
}
if (count == BINARY_NOCOUNT) {
| | | | | | 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 |
scanNumber:
if (arg >= objc) {
DeleteScanNumberCache(numberCachePtr);
goto badIndex;
}
if (count == BINARY_NOCOUNT) {
if ((length - offset) < size) {
goto done;
}
valuePtr = ScanNumber(buffer+offset, cmd, flags,
&numberCachePtr);
offset += size;
} else {
if (count == BINARY_ALL) {
count = (length - offset) / size;
}
if ((length - offset) < (count * size)) {
goto done;
}
valuePtr = Tcl_NewObj();
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;
}
resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
TCL_LEAVE_ERR_MSG);
arg++;
if (resultPtr == NULL) {
DeleteScanNumberCache(numberCachePtr);
return TCL_ERROR;
}
break;
}
case 'x':
if (count == BINARY_NOCOUNT) {
count = 1;
}
if ((count == BINARY_ALL) || (count > (length - offset))) {
offset = length;
} else {
offset += count;
}
break;
case 'X':
if (count == BINARY_NOCOUNT) {
count = 1;
}
if ((count == BINARY_ALL) || (count > offset)) {
offset = 0;
} else {
offset -= count;
}
break;
case '@':
if (count == BINARY_NOCOUNT) {
|
| ︙ | ︙ | |||
1716 1717 1718 1719 1720 1721 1722 |
badIndex:
errorString = "not enough arguments for all format specifiers";
goto error;
badField:
{
Tcl_UniChar ch = 0;
| | | 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 |
badIndex:
errorString = "not enough arguments for all format specifiers";
goto error;
badField:
{
Tcl_UniChar ch = 0;
char buf[5] = "";
TclUtfToUniChar(errorString, &ch);
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad field specifier \"%s\"", buf));
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1755 1756 1757 1758 1759 1760 1761 |
*----------------------------------------------------------------------
*/
static int
GetFormatSpec(
const char **formatPtr, /* Pointer to format string. */
char *cmdPtr, /* Pointer to location of command char. */
| | | 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 |
*----------------------------------------------------------------------
*/
static int
GetFormatSpec(
const char **formatPtr, /* Pointer to format string. */
char *cmdPtr, /* Pointer to location of command char. */
int *countPtr, /* Pointer to repeat count value. */
int *flagsPtr) /* Pointer to field flags */
{
/*
* Skip any leading blanks.
*/
while (**formatPtr == ' ') {
|
| ︙ | ︙ | |||
1921 1922 1923 1924 1925 1926 1927 |
*----------------------------------------------------------------------
*/
static void
CopyNumber(
const void *from, /* source */
void *to, /* destination */
| | | | | 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 |
*----------------------------------------------------------------------
*/
static void
CopyNumber(
const void *from, /* source */
void *to, /* destination */
unsigned length, /* Number of bytes to copy */
int type) /* What type of thing are we copying? */
{
switch (NeedReversing(type)) {
case 0:
memcpy(to, from, length);
break;
case 1: {
const unsigned char *fromPtr = (const unsigned char *)from;
unsigned char *toPtr = (unsigned char *)to;
switch (length) {
case 4:
toPtr[0] = fromPtr[3];
toPtr[1] = fromPtr[2];
toPtr[2] = fromPtr[1];
toPtr[3] = fromPtr[0];
|
| ︙ | ︙ | |||
1953 1954 1955 1956 1957 1958 1959 |
toPtr[6] = fromPtr[1];
toPtr[7] = fromPtr[0];
break;
}
break;
}
case 2: {
| | | | | | 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 |
toPtr[6] = fromPtr[1];
toPtr[7] = fromPtr[0];
break;
}
break;
}
case 2: {
const unsigned char *fromPtr = (const unsigned char *)from;
unsigned char *toPtr = (unsigned char *)to;
toPtr[0] = fromPtr[4];
toPtr[1] = fromPtr[5];
toPtr[2] = fromPtr[6];
toPtr[3] = fromPtr[7];
toPtr[4] = fromPtr[0];
toPtr[5] = fromPtr[1];
toPtr[6] = fromPtr[2];
toPtr[7] = fromPtr[3];
break;
}
case 3: {
const unsigned char *fromPtr = (const unsigned char *)from;
unsigned char *toPtr = (unsigned char *)to;
toPtr[0] = fromPtr[3];
toPtr[1] = fromPtr[2];
toPtr[2] = fromPtr[1];
toPtr[3] = fromPtr[0];
toPtr[4] = fromPtr[7];
toPtr[5] = fromPtr[6];
|
| ︙ | ︙ | |||
2271 2272 2273 2274 2275 2276 2277 |
value -= (((unsigned) 1) << 31);
}
returnNumericObject:
if (*numberCachePtrPtr == NULL) {
return Tcl_NewWideIntObj(value);
} else {
| | | | | | 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 |
value -= (((unsigned) 1) << 31);
}
returnNumericObject:
if (*numberCachePtrPtr == NULL) {
return Tcl_NewWideIntObj(value);
} else {
Tcl_HashTable *tablePtr = *numberCachePtrPtr;
Tcl_HashEntry *hPtr;
int isNew;
hPtr = Tcl_CreateHashEntry(tablePtr, INT2PTR(value), &isNew);
if (!isNew) {
return (Tcl_Obj *)Tcl_GetHashValue(hPtr);
}
if (tablePtr->numEntries <= BINARY_SCAN_MAX_CACHE) {
Tcl_Obj *objPtr = Tcl_NewWideIntObj(value);
Tcl_IncrRefCount(objPtr);
Tcl_SetHashValue(hPtr, objPtr);
return objPtr;
}
/*
|
| ︙ | ︙ | |||
2332 2333 2334 2335 2336 2337 2338 |
| (((Tcl_WideUInt) buffer[1]) << 48)
| (((Tcl_WideUInt) buffer[0]) << 56);
}
if (flags & BINARY_UNSIGNED) {
Tcl_Obj *bigObj = NULL;
mp_int big;
| | | > | 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 |
| (((Tcl_WideUInt) buffer[1]) << 48)
| (((Tcl_WideUInt) buffer[0]) << 56);
}
if (flags & BINARY_UNSIGNED) {
Tcl_Obj *bigObj = NULL;
mp_int big;
if (mp_init_u64(&big, uwvalue) == MP_OKAY) {
bigObj = Tcl_NewBignumObj(&big);
}
return bigObj;
}
return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
/*
* Do not cache double values; they are already too large to use as
* keys and the values stored are utterly incompatible with the
|
| ︙ | ︙ | |||
2399 2400 2401 2402 2403 2404 2405 |
if (numberCachePtr == NULL) {
return;
}
hEntry = Tcl_FirstHashEntry(numberCachePtr, &search);
while (hEntry != NULL) {
| | | 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 |
if (numberCachePtr == NULL) {
return;
}
hEntry = Tcl_FirstHashEntry(numberCachePtr, &search);
while (hEntry != NULL) {
Tcl_Obj *value = (Tcl_Obj *)Tcl_GetHashValue(hEntry);
if (value != NULL) {
Tcl_DecrRefCount(value);
}
hEntry = Tcl_NextHashEntry(&search);
}
Tcl_DeleteHashTable(numberCachePtr);
|
| ︙ | ︙ | |||
2445 2446 2447 2448 2449 2450 2451 | * None * *---------------------------------------------------------------------- */ static int BinaryEncodeHex( | | | | | | | 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 |
* None
*
*----------------------------------------------------------------------
*/
static int
BinaryEncodeHex(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data = NULL;
unsigned char *cursor = NULL;
int offset = 0, count = 0;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "data");
return TCL_ERROR;
}
TclNewObj(resultObj);
data = Tcl_GetByteArrayFromObj(objv[1], &count);
cursor = Tcl_SetByteArrayLength(resultObj, count * 2);
for (offset = 0; offset < count; ++offset) {
*cursor++ = HexDigits[(data[offset] >> 4) & 0x0F];
*cursor++ = HexDigits[data[offset] & 0x0F];
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2489 2490 2491 2492 2493 2494 2495 | * None * *---------------------------------------------------------------------- */ static int BinaryDecodeHex( | | | | > | > | > > | 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 |
* None
*
*----------------------------------------------------------------------
*/
static int
BinaryDecodeHex(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend;
unsigned char *begin, *cursor, c;
int i, index, value, size, pure = 1, count = 0, cut = 0, strict = 0;
int ucs4;
enum {OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
return TCL_ERROR;
}
for (i = 1; i < objc - 1; ++i) {
if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_STRICT:
strict = 1;
break;
}
}
TclNewObj(resultObj);
data = TclGetBytesFromObj(NULL, objv[objc - 1], &count);
if (data == NULL) {
pure = 0;
data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
}
datastart = data;
dataend = data + count;
size = (count + 1) / 2;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
while (data < dataend) {
value = 0;
for (i = 0 ; i < 2 ; i++) {
if (data >= dataend) {
|
| ︙ | ︙ | |||
2549 2550 2551 2552 2553 2554 2555 |
c -= '0';
if (c > 9) {
c += ('0' - 'A') + 10;
}
if (c > 16) {
c += ('A' - 'a');
}
| | > > > > > | | > < < < | | < < < | 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 |
c -= '0';
if (c > 9) {
c += ('0' - 'A') + 10;
}
if (c > 16) {
c += ('A' - 'a');
}
value |= c & 0xF;
}
if (i < 2) {
cut++;
}
*cursor++ = UCHAR(value);
value = 0;
}
if (cut > size) {
cut = size;
}
Tcl_SetByteArrayLength(resultObj, cursor - begin - cut);
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
badChar:
if (pure) {
ucs4 = c;
} else {
TclUtfToUCS4((const char *)(data - 1), &ucs4);
}
TclDecrRefCount(resultObj);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid hexadecimal digit \"%c\" (U+%06X) at position %d",
ucs4, ucs4, (int) (data - datastart - 1)));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* BinaryEncode64 --
*
* This procedure implements the "binary encode base64" Tcl command.
*
* Results:
* The base64 encoded value prescribed by the input arguments.
*
*----------------------------------------------------------------------
*/
#define OUTPUT(c) \
do { \
*cursor++ = (c); \
|
| ︙ | ︙ | |||
2609 2610 2611 2612 2613 2614 2615 |
if (cursor > limit) { \
Tcl_Panic("limit hit"); \
} \
} while (0)
static int
BinaryEncode64(
| | | | | < | 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 |
if (cursor > limit) { \
Tcl_Panic("limit hit"); \
} \
} while (0)
static int
BinaryEncode64(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj;
unsigned char *data, *limit;
int maxlen = 0;
const char *wrapchar = "\n";
int wrapcharlen = 1;
int offset, i, index, size, outindex = 0, count = 0, purewrap = 1;
enum { OPT_MAXLEN, OPT_WRAPCHAR };
static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL };
if (objc < 2 || objc % 2 != 0) {
Tcl_WrongNumArgs(interp, 1, objv,
"?-maxlen len? ?-wrapchar char? data");
return TCL_ERROR;
|
| ︙ | ︙ | |||
2648 2649 2650 2651 2652 2653 2654 | "line length out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", "LINE_LENGTH", NULL); return TCL_ERROR; } break; case OPT_WRAPCHAR: | > | | | > > > | > | > > | > > > > > > > > | > | | | 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 |
"line length out of range", -1));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE",
"LINE_LENGTH", NULL);
return TCL_ERROR;
}
break;
case OPT_WRAPCHAR:
wrapchar = (const char *)TclGetBytesFromObj(NULL,
objv[i + 1], &wrapcharlen);
if (wrapchar == NULL) {
purewrap = 0;
wrapchar = TclGetStringFromObj(objv[i + 1], &wrapcharlen);
}
break;
}
}
if (wrapcharlen == 0) {
maxlen = 0;
}
resultObj = Tcl_NewObj();
data = Tcl_GetByteArrayFromObj(objv[objc - 1], &count);
if (count > 0) {
unsigned char *cursor = NULL;
size = (((count * 4) / 3) + 3) & ~3; /* ensure 4 byte chunks */
if (maxlen > 0 && size > maxlen) {
int adjusted = size + (wrapcharlen * (size / maxlen));
if (size % maxlen == 0) {
adjusted -= wrapcharlen;
}
size = adjusted;
if (purewrap == 0) {
/* Wrapchar is (possibly) non-byte, so build result as
* general string, not bytearray */
Tcl_SetObjLength(resultObj, size);
cursor = (unsigned char *) TclGetString(resultObj);
}
}
if (cursor == NULL) {
cursor = Tcl_SetByteArrayLength(resultObj, size);
}
limit = cursor + size;
for (offset = 0; offset < count; offset += 3) {
unsigned char d[3] = {0, 0, 0};
for (i = 0; i < 3 && offset + i < count; ++i) {
d[i] = data[offset + i];
}
OUTPUT(B64Digits[d[0] >> 2]);
OUTPUT(B64Digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]);
if (offset + 1 < count) {
OUTPUT(B64Digits[((d[1] & 0x0F) << 2) | (d[2] >> 6)]);
} else {
OUTPUT(B64Digits[64]);
}
if (offset+2 < count) {
OUTPUT(B64Digits[d[2] & 0x3F]);
} else {
OUTPUT(B64Digits[64]);
}
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
|
| ︙ | ︙ | |||
2716 2717 2718 2719 2720 2721 2722 | * None * *---------------------------------------------------------------------- */ static int BinaryEncodeUu( | | | | | | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 |
* None
*
*----------------------------------------------------------------------
*/
static int
BinaryEncodeUu(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj;
unsigned char *data, *start, *cursor;
int offset, count, rawLength, n, i, j, bits, index;
int lineLength = 61;
const unsigned char SingleNewline[] = { UCHAR('\n') };
const unsigned char *wrapchar = SingleNewline;
int wrapcharlen = sizeof(SingleNewline);
enum { OPT_MAXLEN, OPT_WRAPCHAR };
static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL };
if (objc < 2 || objc % 2 != 0) {
Tcl_WrongNumArgs(interp, 1, objv,
"?-maxlen len? ?-wrapchar char? data");
return TCL_ERROR;
}
for (i = 1; i < objc - 1; i += 2) {
if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_MAXLEN:
if (Tcl_GetIntFromObj(interp, objv[i + 1],
&lineLength) != TCL_OK) {
return TCL_ERROR;
}
if (lineLength < 5 || lineLength > 85) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"line length out of range", -1));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE",
"LINE_LENGTH", NULL);
return TCL_ERROR;
}
lineLength = ((lineLength - 1) & -4) + 1; /* 5, 9, 13 ... */
break;
case OPT_WRAPCHAR:
wrapchar = (const unsigned char *) TclGetStringFromObj(
objv[i + 1], &wrapcharlen);
{
const unsigned char *p = wrapchar;
int numBytes = wrapcharlen;
while (numBytes) {
switch (*p) {
case '\t':
case '\v':
case '\f':
case '\r':
p++; numBytes--;
continue;
case '\n':
numBytes--;
break;
default:
badwrap:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"invalid wrapchar; will defeat decoding",
-1));
Tcl_SetErrorCode(interp, "TCL", "BINARY",
"ENCODE", "WRAPCHAR", NULL);
return TCL_ERROR;
}
}
if (numBytes) {
goto badwrap;
}
}
break;
}
}
/*
* Allocate the buffer. This is a little bit too long, but is "good
* enough".
*/
resultObj = Tcl_NewObj();
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;
/*
|
| ︙ | ︙ | |||
2793 2794 2795 2796 2797 2798 2799 |
lineLen = rawLength;
}
*cursor++ = UueDigits[lineLen];
for (i = 0 ; i < lineLen ; i++) {
n <<= 8;
n |= data[offset++];
for (bits += 8; bits > 6 ; bits -= 6) {
| | | | 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 |
lineLen = rawLength;
}
*cursor++ = UueDigits[lineLen];
for (i = 0 ; i < lineLen ; i++) {
n <<= 8;
n |= data[offset++];
for (bits += 8; bits > 6 ; bits -= 6) {
*cursor++ = UueDigits[(n >> (bits - 6)) & 0x3F];
}
}
if (bits > 0) {
n <<= 8;
*cursor++ = UueDigits[(n >> (bits + 2)) & 0x3F];
bits = 0;
}
for (j = 0 ; j < wrapcharlen ; ++j) {
*cursor++ = wrapchar[j];
}
}
|
| ︙ | ︙ | |||
2833 2834 2835 2836 2837 2838 2839 | * None * *---------------------------------------------------------------------- */ static int BinaryDecodeUu( | | | < > > | > | > > | 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 |
* None
*
*----------------------------------------------------------------------
*/
static int
BinaryDecodeUu(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend;
unsigned char *begin, *cursor;
int i, index, size, pure = 1, count = 0, strict = 0, lineLen;
unsigned char c;
int ucs4;
enum { OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
return TCL_ERROR;
}
for (i = 1; i < objc - 1; ++i) {
if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_STRICT:
strict = 1;
break;
}
}
TclNewObj(resultObj);
data = TclGetBytesFromObj(NULL, objv[objc - 1], &count);
if (data == NULL) {
pure = 0;
data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
}
datastart = data;
dataend = data + count;
size = ((count + 3) & ~3) * 3 / 4;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
lineLen = -1;
/*
* The decoding loop. First, we get the length of line (strictly, the
|
| ︙ | ︙ | |||
2890 2891 2892 2893 2894 2895 2896 |
if (c < 32 || c > 96) {
if (strict || !TclIsSpaceProc(c)) {
goto badUu;
}
i--;
continue;
}
| | | 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 |
if (c < 32 || c > 96) {
if (strict || !TclIsSpaceProc(c)) {
goto badUu;
}
i--;
continue;
}
lineLen = (c - 32) & 0x3F;
}
/*
* Now we read a four-character grouping.
*/
for (i = 0 ; i < 4 ; i++) {
|
| ︙ | ︙ | |||
2919 2920 2921 2922 2923 2924 2925 |
}
/*
* Translate that grouping into (up to) three binary bytes output.
*/
if (lineLen > 0) {
| | | | | | | | 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 |
}
/*
* Translate that grouping into (up to) three binary bytes output.
*/
if (lineLen > 0) {
*cursor++ = (((d[0] - 0x20) & 0x3F) << 2)
| (((d[1] - 0x20) & 0x3F) >> 4);
if (--lineLen > 0) {
*cursor++ = (((d[1] - 0x20) & 0x3F) << 4)
| (((d[2] - 0x20) & 0x3F) >> 2);
if (--lineLen > 0) {
*cursor++ = (((d[2] - 0x20) & 0x3F) << 6)
| (((d[3] - 0x20) & 0x3F));
lineLen--;
}
}
}
/*
* If we've reached the end of the line, skip until we process a
|
| ︙ | ︙ | |||
2971 2972 2973 2974 2975 2976 2977 2978 |
shortUu:
Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data"));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
badUu:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
| > > > > > | | | 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 |
shortUu:
Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data"));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
badUu:
if (pure) {
ucs4 = c;
} else {
TclUtfToUCS4((const char *)(data - 1), &ucs4);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid uuencode character \"%c\" (U+%06X) at position %d",
ucs4, ucs4, (int) (data - datastart - 1)));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2997 2998 2999 3000 3001 3002 3003 | * None * *---------------------------------------------------------------------- */ static int BinaryDecode64( | | | | | > | > | > > | 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 |
* None
*
*----------------------------------------------------------------------
*/
static int
BinaryDecode64(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *resultObj = NULL;
unsigned char *data, *datastart, *dataend, c = '\0';
unsigned char *begin = NULL;
unsigned char *cursor = NULL;
int pure = 1, strict = 0;
int i, index, size, cut = 0, count = 0;
int ucs4;
enum { OPT_STRICT };
static const char *const optStrings[] = { "-strict", NULL };
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?options? data");
return TCL_ERROR;
}
for (i = 1; i < objc - 1; ++i) {
if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case OPT_STRICT:
strict = 1;
break;
}
}
TclNewObj(resultObj);
data = TclGetBytesFromObj(NULL, objv[objc - 1], &count);
if (data == NULL) {
pure = 0;
data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count);
}
datastart = data;
dataend = data + count;
size = ((count + 3) & ~3) * 3 / 4;
begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
while (data < dataend) {
unsigned long value = 0;
/*
|
| ︙ | ︙ | |||
3080 3081 3082 3083 3084 3085 3086 |
* input whitespace characters.
*/
if (cut) {
if (c == '=' && i > 1) {
value <<= 6;
cut++;
| | | | | | | | | | | < < < < < > > > > > > > > > > > | | > | 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 |
* input whitespace characters.
*/
if (cut) {
if (c == '=' && i > 1) {
value <<= 6;
cut++;
} else if (!strict) {
i--;
} else {
goto bad64;
}
} else if (c >= 'A' && c <= 'Z') {
value = (value << 6) | ((c - 'A') & 0x3F);
} else if (c >= 'a' && c <= 'z') {
value = (value << 6) | ((c - 'a' + 26) & 0x3F);
} else if (c >= '0' && c <= '9') {
value = (value << 6) | ((c - '0' + 52) & 0x3F);
} else if (c == '+') {
value = (value << 6) | 0x3E;
} else if (c == '/') {
value = (value << 6) | 0x3F;
} else if (c == '=' && (!strict || i > 1)) {
/*
* "=" and "a=" is rather bad64 error case in strict mode.
*/
value <<= 6;
if (i) {
cut++;
}
} else if (strict) {
goto bad64;
} else {
i--;
}
}
*cursor++ = UCHAR((value >> 16) & 0xFF);
*cursor++ = UCHAR((value >> 8) & 0xFF);
*cursor++ = UCHAR(value & 0xFF);
/*
* Since = is only valid within the final block, if it was encountered
* but there are still more input characters, confirm that strict mode
* is off and all subsequent characters are whitespace.
*/
if (cut && data < dataend) {
if (strict) {
goto bad64;
}
}
}
Tcl_SetByteArrayLength(resultObj, cursor - begin - cut);
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
bad64:
if (pure) {
ucs4 = c;
} else {
/* The decoder is byte-oriented. If we saw a byte that's not a
* valid member of the base64 alphabet, it could be the lead byte
* of a multi-byte character. */
/* Safe because we know data is NUL-terminated */
TclUtfToUCS4((const char *)(data - 1), &ucs4);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid base64 character \"%c\" (U+%06X) at position %d",
ucs4, ucs4, (int) (data - datastart - 1)));
Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL);
TclDecrRefCount(resultObj);
return TCL_ERROR;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclCkalloc.c.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | */ #include "tclInt.h" #define FALSE 0 #define TRUE 1 #undef Tcl_Free #undef Tcl_AttemptAlloc #undef Tcl_AttemptRealloc #ifdef TCL_MEM_DEBUG /* * One of the following structures is allocated each time the * "memory tag" command is invoked, to hold the current tag. */ | > > | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
*/
#include "tclInt.h"
#define FALSE 0
#define TRUE 1
#undef Tcl_Alloc
#undef Tcl_Free
#undef Tcl_Realloc
#undef Tcl_AttemptAlloc
#undef Tcl_AttemptRealloc
#ifdef TCL_MEM_DEBUG
/*
* One of the following structures is allocated each time the
* "memory tag" command is invoked, to hold the current tag.
*/
typedef struct MemTag {
size_t refCount; /* Number of mem_headers referencing this
* tag. */
char string[1]; /* Actual size of string will be as large as
* needed for actual tag. This must be the
* last field in the structure. */
} MemTag;
|
| ︙ | ︙ | |||
115 116 117 118 119 120 121 | static char *onExitMemDumpFileName = NULL; static char dumpFile[100]; /* Records where to dump memory allocation * information. */ /* * Mutex to serialize allocations. This is a low-level mutex that must be * explicitly initialized. This is necessary because the self initializing | | | > | | > | | | 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 |
static char *onExitMemDumpFileName = NULL;
static char dumpFile[100]; /* Records where to dump memory allocation
* information. */
/*
* Mutex to serialize allocations. This is a low-level mutex that must be
* explicitly initialized. This is necessary because the self initializing
* mutexes use ckalloc...
*/
static Tcl_Mutex *ckallocMutexPtr;
static int ckallocInit = 0;
/*
* Prototypes for procedures defined in this file:
*/
static int CheckmemCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int MemoryCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static void ValidateMemory(struct mem_header *memHeaderP,
const char *file, int line, int nukeGuards);
/*
*----------------------------------------------------------------------
*
* TclInitDbCkalloc --
*
* Initialize the locks used by the allocator. This is only appropriate
* to call in a single threaded environment, such as during
* Tcl_InitSubsystems.
*
*----------------------------------------------------------------------
*/
void
TclInitDbCkalloc(void)
{
|
| ︙ | ︙ | |||
238 239 240 241 242 243 244 |
int byte;
for (idx = 0; idx < LOW_GUARD_SIZE; idx++) {
byte = *(memHeaderP->low_guard + idx);
if (byte != GUARD_VALUE) {
guard_failed = TRUE;
fflush(stdout);
| | | | | | | | 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 |
int byte;
for (idx = 0; idx < LOW_GUARD_SIZE; idx++) {
byte = *(memHeaderP->low_guard + idx);
if (byte != GUARD_VALUE) {
guard_failed = TRUE;
fflush(stdout);
byte &= 0xFF;
fprintf(stderr, "low guard byte %d is 0x%x \t%c\n", (int)idx, byte,
(isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
}
}
if (guard_failed) {
TclDumpMemoryInfo((ClientData) stderr, 0);
fprintf(stderr, "low guard failed at %p, %s %d\n",
memHeaderP->body, file, line);
fflush(stderr); /* In case name pointer is bad. */
fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n", memHeaderP->length,
memHeaderP->file, memHeaderP->line);
Tcl_Panic("Memory validation failure");
}
hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length;
for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) {
byte = *(hiPtr + idx);
if (byte != GUARD_VALUE) {
guard_failed = TRUE;
fflush(stdout);
byte &= 0xFF;
fprintf(stderr, "hi guard byte %d is 0x%x \t%c\n", (int)idx, byte,
(isprint(UCHAR(byte)) ? byte : ' ')); /* INTL: bytes */
}
}
if (guard_failed) {
TclDumpMemoryInfo((ClientData) stderr, 0);
fprintf(stderr, "high guard failed at %p, %s %d\n",
memHeaderP->body, file, line);
fflush(stderr); /* In case name pointer is bad. */
fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n",
memHeaderP->length, memHeaderP->file,
memHeaderP->line);
Tcl_Panic("Memory validation failure");
|
| ︙ | ︙ | |||
370 371 372 373 374 375 376 |
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| | | | | | | | 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 |
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DbCkalloc - debugging ckalloc
*
* Allocate the requested amount of space plus some extra for guard bands
* at both ends of the request, plus a size, panicing if there isn't
* enough space, then write in the guard bands and return the address of
* the space in the middle that the user asked for.
*
* The second and third arguments are file and line, these contain the
* filename and line number corresponding to the caller. These are sent
* by the ckalloc macro; it uses the preprocessor autodefines __FILE__
* and __LINE__.
*
*----------------------------------------------------------------------
*/
char *
Tcl_DbCkalloc(
unsigned int size,
const char *file,
int line)
{
struct mem_header *result = NULL;
if (validate_memory) {
Tcl_ValidateAllMemory(file, line);
}
/* Don't let size argument to TclpAlloc overflow */
if (size <= UINT_MAX - HIGH_GUARD_SIZE -sizeof(struct mem_header)) {
result = (struct mem_header *) TclpAlloc(size +
sizeof(struct mem_header) + HIGH_GUARD_SIZE);
}
if (result == NULL) {
fflush(stdout);
TclDumpMemoryInfo((ClientData) stderr, 0);
Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line);
}
/*
* Fill in guard zones and size. Also initialize the contents of the block
* with bogus bytes to detect uses of initialized data. Link into
* allocated list.
*/
|
| ︙ | ︙ | |||
451 452 453 454 455 456 457 |
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
trace_on_at_malloc = 0;
}
if (alloc_tracing) {
| | | 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 |
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
trace_on_at_malloc = 0;
}
if (alloc_tracing) {
fprintf(stderr,"ckalloc %p %u %s %d\n",
result->body, size, file, line);
}
if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
break_on_malloc = 0;
(void) fflush(stdout);
Tcl_Panic("reached malloc break limit (%u)", total_mallocs);
|
| ︙ | ︙ | |||
475 476 477 478 479 480 481 |
}
Tcl_MutexUnlock(ckallocMutexPtr);
return result->body;
}
| | | | | 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 |
}
Tcl_MutexUnlock(ckallocMutexPtr);
return result->body;
}
char *
Tcl_AttemptDbCkalloc(
unsigned int size,
const char *file,
int line)
{
struct mem_header *result = NULL;
if (validate_memory) {
Tcl_ValidateAllMemory(file, line);
}
/* Don't let size argument to TclpAlloc overflow */
if (size <= UINT_MAX - HIGH_GUARD_SIZE - sizeof(struct mem_header)) {
result = (struct mem_header *) TclpAlloc(size +
sizeof(struct mem_header) + HIGH_GUARD_SIZE);
}
if (result == NULL) {
fflush(stdout);
TclDumpMemoryInfo((ClientData) stderr, 0);
return NULL;
}
/*
* Fill in guard zones and size. Also initialize the contents of the block
* with bogus bytes to detect uses of initialized data. Link into
* allocated list.
|
| ︙ | ︙ | |||
540 541 542 543 544 545 546 |
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
trace_on_at_malloc = 0;
}
if (alloc_tracing) {
| | | 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 |
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
trace_on_at_malloc = 0;
}
if (alloc_tracing) {
fprintf(stderr,"ckalloc %p %u %s %d\n",
result->body, size, file, line);
}
if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
break_on_malloc = 0;
(void) fflush(stdout);
Tcl_Panic("reached malloc break limit (%d)", total_mallocs);
|
| ︙ | ︙ | |||
567 568 569 570 571 572 573 |
return result->body;
}
/*
*----------------------------------------------------------------------
*
| | | | | | | | | | | | 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 |
return result->body;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DbCkfree - debugging ckfree
*
* Verify that the low and high guards are intact, and if so then free
* the buffer else Tcl_Panic.
*
* The guards are erased after being checked to catch duplicate frees.
*
* The second and third arguments are file and line, these contain the
* filename and line number corresponding to the caller. These are sent
* by the ckfree macro; it uses the preprocessor autodefines __FILE__ and
* __LINE__.
*
*----------------------------------------------------------------------
*/
void
Tcl_DbCkfree(
char *ptr,
const char *file,
int line)
{
struct mem_header *memp;
if (ptr == NULL) {
return;
}
/*
* The following cast is *very* tricky. Must convert the pointer to an
* integer before doing arithmetic on it, because otherwise the arithmetic
* will be done differently (and incorrectly) on word-addressed machines
* such as Crays (will subtract only bytes, even though BODY_OFFSET is in
* words on these machines).
*/
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
if (alloc_tracing) {
fprintf(stderr, "ckfree %p %" TCL_Z_MODIFIER "u %s %d\n",
memp->body, memp->length, file, line);
}
if (validate_memory) {
Tcl_ValidateAllMemory(file, line);
}
Tcl_MutexLock(ckallocMutexPtr);
ValidateMemory(memp, file, line, TRUE);
if (init_malloced_bodies) {
memset(ptr, GUARD_VALUE, memp->length);
}
total_frees++;
current_malloc_packets--;
current_bytes_malloced -= memp->length;
if (memp->tagPtr != NULL) {
if ((memp->tagPtr->refCount-- <= 1) && (curTagPtr != memp->tagPtr)) {
TclpFree(memp->tagPtr);
}
}
/*
* Delink from allocated list
*/
if (memp->flink != NULL) {
memp->flink->blink = memp->blink;
}
if (memp->blink != NULL) {
memp->blink->flink = memp->flink;
}
if (allocHead == memp) {
allocHead = memp->flink;
}
TclpFree(memp);
Tcl_MutexUnlock(ckallocMutexPtr);
}
/*
*--------------------------------------------------------------------
*
* Tcl_DbCkrealloc - debugging ckrealloc
*
* Reallocate a chunk of memory by allocating a new one of the right
* size, copying the old data to the new location, and then freeing the
* old memory space, using all the memory checking features of this
* package.
*
*--------------------------------------------------------------------
*/
char *
Tcl_DbCkrealloc(
char *ptr,
unsigned int size,
const char *file,
int line)
{
char *newPtr;
size_t copySize;
struct mem_header *memp;
|
| ︙ | ︙ | |||
690 691 692 693 694 695 696 |
}
newPtr = Tcl_DbCkalloc(size, file, line);
memcpy(newPtr, ptr, copySize);
Tcl_DbCkfree(ptr, file, line);
return newPtr;
}
| | | | | 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 |
}
newPtr = Tcl_DbCkalloc(size, file, line);
memcpy(newPtr, ptr, copySize);
Tcl_DbCkfree(ptr, file, line);
return newPtr;
}
char *
Tcl_AttemptDbCkrealloc(
char *ptr,
unsigned int size,
const char *file,
int line)
{
char *newPtr;
size_t copySize;
struct mem_header *memp;
|
| ︙ | ︙ | |||
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 |
return newPtr;
}
/*
*----------------------------------------------------------------------
*
* MemoryCmd --
*
* Implements the Tcl "memory" command, which provides Tcl-level control
* of Tcl memory debugging information.
* memory active $file
* memory break_on_malloc $count
* memory info
* memory init on|off
* memory onexit $file
* memory tag $string
* memory trace on|off
* memory trace_on_at_malloc $count
* memory validate on|off
*
* Results:
* Standard TCL results.
*
*----------------------------------------------------------------------
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | | | | | < | | | < < | | | | | | | | | | | | < | | | | < | | | | < | | | | | | | | | | | | | | < | < > > > | | | | | < | | 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 |
return newPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Alloc, et al. --
*
* These functions are defined in terms of the debugging versions when
* TCL_MEM_DEBUG is set.
*
* Results:
* Same as the debug versions.
*
* Side effects:
* Same as the debug versions.
*
*----------------------------------------------------------------------
*/
char *
Tcl_Alloc(
unsigned int size)
{
return Tcl_DbCkalloc(size, "unknown", 0);
}
char *
Tcl_AttemptAlloc(
unsigned int size)
{
return Tcl_AttemptDbCkalloc(size, "unknown", 0);
}
void
Tcl_Free(
char *ptr)
{
Tcl_DbCkfree(ptr, "unknown", 0);
}
char *
Tcl_Realloc(
char *ptr,
unsigned int size)
{
return Tcl_DbCkrealloc(ptr, size, "unknown", 0);
}
char *
Tcl_AttemptRealloc(
char *ptr,
unsigned int size)
{
return Tcl_AttemptDbCkrealloc(ptr, size, "unknown", 0);
}
/*
*----------------------------------------------------------------------
*
* MemoryCmd --
*
* Implements the Tcl "memory" command, which provides Tcl-level control
* of Tcl memory debugging information.
* memory active $file
* memory break_on_malloc $count
* memory info
* memory init on|off
* memory onexit $file
* memory tag $string
* memory trace on|off
* memory trace_on_at_malloc $count
* memory validate on|off
*
* Results:
* Standard TCL results.
*
*----------------------------------------------------------------------
*/
static int
MemoryCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Obj values of arguments. */
{
const char *fileName;
FILE *fileP;
Tcl_DString buffer;
int result;
size_t len;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option [args..]");
return TCL_ERROR;
}
if (strcmp(TclGetString(objv[1]), "active") == 0 || strcmp(TclGetString(objv[1]), "display") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "file");
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, TclGetString(objv[2]), &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
result = Tcl_DumpActiveMemory(fileName);
Tcl_DStringFree(&buffer);
if (result != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("error accessing %s: %s",
TclGetString(objv[2]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]),"break_on_malloc") == 0) {
int value;
if (objc != 3) {
goto argError;
}
if (Tcl_GetIntFromObj(interp, objv[2], &value) != TCL_OK) {
return TCL_ERROR;
}
break_on_malloc = (unsigned int) value;
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]),"info") == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%-25s %10u\n%-25s %10u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER"u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER "u\n",
"total mallocs", total_mallocs, "total frees", total_frees,
"current packets allocated", current_malloc_packets,
"current bytes allocated", current_bytes_malloced,
"maximum packets allocated", maximum_malloc_packets,
"maximum bytes allocated", maximum_bytes_malloced));
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]), "init") == 0) {
if (objc != 3) {
goto bad_suboption;
}
init_malloced_bodies = (strcmp(TclGetString(objv[2]),"on") == 0);
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]), "objs") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "file");
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, TclGetString(objv[2]), &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
fileP = fopen(fileName, "w");
if (fileP == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot open output file: %s",
Tcl_PosixError(interp)));
return TCL_ERROR;
}
TclDbDumpActiveObjects(fileP);
fclose(fileP);
Tcl_DStringFree(&buffer);
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]),"onexit") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "file");
return TCL_ERROR;
}
fileName = Tcl_TranslateFileName(interp, TclGetString(objv[2]), &buffer);
if (fileName == NULL) {
return TCL_ERROR;
}
onExitMemDumpFileName = dumpFile;
strcpy(onExitMemDumpFileName,fileName);
Tcl_DStringFree(&buffer);
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]),"tag") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "file");
return TCL_ERROR;
}
if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) {
TclpFree(curTagPtr);
}
len = strlen(TclGetString(objv[2]));
curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(len));
curTagPtr->refCount = 0;
memcpy(curTagPtr->string, TclGetString(objv[2]), len + 1);
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]),"trace") == 0) {
if (objc != 3) {
goto bad_suboption;
}
alloc_tracing = (strcmp(TclGetString(objv[2]),"on") == 0);
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]),"trace_on_at_malloc") == 0) {
int value;
if (objc != 3) {
goto argError;
}
if (Tcl_GetIntFromObj(interp, objv[2], &value) != TCL_OK) {
return TCL_ERROR;
}
trace_on_at_malloc = value;
return TCL_OK;
}
if (strcmp(TclGetString(objv[1]),"validate") == 0) {
if (objc != 3) {
goto bad_suboption;
}
validate_memory = (strcmp(TclGetString(objv[2]),"on") == 0);
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\": should be active, break_on_malloc, info, "
"init, objs, onexit, tag, trace, trace_on_at_malloc, or validate",
TclGetString(objv[1])));
return TCL_ERROR;
argError:
Tcl_WrongNumArgs(interp, 2, objv, "count");
return TCL_ERROR;
bad_suboption:
Tcl_WrongNumArgs(interp, 2, objv, "on|off");
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* CheckmemCmd --
*
* This is the command procedure for the "checkmem" command, which causes
* the application to exit after printing information about memory usage
* to the file passed to this command as its first argument.
*
* Results:
* Returns a standard Tcl completion code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int CheckmemCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int
CheckmemCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter for evaluation. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Obj values of arguments. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "fileName");
return TCL_ERROR;
}
tclMemDumpFileName = dumpFile;
strcpy(tclMemDumpFileName, TclGetString(objv[1]));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_InitMemory --
|
| ︙ | ︙ | |||
968 969 970 971 972 973 974 |
void
Tcl_InitMemory(
Tcl_Interp *interp) /* Interpreter in which commands should be
* added */
{
TclInitDbCkalloc();
| | | | 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 |
void
Tcl_InitMemory(
Tcl_Interp *interp) /* Interpreter in which commands should be
* added */
{
TclInitDbCkalloc();
Tcl_CreateObjCommand(interp, "memory", MemoryCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "checkmem", CheckmemCmd, NULL, NULL);
}
#else /* TCL_MEM_DEBUG */
/* This is the !TCL_MEM_DEBUG case */
|
| ︙ | ︙ | |||
993 994 995 996 997 998 999 | * * Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check * that memory was actually allocated. * *---------------------------------------------------------------------- */ | < | | < < | | | | < < | | < | | < < | < | | | | < < | < < | | | | < < | | | | < < | | < | | | < < | < | | | | | < < | < < | | | | < | | | | | | | 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 |
*
* Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does check
* that memory was actually allocated.
*
*----------------------------------------------------------------------
*/
char *
Tcl_Alloc(
unsigned int size)
{
char *result = (char *)TclpAlloc(size);
/*
* Most systems will not alloc(0), instead bumping it to one so that NULL
* isn't returned. Some systems (AIX, Tru64) will alloc(0) by returning
* NULL, so we have to check that the NULL we get is not in response to
* alloc(0).
*
* The ANSI spec actually says that systems either return NULL *or* a
* special pointer on failure, but we only check for NULL
*/
if ((result == NULL) && size) {
Tcl_Panic("unable to alloc %u bytes", size);
}
return result;
}
char *
Tcl_DbCkalloc(
unsigned int size,
const char *file,
int line)
{
char *result = (char *)TclpAlloc(size);
if ((result == NULL) && size) {
fflush(stdout);
Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_AttemptAlloc --
*
* Interface to TclpAlloc when TCL_MEM_DEBUG is disabled. It does not
* check that memory was actually allocated.
*
*----------------------------------------------------------------------
*/
char *
Tcl_AttemptAlloc(
unsigned int size)
{
return (char *)TclpAlloc(size);
}
char *
Tcl_AttemptDbCkalloc(
unsigned int size,
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return (char *)TclpAlloc(size);
}
/*
*----------------------------------------------------------------------
*
* Tcl_Realloc --
*
* Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does check
* that memory was actually allocated.
*
*----------------------------------------------------------------------
*/
char *
Tcl_Realloc(
char *ptr,
unsigned int size)
{
char *result = (char *)TclpRealloc(ptr, size);
if ((result == NULL) && size) {
Tcl_Panic("unable to realloc %u bytes", size);
}
return result;
}
char *
Tcl_DbCkrealloc(
char *ptr,
unsigned int size,
const char *file,
int line)
{
char *result = (char *)TclpRealloc(ptr, size);
if ((result == NULL) && size) {
fflush(stdout);
Tcl_Panic("unable to realloc %u bytes, %s line %d", size, file, line);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_AttemptRealloc --
*
* Interface to TclpRealloc when TCL_MEM_DEBUG is disabled. It does not
* check that memory was actually allocated.
*
*----------------------------------------------------------------------
*/
char *
Tcl_AttemptRealloc(
char *ptr,
unsigned int size)
{
return (char *)TclpRealloc(ptr, size);
}
char *
Tcl_AttemptDbCkrealloc(
char *ptr,
unsigned int size,
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return (char *)TclpRealloc(ptr, size);
}
/*
*----------------------------------------------------------------------
*
* Tcl_Free --
*
* Interface to TclpFree when TCL_MEM_DEBUG is disabled. Done here rather
* in the macro to keep some modules from being compiled with
* TCL_MEM_DEBUG enabled and some with it disabled.
*
*----------------------------------------------------------------------
*/
void
Tcl_Free(
char *ptr)
{
TclpFree(ptr);
}
void
Tcl_DbCkfree(
char *ptr,
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
TclpFree(ptr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_InitMemory --
*
* Dummy initialization for memory command, which is only available if
* TCL_MEM_DEBUG is on.
*
*----------------------------------------------------------------------
*/
void
Tcl_InitMemory(
TCL_UNUSED(Tcl_Interp *) /*interp*/)
{
}
int
Tcl_DumpActiveMemory(
TCL_UNUSED(const char *) /*fileName*/)
{
return TCL_OK;
}
void
Tcl_ValidateAllMemory(
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
}
int
TclDumpMemoryInfo(
TCL_UNUSED(ClientData),
TCL_UNUSED(int) /*flags*/)
{
return 1;
}
#endif /* TCL_MEM_DEBUG */
/*
|
| ︙ | ︙ | |||
1252 1253 1254 1255 1256 1257 1258 |
} else if (onExitMemDumpFileName != NULL) {
Tcl_DumpActiveMemory(onExitMemDumpFileName);
}
Tcl_MutexLock(ckallocMutexPtr);
if (curTagPtr != NULL) {
| | | 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 |
} else if (onExitMemDumpFileName != NULL) {
Tcl_DumpActiveMemory(onExitMemDumpFileName);
}
Tcl_MutexLock(ckallocMutexPtr);
if (curTagPtr != NULL) {
TclpFree(curTagPtr);
curTagPtr = NULL;
}
allocHead = NULL;
Tcl_MutexUnlock(ckallocMutexPtr);
#endif
|
| ︙ | ︙ |
Changes to generic/tclClock.c.
| ︙ | ︙ | |||
96 97 98 99 100 101 102 |
Tcl_Obj **literals; /* Pool of object literals. */
} ClockClientData;
/*
* Structure containing the fields used in [clock format] and [clock scan]
*/
| | | | 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 |
Tcl_Obj **literals; /* Pool of object literals. */
} ClockClientData;
/*
* Structure containing the fields used in [clock format] and [clock scan]
*/
typedef struct TclDateFields {
Tcl_WideInt seconds; /* Time expressed in seconds from the Posix
* epoch */
Tcl_WideInt localSeconds; /* Local time expressed in nominal seconds
* from the Posix epoch */
int tzOffset; /* Time zone offset in seconds east of
* Greenwich */
Tcl_Obj *tzName; /* Time zone name */
int julianDay; /* Julian Day Number in local time zone */
int isBce; /* 1 if BCE */
int gregorian; /* Flag == 1 if the date is Gregorian */
int year; /* Year of the era */
int dayOfYear; /* Day of the year (1 January == 1) */
int month; /* Month number */
int dayOfMonth; /* Day of the month */
int iso8601Year; /* ISO8601 week-based year */
int iso8601Week; /* ISO8601 week number */
|
| ︙ | ︙ | |||
271 272 273 274 275 276 277 |
return;
}
/*
* Create the client data, which is a refcounted literal pool.
*/
| | | | 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 |
return;
}
/*
* Create the client data, which is a refcounted literal pool.
*/
data = (ClockClientData *)ckalloc(sizeof(ClockClientData));
data->refCount = 0;
data->literals = (Tcl_Obj **)ckalloc(LIT__END * sizeof(Tcl_Obj*));
for (i = 0; i < LIT__END; ++i) {
data->literals[i] = Tcl_NewStringObj(literals[i], -1);
Tcl_IncrRefCount(data->literals[i]);
}
/*
* Install the commands.
|
| ︙ | ︙ | |||
332 333 334 335 336 337 338 |
static int
ClockConvertlocaltoutcObjCmd(
ClientData clientData, /* Client data */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
| | | | | 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 |
static int
ClockConvertlocaltoutcObjCmd(
ClientData clientData, /* Client data */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
ClockClientData *data = (ClockClientData *)clientData;
Tcl_Obj *const *lit = data->literals;
Tcl_Obj *secondsObj;
Tcl_Obj *dict;
int changeover;
TclDateFields fields;
int created = 0;
int status;
/*
* Check params and convert time.
*/
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "dict tzdata changeover");
return TCL_ERROR;
}
dict = objv[1];
if (Tcl_DictObjGet(interp, dict, lit[LIT_LOCALSECONDS],
&secondsObj)!= TCL_OK) {
return TCL_ERROR;
}
if (secondsObj == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("key \"localseconds\" not "
"found in dictionary", -1));
return TCL_ERROR;
|
| ︙ | ︙ | |||
376 377 378 379 380 381 382 |
*/
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
created = 1;
Tcl_IncrRefCount(dict);
}
| | | 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 |
*/
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
created = 1;
Tcl_IncrRefCount(dict);
}
status = Tcl_DictObjPut(interp, dict, lit[LIT_SECONDS],
Tcl_NewWideIntObj(fields.seconds));
if (status == TCL_OK) {
Tcl_SetObjResult(interp, dict);
}
if (created) {
Tcl_DecrRefCount(dict);
}
|
| ︙ | ︙ | |||
426 427 428 429 430 431 432 |
ClientData clientData, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
TclDateFields fields;
Tcl_Obj *dict;
| | | | 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 |
ClientData clientData, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
TclDateFields fields;
Tcl_Obj *dict;
ClockClientData *data = (ClockClientData *)clientData;
Tcl_Obj *const *lit = data->literals;
int changeover;
/*
* Check params.
*/
if (objc != 4) {
|
| ︙ | ︙ | |||
449 450 451 452 453 454 455 |
/*
* fields.seconds could be an unsigned number that overflowed. Make sure
* that it isn't.
*/
if (TclHasIntRep(objv[1], &tclBignumType)) {
| | | 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 |
/*
* fields.seconds could be an unsigned number that overflowed. Make sure
* that it isn't.
*/
if (TclHasIntRep(objv[1], &tclBignumType)) {
Tcl_SetObjResult(interp, lit[LIT_INTEGER_VALUE_TOO_LARGE]);
return TCL_ERROR;
}
/*
* Convert UTC time to local.
*/
|
| ︙ | ︙ | |||
477 478 479 480 481 482 483 |
*/
GetGregorianEraYearDay(&fields, changeover);
GetMonthDay(&fields);
GetYearWeekDay(&fields, changeover);
dict = Tcl_NewDictObj();
| | | | | | | | | | | | | | | | | 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 |
*/
GetGregorianEraYearDay(&fields, changeover);
GetMonthDay(&fields);
GetYearWeekDay(&fields, changeover);
dict = Tcl_NewDictObj();
Tcl_DictObjPut(NULL, dict, lit[LIT_LOCALSECONDS],
Tcl_NewWideIntObj(fields.localSeconds));
Tcl_DictObjPut(NULL, dict, lit[LIT_SECONDS],
Tcl_NewWideIntObj(fields.seconds));
Tcl_DictObjPut(NULL, dict, lit[LIT_TZNAME], fields.tzName);
Tcl_DecrRefCount(fields.tzName);
Tcl_DictObjPut(NULL, dict, lit[LIT_TZOFFSET],
Tcl_NewWideIntObj(fields.tzOffset));
Tcl_DictObjPut(NULL, dict, lit[LIT_JULIANDAY],
Tcl_NewWideIntObj(fields.julianDay));
Tcl_DictObjPut(NULL, dict, lit[LIT_GREGORIAN],
Tcl_NewWideIntObj(fields.gregorian));
Tcl_DictObjPut(NULL, dict, lit[LIT_ERA],
lit[fields.isBce ? LIT_BCE : LIT_CE]);
Tcl_DictObjPut(NULL, dict, lit[LIT_YEAR],
Tcl_NewWideIntObj(fields.year));
Tcl_DictObjPut(NULL, dict, lit[LIT_DAYOFYEAR],
Tcl_NewWideIntObj(fields.dayOfYear));
Tcl_DictObjPut(NULL, dict, lit[LIT_MONTH],
Tcl_NewWideIntObj(fields.month));
Tcl_DictObjPut(NULL, dict, lit[LIT_DAYOFMONTH],
Tcl_NewWideIntObj(fields.dayOfMonth));
Tcl_DictObjPut(NULL, dict, lit[LIT_ISO8601YEAR],
Tcl_NewWideIntObj(fields.iso8601Year));
Tcl_DictObjPut(NULL, dict, lit[LIT_ISO8601WEEK],
Tcl_NewWideIntObj(fields.iso8601Week));
Tcl_DictObjPut(NULL, dict, lit[LIT_DAYOFWEEK],
Tcl_NewWideIntObj(fields.dayOfWeek));
Tcl_SetObjResult(interp, dict);
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
580 581 582 583 584 585 586 |
ClientData clientData, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
TclDateFields fields;
Tcl_Obj *dict;
| | | | | | | | | | | 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 |
ClientData clientData, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
TclDateFields fields;
Tcl_Obj *dict;
ClockClientData *data = (ClockClientData *)clientData;
Tcl_Obj *const *lit = data->literals;
int changeover;
int copied = 0;
int status;
int isBce = 0;
/*
* Check params.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dict changeover");
return TCL_ERROR;
}
dict = objv[1];
if (FetchEraField(interp, dict, lit[LIT_ERA], &isBce) != TCL_OK
|| FetchIntField(interp, dict, lit[LIT_YEAR], &fields.year)
!= TCL_OK
|| FetchIntField(interp, dict, lit[LIT_MONTH], &fields.month)
!= TCL_OK
|| FetchIntField(interp, dict, lit[LIT_DAYOFMONTH],
&fields.dayOfMonth) != TCL_OK
|| TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
return TCL_ERROR;
}
fields.isBce = isBce;
/*
* Get Julian day.
*/
GetJulianDayFromEraYearMonthDay(&fields, changeover);
/*
* Store Julian day in the dictionary - copy on write.
*/
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
Tcl_IncrRefCount(dict);
copied = 1;
}
status = Tcl_DictObjPut(interp, dict, lit[LIT_JULIANDAY],
Tcl_NewWideIntObj(fields.julianDay));
if (status == TCL_OK) {
Tcl_SetObjResult(interp, dict);
}
if (copied) {
Tcl_DecrRefCount(dict);
}
|
| ︙ | ︙ | |||
664 665 666 667 668 669 670 |
ClientData clientData, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
TclDateFields fields;
Tcl_Obj *dict;
| | | | | | | | | | | 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 |
ClientData clientData, /* Opaque pointer to literal pool, etc. */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter vector */
{
TclDateFields fields;
Tcl_Obj *dict;
ClockClientData *data = (ClockClientData *)clientData;
Tcl_Obj *const *lit = data->literals;
int changeover;
int copied = 0;
int status;
int isBce = 0;
/*
* Check params.
*/
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dict changeover");
return TCL_ERROR;
}
dict = objv[1];
if (FetchEraField(interp, dict, lit[LIT_ERA], &isBce) != TCL_OK
|| FetchIntField(interp, dict, lit[LIT_ISO8601YEAR],
&fields.iso8601Year) != TCL_OK
|| FetchIntField(interp, dict, lit[LIT_ISO8601WEEK],
&fields.iso8601Week) != TCL_OK
|| FetchIntField(interp, dict, lit[LIT_DAYOFWEEK],
&fields.dayOfWeek) != TCL_OK
|| TclGetIntFromObj(interp, objv[2], &changeover) != TCL_OK) {
return TCL_ERROR;
}
fields.isBce = isBce;
/*
* Get Julian day.
*/
GetJulianDayFromEraYearWeekDay(&fields, changeover);
/*
* Store Julian day in the dictionary - copy on write.
*/
if (Tcl_IsShared(dict)) {
dict = Tcl_DuplicateObj(dict);
Tcl_IncrRefCount(dict);
copied = 1;
}
status = Tcl_DictObjPut(interp, dict, lit[LIT_JULIANDAY],
Tcl_NewWideIntObj(fields.julianDay));
if (status == TCL_OK) {
Tcl_SetObjResult(interp, dict);
}
if (copied) {
Tcl_DecrRefCount(dict);
}
|
| ︙ | ︙ | |||
1048 1049 1050 1051 1052 1053 1054 |
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Time to convert, with 'seconds' filled in */
int changeover) /* Julian Day of the Gregorian transition */
{
time_t tock;
struct tm *timeVal; /* Time after conversion */
int diff; /* Time zone diff local-Greenwich */
| | | 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 |
Tcl_Interp *interp, /* Tcl interpreter */
TclDateFields *fields, /* Time to convert, with 'seconds' filled in */
int changeover) /* Julian Day of the Gregorian transition */
{
time_t tock;
struct tm *timeVal; /* Time after conversion */
int diff; /* Time zone diff local-Greenwich */
char buffer[16]; /* Buffer for time zone name */
/*
* Use 'localtime' to determine local year, month, day, time of day.
*/
tock = (time_t) fields->seconds;
if ((Tcl_WideInt) tock != fields->seconds) {
|
| ︙ | ︙ | |||
1075 1076 1077 1078 1079 1080 1081 |
return TCL_ERROR;
}
/*
* Fill in the date in 'fields' and use it to derive Julian Day.
*/
| | | 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 |
return TCL_ERROR;
}
/*
* Fill in the date in 'fields' and use it to derive Julian Day.
*/
fields->isBce = 0;
fields->year = timeVal->tm_year + 1900;
fields->month = timeVal->tm_mon + 1;
fields->dayOfMonth = timeVal->tm_mday;
GetJulianDayFromEraYearMonthDay(fields, changeover);
/*
* Convert that value to seconds.
|
| ︙ | ︙ | |||
1213 1214 1215 1216 1217 1218 1219 |
/*
* Find the given date, minus three days, plus one year. That date's
* iso8601 year is an upper bound on the ISO8601 year of the given date.
*/
temp.julianDay = fields->julianDay - 3;
GetGregorianEraYearDay(&temp, changeover);
| | | | 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 |
/*
* Find the given date, minus three days, plus one year. That date's
* iso8601 year is an upper bound on the ISO8601 year of the given date.
*/
temp.julianDay = fields->julianDay - 3;
GetGregorianEraYearDay(&temp, changeover);
if (temp.isBce) {
temp.iso8601Year = temp.year - 1;
} else {
temp.iso8601Year = temp.year + 1;
}
temp.iso8601Week = 1;
temp.dayOfWeek = 1;
GetJulianDayFromEraYearWeekDay(&temp, changeover);
/*
* temp.julianDay is now the start of an ISO8601 year, either the one
* corresponding to the given date, or the one after. If we guessed high,
* move one year earlier
*/
if (fields->julianDay < temp.julianDay) {
if (temp.isBce) {
temp.iso8601Year += 1;
} else {
temp.iso8601Year -= 1;
}
GetJulianDayFromEraYearWeekDay(&temp, changeover);
}
|
| ︙ | ︙ | |||
1355 1356 1357 1358 1359 1360 1361 |
year += n;
/*
* store era/year/day back into fields.
*/
if (year <= 0) {
| | | | 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 |
year += n;
/*
* store era/year/day back into fields.
*/
if (year <= 0) {
fields->isBce = 1;
fields->year = 1 - year;
} else {
fields->isBce = 0;
fields->year = year;
}
fields->dayOfYear = day + 1;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1426 1427 1428 1429 1430 1431 1432 |
* given year */
TclDateFields firstWeek;
/*
* Find January 4 in the ISO8601 year, which will always be in week 1.
*/
| | | 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 |
* given year */
TclDateFields firstWeek;
/*
* Find January 4 in the ISO8601 year, which will always be in week 1.
*/
firstWeek.isBce = fields->isBce;
firstWeek.year = fields->iso8601Year;
firstWeek.month = 1;
firstWeek.dayOfMonth = 4;
GetJulianDayFromEraYearMonthDay(&firstWeek, changeover);
/*
* Find Monday of week 1.
|
| ︙ | ︙ | |||
1470 1471 1472 1473 1474 1475 1476 |
static void
GetJulianDayFromEraYearMonthDay(
TclDateFields *fields, /* Date to convert */
int changeover) /* Gregorian transition date as a Julian Day */
{
int year, ym1, month, mm1, q, r, ym1o4, ym1o100, ym1o400;
| | | 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 |
static void
GetJulianDayFromEraYearMonthDay(
TclDateFields *fields, /* Date to convert */
int changeover) /* Gregorian transition date as a Julian Day */
{
int year, ym1, month, mm1, q, r, ym1o4, ym1o100, ym1o400;
if (fields->isBce) {
year = 1 - fields->year;
} else {
year = fields->year;
}
/*
* Reduce month modulo 12.
|
| ︙ | ︙ | |||
1498 1499 1500 1501 1502 1503 1504 |
/*
* Adjust the year after reducing the month.
*/
fields->gregorian = 1;
if (year < 1) {
| | | | | 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 |
/*
* Adjust the year after reducing the month.
*/
fields->gregorian = 1;
if (year < 1) {
fields->isBce = 1;
fields->year = 1-year;
} else {
fields->isBce = 0;
fields->year = year;
}
/*
* Try an initial conversion in the Gregorian calendar.
*/
#if 0 /* BUG https://core.tcl-lang.org/tcl/tktview?name=da340d4f32 */
ym1o4 = ym1 / 4;
#else
/*
* Have to make sure quotient is truncated towards 0 when negative.
* See above bug for details. The casts are necessary.
*/
if (ym1 >= 0)
|
| ︙ | ︙ | |||
1576 1577 1578 1579 1580 1581 1582 |
static int
IsGregorianLeapYear(
TclDateFields *fields) /* Date to test */
{
int year = fields->year;
| | | 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 |
static int
IsGregorianLeapYear(
TclDateFields *fields) /* Date to test */
{
int year = fields->year;
if (fields->isBce) {
year = 1 - year;
}
if (year%4 != 0) {
return 0;
} else if (!(fields->gregorian)) {
return 1;
} else if (year%400 == 0) {
|
| ︙ | ︙ | |||
1641 1642 1643 1644 1645 1646 1647 | * the value of the variable if the variable does exist, * *---------------------------------------------------------------------- */ int ClockGetenvObjCmd( | | | 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 |
* the value of the variable if the variable does exist,
*
*----------------------------------------------------------------------
*/
int
ClockGetenvObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
const char *varName;
const char *varValue;
|
| ︙ | ︙ | |||
1688 1689 1690 1691 1692 1693 1694 |
const time_t *timePtr) /* Pointer to the number of seconds since the
* local system's epoch */
{
/*
* Get a thread-local buffer to hold the returned time.
*/
| | | 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 |
const time_t *timePtr) /* Pointer to the number of seconds since the
* local system's epoch */
{
/*
* Get a thread-local buffer to hold the returned time.
*/
struct tm *tmPtr = (struct tm *)Tcl_GetThreadData(&tmKey, sizeof(struct tm));
#ifdef HAVE_LOCALTIME_R
localtime_r(timePtr, tmPtr);
#else
struct tm *sysTmPtr;
Tcl_MutexLock(&clockMutex);
sysTmPtr = localtime(timePtr);
|
| ︙ | ︙ | |||
1726 1727 1728 1729 1730 1731 1732 | * documentation for details on what it does. * *---------------------------------------------------------------------- */ int ClockClicksObjCmd( | | | 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 |
* documentation for details on what it does.
*
*----------------------------------------------------------------------
*/
int
ClockClicksObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
static const char *const clicksSwitches[] = {
"-milliseconds", "-microseconds", NULL
};
|
| ︙ | ︙ | |||
1796 1797 1798 1799 1800 1801 1802 | * user documentation for details on what it does. * *---------------------------------------------------------------------- */ int ClockMillisecondsObjCmd( | | | 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 |
* user documentation for details on what it does.
*
*----------------------------------------------------------------------
*/
int
ClockMillisecondsObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
if (objc != 1) {
|
| ︙ | ︙ | |||
1833 1834 1835 1836 1837 1838 1839 | * user documentation for details on what it does. * *---------------------------------------------------------------------- */ int ClockMicrosecondsObjCmd( | | | 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 |
* user documentation for details on what it does.
*
*----------------------------------------------------------------------
*/
int
ClockMicrosecondsObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
1871 1872 1873 1874 1875 1876 1877 |
static int
ClockParseformatargsObjCmd(
ClientData clientData, /* Client data containing literal pool */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const objv[]) /* Parameter vector */
{
| | | 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 |
static int
ClockParseformatargsObjCmd(
ClientData clientData, /* Client data containing literal pool */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const objv[]) /* Parameter vector */
{
ClockClientData *dataPtr = (ClockClientData *)clientData;
Tcl_Obj **litPtr = dataPtr->literals;
Tcl_Obj *results[3]; /* Format, locale and timezone */
#define formatObj results[0]
#define localeObj results[1]
#define timezoneObj results[2]
int gmtFlag = 0;
static const char *const options[] = { /* Command line options expected */
|
| ︙ | ︙ | |||
1913 1914 1915 1916 1917 1918 1919 |
formatObj = litPtr[LIT__DEFAULT_FORMAT];
localeObj = litPtr[LIT_C];
timezoneObj = litPtr[LIT__NIL];
for (i = 2; i < objc; i+=2) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&optionIndex) != TCL_OK) {
Tcl_SetErrorCode(interp, "CLOCK", "badOption",
| | | 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 |
formatObj = litPtr[LIT__DEFAULT_FORMAT];
localeObj = litPtr[LIT_C];
timezoneObj = litPtr[LIT__NIL];
for (i = 2; i < objc; i+=2) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&optionIndex) != TCL_OK) {
Tcl_SetErrorCode(interp, "CLOCK", "badOption",
Tcl_GetString(objv[i]), NULL);
return TCL_ERROR;
}
switch (optionIndex) {
case CLOCK_FORMAT_FORMAT:
formatObj = objv[i+1];
break;
case CLOCK_FORMAT_GMT:
|
| ︙ | ︙ | |||
1984 1985 1986 1987 1988 1989 1990 | * documentation for details on what it does. * *---------------------------------------------------------------------- */ int ClockSecondsObjCmd( | | | 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 |
* documentation for details on what it does.
*
*----------------------------------------------------------------------
*/
int
ClockSecondsObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const *objv) /* Parameter values */
{
Tcl_Time now;
if (objc != 1) {
|
| ︙ | ︙ | |||
2020 2021 2022 2023 2024 2025 2026 |
*
*----------------------------------------------------------------------
*/
static void
TzsetIfNecessary(void)
{
| | | | | | 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 |
*
*----------------------------------------------------------------------
*/
static void
TzsetIfNecessary(void)
{
static char* tzWas = (char *)INT2PTR(-1); /* Previous value of TZ, protected by
* clockMutex. */
const char *tzIsNow; /* Current value of TZ */
Tcl_MutexLock(&clockMutex);
tzIsNow = getenv("TZ");
if (tzIsNow != NULL && (tzWas == NULL || tzWas == INT2PTR(-1)
|| strcmp(tzIsNow, tzWas) != 0)) {
tzset();
if (tzWas != NULL && tzWas != INT2PTR(-1)) {
ckfree(tzWas);
}
tzWas = (char *)ckalloc(strlen(tzIsNow) + 1);
strcpy(tzWas, tzIsNow);
} else if (tzIsNow == NULL && tzWas != NULL) {
tzset();
if (tzWas != INT2PTR(-1)) ckfree(tzWas);
tzWas = NULL;
}
Tcl_MutexUnlock(&clockMutex);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2060 2061 2062 2063 2064 2065 2066 |
*----------------------------------------------------------------------
*/
static void
ClockDeleteCmdProc(
ClientData clientData) /* Opaque pointer to the client data */
{
| | | | | 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 |
*----------------------------------------------------------------------
*/
static void
ClockDeleteCmdProc(
ClientData clientData) /* Opaque pointer to the client data */
{
ClockClientData *data = (ClockClientData *)clientData;
int i;
if (data->refCount-- <= 1) {
for (i = 0; i < LIT__END; ++i) {
Tcl_DecrRefCount(data->literals[i]);
}
ckfree(data->literals);
ckfree(data);
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclCmdAH.c.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #ifdef _WIN32 # include "tclWinInt.h" #endif | < | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #ifdef _WIN32 # include "tclWinInt.h" #endif /* * The state structure used by [foreach]. Note that the actual structure has * all its working arrays appended afterwards so they can be allocated and * freed in a single step. */ |
| ︙ | ︙ | |||
42 43 44 45 46 47 48 | /* * Prototypes for local procedures defined in this file: */ static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode); | | < < | < < | < < | < < | < < | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | /* * Prototypes for local procedures defined in this file: */ static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode); static Tcl_ObjCmdProc EncodingConvertfromObjCmd; static Tcl_ObjCmdProc EncodingConverttoObjCmd; static Tcl_ObjCmdProc EncodingDirsObjCmd; static Tcl_ObjCmdProc EncodingNamesObjCmd; static Tcl_ObjCmdProc EncodingSystemObjCmd; static inline int ForeachAssignments(Tcl_Interp *interp, struct ForeachState *statePtr); static inline void ForeachCleanup(Tcl_Interp *interp, struct ForeachState *statePtr); static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_FSStatProc *statProc, Tcl_StatBuf *statPtr); static const char * GetTypeFromMode(int mode); |
| ︙ | ︙ | |||
124 125 126 127 128 129 130 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | | | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_BreakObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
return TCL_BREAK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CaseObjCmd --
*
* This procedure is invoked to process the "case" Tcl command. See the
* user documentation for details on what it does. THIS COMMAND IS
* OBSOLETE AND DEPRECATED. SLATED FOR REMOVAL IN TCL 9.0.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
int
Tcl_CaseObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i;
int body, result, caseObjc;
const char *stringPtr, *arg;
Tcl_Obj *const *caseObjv;
Tcl_Obj *armPtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
"string ?in? ?pattern body ...? ?default body?");
return TCL_ERROR;
}
stringPtr = TclGetString(objv[1]);
body = -1;
arg = TclGetString(objv[2]);
if (strcmp(arg, "in") == 0) {
i = 3;
} else {
i = 2;
}
caseObjc = objc - i;
caseObjv = objv + i;
/*
* If all of the pattern/command pairs are lumped into a single argument,
* split them out again.
*/
if (caseObjc == 1) {
Tcl_Obj **newObjv;
TclListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv);
caseObjv = newObjv;
}
for (i = 0; i < caseObjc; i += 2) {
int patObjc, j;
const char **patObjv;
const char *pat, *p;
if (i == caseObjc-1) {
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"extra case pattern with no body", -1));
return TCL_ERROR;
}
/*
* Check for special case of single pattern (no list) with no
* backslash sequences.
*/
pat = TclGetString(caseObjv[i]);
for (p = pat; *p != '\0'; p++) {
if (TclIsSpaceProcM(*p) || (*p == '\\')) {
break;
}
}
if (*p == '\0') {
if ((*pat == 'd') && (strcmp(pat, "default") == 0)) {
body = i + 1;
}
if (Tcl_StringMatch(stringPtr, pat)) {
body = i + 1;
goto match;
}
continue;
}
/*
* Break up pattern lists, then check each of the patterns in the
* list.
*/
result = Tcl_SplitList(interp, pat, &patObjc, &patObjv);
if (result != TCL_OK) {
return result;
}
for (j = 0; j < patObjc; j++) {
if (Tcl_StringMatch(stringPtr, patObjv[j])) {
body = i + 1;
break;
}
}
ckfree(patObjv);
if (j < patObjc) {
break;
}
}
match:
if (body != -1) {
armPtr = caseObjv[body - 1];
result = Tcl_EvalObjEx(interp, caseObjv[body], 0);
if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (\"%.50s\" arm line %d)",
TclGetString(armPtr), Tcl_GetErrorLine(interp)));
}
return result;
}
/*
* Nothing matched: return nothing.
*/
return TCL_OK;
}
#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_CatchObjCmd --
*
* This object-based procedure is invoked to process the "catch" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_CatchObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRCatchObjCmd, clientData, objc, objv);
}
int
TclNRCatchObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *varNamePtr = NULL;
Tcl_Obj *optionVarNamePtr = NULL;
Interp *iPtr = (Interp *) interp;
|
| ︙ | ︙ | |||
209 210 211 212 213 214 215 |
CatchObjCmdCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
int objc = PTR2INT(data[0]);
| | | | 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 |
CatchObjCmdCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
int objc = PTR2INT(data[0]);
Tcl_Obj *varNamePtr = (Tcl_Obj *)data[1];
Tcl_Obj *optionVarNamePtr = (Tcl_Obj *)data[2];
int rewind = iPtr->execEnvPtr->rewind;
/*
* We disable catch in interpreters where the limit has been exceeded.
*/
if (rewind || Tcl_LimitExceeded(interp)) {
|
| ︙ | ︙ | |||
262 263 264 265 266 267 268 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_CdObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *dir;
int result;
|
| ︙ | ︙ | |||
318 319 320 321 322 323 324 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ConcatObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc >= 2) {
Tcl_SetObjResult(interp, Tcl_ConcatObj(objc-1, objv+1));
}
|
| ︙ | ︙ | |||
353 354 355 356 357 358 359 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ContinueObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
416 417 418 419 420 421 422 | * A standard Tcl result. * *---------------------------------------------------------------------- */ int EncodingConvertfromObjCmd( | | | | | 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 |
* A standard Tcl result.
*
*----------------------------------------------------------------------
*/
int
EncodingConvertfromObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *data; /* Byte array to convert */
Tcl_DString ds; /* Buffer to hold the string */
Tcl_Encoding encoding; /* Encoding to use */
int length; /* Length of the byte array being converted */
const char *bytesPtr; /* Pointer to the first byte of the array */
if (objc == 2) {
encoding = Tcl_GetEncoding(interp, NULL);
data = objv[1];
} else if (objc == 3) {
if (Tcl_GetEncodingFromObj(interp, objv[1], &encoding) != TCL_OK) {
return TCL_ERROR;
}
data = objv[2];
} else {
Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data");
return TCL_ERROR;
}
/*
* Convert the string into a byte array in 'ds'
*/
bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length);
Tcl_ExternalToUtfDString(encoding, bytesPtr, length, &ds);
/*
* Note that we cannot use Tcl_DStringResult here because it will
* truncate the string at the first null byte.
*/
|
| ︙ | ︙ | |||
478 479 480 481 482 483 484 | * A standard Tcl result. * *---------------------------------------------------------------------- */ int EncodingConverttoObjCmd( | | | | 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 |
* A standard Tcl result.
*
*----------------------------------------------------------------------
*/
int
EncodingConverttoObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *data; /* String to convert */
Tcl_DString ds; /* Buffer to hold the byte array */
Tcl_Encoding encoding; /* Encoding to use */
int length; /* Length of the string being converted */
const char *stringPtr; /* Pointer to the first byte of the string */
/* TODO - ADJUST OBJ INDICES WHEN ENSEMBLIFYING THIS */
if (objc == 2) {
encoding = Tcl_GetEncoding(interp, NULL);
data = objv[1];
|
| ︙ | ︙ | |||
542 543 544 545 546 547 548 | * Can set the encoding search path. * *---------------------------------------------------------------------- */ int EncodingDirsObjCmd( | | | 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 |
* Can set the encoding search path.
*
*----------------------------------------------------------------------
*/
int
EncodingDirsObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *dirListObj;
if (objc > 2) {
|
| ︙ | ︙ | |||
585 586 587 588 589 590 591 | * Results: * Returns a standard Tcl result * *----------------------------------------------------------------------------- */ int | | > | | | | 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 |
* Results:
* Returns a standard Tcl result
*
*-----------------------------------------------------------------------------
*/
int
EncodingNamesObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Number of command line args */
Tcl_Obj* const objv[]) /* Vector of command line args */
{
if (objc > 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
Tcl_GetEncodingNames(interp);
return TCL_OK;
|
| ︙ | ︙ | |||
615 616 617 618 619 620 621 | * Side effects: * May change the system encoding. * *----------------------------------------------------------------------------- */ int | | > | | | | 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 |
* Side effects:
* May change the system encoding.
*
*-----------------------------------------------------------------------------
*/
int
EncodingSystemObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Number of command line args */
Tcl_Obj* const objv[]) /* Vector of command line args */
{
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?encoding?");
return TCL_ERROR;
}
if (objc == 1) {
Tcl_SetObjResult(interp,
|
| ︙ | ︙ | |||
650 651 652 653 654 655 656 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ErrorObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *options, *optName;
if ((objc < 2) || (objc > 4)) {
|
| ︙ | ︙ | |||
700 701 702 703 704 705 706 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | | | | | 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
EvalCmdErrMsg(
TCL_UNUSED(ClientData *),
Tcl_Interp *interp,
int result)
{
if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (\"eval\" body line %d)", Tcl_GetErrorLine(interp)));
}
return result;
}
int
Tcl_EvalObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNREvalObjCmd, clientData, objc, objv);
}
int
TclNREvalObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *objPtr;
Interp *iPtr = (Interp *) interp;
CmdFrame *invoker = NULL;
int word = 0;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
783 784 785 786 787 788 789 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | < | 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ExitObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_WideInt value;
if ((objc != 1) && (objc != 2)) {
Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?");
return TCL_ERROR;
}
if (objc == 1) {
value = 0;
} else if (TclGetWideBitsFromObj(interp, objv[1], &value) != TCL_OK) {
return TCL_ERROR;
}
Tcl_Exit((int)value);
return TCL_OK; /* Better not ever reach this! */
}
/*
*----------------------------------------------------------------------
*
* Tcl_ExprObjCmd --
|
| ︙ | ︙ | |||
832 833 834 835 836 837 838 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | | | 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ExprObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRExprObjCmd, clientData, objc, objv);
}
int
TclNRExprObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *resultPtr, *objPtr;
if (objc < 2) {
|
| ︙ | ︙ | |||
876 877 878 879 880 881 882 |
static int
ExprCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 |
static int
ExprCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj *resultPtr = (Tcl_Obj *)data[0];
Tcl_Obj *objPtr = (Tcl_Obj *)data[1];
if (objPtr != NULL) {
Tcl_DecrRefCount(objPtr);
}
if (result == TCL_OK) {
Tcl_SetObjResult(interp, resultPtr);
|
| ︙ | ︙ | |||
981 982 983 984 985 986 987 | * May update the access time on the file, if requested by the user. * *---------------------------------------------------------------------- */ static int FileAttrAccessTimeCmd( | | | | | | 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 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 |
* May update the access time on the file, if requested by the user.
*
*----------------------------------------------------------------------
*/
static int
FileAttrAccessTimeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
struct utimbuf tval;
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "name ?time?");
return TCL_ERROR;
}
if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
#if defined(_WIN32)
/* We use a value of 0 to indicate the access time not available */
if (Tcl_GetAccessTimeFromStat(&buf) == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not get access time for file \"%s\"",
TclGetString(objv[1])));
return TCL_ERROR;
}
#endif
if (objc == 3) {
/*
* Need separate variable for reading longs from an object on 64-bit
* platforms. [Bug 698146]
*/
Tcl_WideInt newTime;
if (TclGetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) {
return TCL_ERROR;
}
tval.actime = newTime;
tval.modtime = Tcl_GetModificationTimeFromStat(&buf);
if (Tcl_FSUtime(objv[1], &tval) != 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set access time for file \"%s\": %s",
TclGetString(objv[1]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
/*
* Do another stat to ensure that the we return the new recognized
* atime - hopefully the same as the one we sent in. However, fs's
* like FAT don't even know what atime is.
*/
if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(&buf)));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* FileAttrModifyTimeCmd --
|
| ︙ | ︙ | |||
1063 1064 1065 1066 1067 1068 1069 | * user. * *---------------------------------------------------------------------- */ static int FileAttrModifyTimeCmd( | | | | | | 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 |
* user.
*
*----------------------------------------------------------------------
*/
static int
FileAttrModifyTimeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
struct utimbuf tval;
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "name ?time?");
return TCL_ERROR;
}
if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
#if defined(_WIN32)
/* We use a value of 0 to indicate the modification time not available */
if (Tcl_GetModificationTimeFromStat(&buf) == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not get modification time for file \"%s\"",
TclGetString(objv[1])));
return TCL_ERROR;
}
#endif
if (objc == 3) {
/*
* Need separate variable for reading longs from an object on 64-bit
* platforms. [Bug 698146]
*/
Tcl_WideInt newTime;
if (TclGetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) {
return TCL_ERROR;
}
tval.actime = Tcl_GetAccessTimeFromStat(&buf);
tval.modtime = newTime;
if (Tcl_FSUtime(objv[1], &tval) != 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set modification time for file \"%s\": %s",
TclGetString(objv[1]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
/*
* Do another stat to ensure that the we return the new recognized
* mtime - hopefully the same as the one we sent in.
*/
if (GetStatBuf(interp, objv[1], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(&buf)));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* FileAttrLinkStatCmd --
|
| ︙ | ︙ | |||
1142 1143 1144 1145 1146 1147 1148 | * Writes to an array named by the user. * *---------------------------------------------------------------------- */ static int FileAttrLinkStatCmd( | | | 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 |
* Writes to an array named by the user.
*
*----------------------------------------------------------------------
*/
static int
FileAttrLinkStatCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
if (objc != 3) {
|
| ︙ | ︙ | |||
1178 1179 1180 1181 1182 1183 1184 | * Writes to an array named by the user. * *---------------------------------------------------------------------- */ static int FileAttrStatCmd( | | | 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 |
* Writes to an array named by the user.
*
*----------------------------------------------------------------------
*/
static int
FileAttrStatCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
if (objc != 3) {
|
| ︙ | ︙ | |||
1214 1215 1216 1217 1218 1219 1220 | * None. * *---------------------------------------------------------------------- */ static int FileAttrTypeCmd( | | | 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrTypeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
if (objc != 2) {
|
| ︙ | ︙ | |||
1252 1253 1254 1255 1256 1257 1258 | * None. * *---------------------------------------------------------------------- */ static int FileAttrSizeCmd( | | | 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrSizeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
if (objc != 2) {
|
| ︙ | ︙ | |||
1289 1290 1291 1292 1293 1294 1295 | * None. * *---------------------------------------------------------------------- */ static int FileAttrIsDirectoryCmd( | | | 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrIsDirectoryCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
int value = 0;
|
| ︙ | ︙ | |||
1327 1328 1329 1330 1331 1332 1333 | * None. * *---------------------------------------------------------------------- */ static int FileAttrIsExecutableCmd( | | | 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrIsExecutableCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
|
| ︙ | ︙ | |||
1358 1359 1360 1361 1362 1363 1364 | * None. * *---------------------------------------------------------------------- */ static int FileAttrIsExistingCmd( | | | 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrIsExistingCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
|
| ︙ | ︙ | |||
1389 1390 1391 1392 1393 1394 1395 | * None. * *---------------------------------------------------------------------- */ static int FileAttrIsFileCmd( | | | 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrIsFileCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_StatBuf buf;
int value = 0;
|
| ︙ | ︙ | |||
1427 1428 1429 1430 1431 1432 1433 | * None. * *---------------------------------------------------------------------- */ static int FileAttrIsOwnedCmd( | | | 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrIsOwnedCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
#ifdef __CYGWIN__
#define geteuid() (short)(geteuid)()
#endif
|
| ︙ | ︙ | |||
1474 1475 1476 1477 1478 1479 1480 | * None. * *---------------------------------------------------------------------- */ static int FileAttrIsReadableCmd( | | | 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrIsReadableCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
|
| ︙ | ︙ | |||
1505 1506 1507 1508 1509 1510 1511 | * None. * *---------------------------------------------------------------------- */ static int FileAttrIsWritableCmd( | | | 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileAttrIsWritableCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
|
| ︙ | ︙ | |||
1536 1537 1538 1539 1540 1541 1542 | * None. * *---------------------------------------------------------------------- */ static int PathDirNameCmd( | | | 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathDirNameCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *dirPtr;
if (objc != 2) {
|
| ︙ | ︙ | |||
1575 1576 1577 1578 1579 1580 1581 | * None. * *---------------------------------------------------------------------- */ static int PathExtensionCmd( | | | 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathExtensionCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *dirPtr;
if (objc != 2) {
|
| ︙ | ︙ | |||
1614 1615 1616 1617 1618 1619 1620 | * None. * *---------------------------------------------------------------------- */ static int PathRootNameCmd( | | | 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathRootNameCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *dirPtr;
if (objc != 2) {
|
| ︙ | ︙ | |||
1653 1654 1655 1656 1657 1658 1659 | * None. * *---------------------------------------------------------------------- */ static int PathTailCmd( | | | 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathTailCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *dirPtr;
if (objc != 2) {
|
| ︙ | ︙ | |||
1692 1693 1694 1695 1696 1697 1698 | * None. * *---------------------------------------------------------------------- */ static int PathFilesystemCmd( | | | | 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 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathFilesystemCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *fsInfo;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
fsInfo = Tcl_FSFileSystemInfo(objv[1]);
if (fsInfo == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("unrecognised path", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM",
Tcl_GetString(objv[1]), NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, fsInfo);
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
1733 1734 1735 1736 1737 1738 1739 | * None. * *---------------------------------------------------------------------- */ static int PathJoinCmd( | | | 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathJoinCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
1765 1766 1767 1768 1769 1770 1771 | * None. * *---------------------------------------------------------------------- */ static int PathNativeNameCmd( | | | 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathNativeNameCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_DString ds;
if (objc != 2) {
|
| ︙ | ︙ | |||
1802 1803 1804 1805 1806 1807 1808 | * None. * *---------------------------------------------------------------------- */ static int PathNormalizeCmd( | | | 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathNormalizeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *fileName;
if (objc != 2) {
|
| ︙ | ︙ | |||
1840 1841 1842 1843 1844 1845 1846 | * None. * *---------------------------------------------------------------------- */ static int PathSplitCmd( | | | 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathSplitCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *res;
if (objc != 2) {
|
| ︙ | ︙ | |||
1883 1884 1885 1886 1887 1888 1889 | * None. * *---------------------------------------------------------------------- */ static int PathTypeCmd( | | | 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PathTypeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *typeName;
if (objc != 2) {
|
| ︙ | ︙ | |||
1931 1932 1933 1934 1935 1936 1937 | * None. * *---------------------------------------------------------------------- */ static int FilesystemSeparatorCmd( | | | | | 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FilesystemSeparatorCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc < 1 || objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?name?");
return TCL_ERROR;
}
if (objc == 1) {
const char *separator = NULL;
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
separator = "/";
break;
case TCL_PLATFORM_WINDOWS:
separator = "\\";
break;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(separator, 1));
} else {
Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[1]);
if (separatorObj == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"unrecognised path", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM",
Tcl_GetString(objv[1]), NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, separatorObj);
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
1986 1987 1988 1989 1990 1991 1992 | * None. * *---------------------------------------------------------------------- */ static int FilesystemVolumesCmd( | | | 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FilesystemVolumesCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
2113 2114 2115 2116 2117 2118 2119 |
Tcl_Interp *interp, /* Interpreter for error reports. */
Tcl_Obj *varName, /* Name of associative array variable in which
* to store stat results. */
Tcl_StatBuf *statPtr) /* Pointer to buffer containing stat data to
* store in varName. */
{
Tcl_Obj *field, *value;
| | | 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 |
Tcl_Interp *interp, /* Interpreter for error reports. */
Tcl_Obj *varName, /* Name of associative array variable in which
* to store stat results. */
Tcl_StatBuf *statPtr) /* Pointer to buffer containing stat data to
* store in varName. */
{
Tcl_Obj *field, *value;
unsigned short mode;
/*
* Assume Tcl_ObjSetVar2() does not keep a copy of the field name!
*
* Might be a better idea to call Tcl_SetVar2Ex() instead, except we want
* to have an object (i.e. possibly cached) array variable name but a
* string element name, so no API exists. Messy.
|
| ︙ | ︙ | |||
2150 2151 2152 2153 2154 2155 2156 |
STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
STORE_ARY("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks));
#endif
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
STORE_ARY("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize));
#endif
| | | | | 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 |
STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size));
#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
STORE_ARY("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks));
#endif
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
STORE_ARY("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize));
#endif
STORE_ARY("atime", Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr)));
STORE_ARY("mtime", Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr)));
STORE_ARY("ctime", Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr)));
mode = (unsigned short) statPtr->st_mode;
STORE_ARY("mode", Tcl_NewWideIntObj(mode));
STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1));
#undef STORE_ARY
return TCL_OK;
}
|
| ︙ | ︙ | |||
2244 2245 2246 2247 2248 2249 2250 | * | | * ForPostNextCallback | * |____________________| * *---------------------------------------------------------------------- */ | < | | | | 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 |
* | |
* ForPostNextCallback |
* |____________________|
*
*----------------------------------------------------------------------
*/
int
Tcl_ForObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRForObjCmd, clientData, objc, objv);
}
int
TclNRForObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
ForIterData *iterPtr;
|
| ︙ | ︙ | |||
2292 2293 2294 2295 2296 2297 2298 |
static int
ForSetupCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 |
static int
ForSetupCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
ForIterData *iterPtr = (ForIterData *)data[0];
if (result != TCL_OK) {
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)");
}
TclSmallFreeEx(interp, iterPtr);
return result;
}
TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL);
return TCL_OK;
}
int
TclNRForIterCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
ForIterData *iterPtr = (ForIterData *)data[0];
Tcl_Obj *boolObj;
switch (result) {
case TCL_OK:
case TCL_CONTINUE:
/*
* We need to reset the result before evaluating the expression.
|
| ︙ | ︙ | |||
2347 2348 2349 2350 2351 2352 2353 |
static int
ForCondCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | | 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 |
static int
ForCondCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
ForIterData *iterPtr = (ForIterData *)data[0];
Tcl_Obj *boolObj = (Tcl_Obj *)data[1];
int value;
if (result != TCL_OK) {
Tcl_DecrRefCount(boolObj);
TclSmallFreeEx(interp, iterPtr);
return result;
} else if (Tcl_GetBooleanFromObj(interp, boolObj, &value) != TCL_OK) {
|
| ︙ | ︙ | |||
2385 2386 2387 2388 2389 2390 2391 |
static int
ForNextCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 |
static int
ForNextCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
ForIterData *iterPtr = (ForIterData *)data[0];
Tcl_Obj *next = iterPtr->next;
if ((result == TCL_OK) || (result == TCL_CONTINUE)) {
TclNRAddCallback(interp, ForPostNextCallback, iterPtr, NULL, NULL,
NULL);
/*
|
| ︙ | ︙ | |||
2409 2410 2411 2412 2413 2414 2415 |
static int
ForPostNextCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 |
static int
ForPostNextCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
ForIterData *iterPtr = (ForIterData *)data[0];
if ((result != TCL_BREAK) && (result != TCL_OK)) {
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)");
TclSmallFreeEx(interp, iterPtr);
}
return result;
|
| ︙ | ︙ | |||
2439 2440 2441 2442 2443 2444 2445 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | | | | | | | 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ForeachObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRForeachCmd, clientData, objc, objv);
}
int
TclNRForeachCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
return EachloopCmd(interp, TCL_EACH_KEEP_NONE, objc, objv);
}
int
Tcl_LmapObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRLmapCmd, clientData, objc, objv);
}
int
TclNRLmapCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
return EachloopCmd(interp, TCL_EACH_COLLECT, objc, objv);
}
static inline 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[])
{
int numLists = (objc-2) / 2;
struct ForeachState *statePtr;
int i, j, result;
if (objc < 4 || (objc%2 != 0)) {
Tcl_WrongNumArgs(interp, 1, objv,
"varList list ?varList list ...? command");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2514 2515 2516 2517 2518 2519 2520 |
* statePtr->argvList[i].
*
* The setting up of all of these pointers is moderately messy, but allows
* the rest of this code to be simple and for us to use a single memory
* allocation for better performance.
*/
| | | 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 |
* statePtr->argvList[i].
*
* The setting up of all of these pointers is moderately messy, but allows
* the rest of this code to be simple and for us to use a single memory
* allocation for better performance.
*/
statePtr = (struct ForeachState *)TclStackAlloc(interp,
sizeof(struct ForeachState) + 3 * numLists * sizeof(int)
+ 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *)));
memset(statePtr, 0,
sizeof(struct ForeachState) + 3 * numLists * sizeof(int)
+ 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *)));
statePtr->varvList = (Tcl_Obj ***) (statePtr + 1);
statePtr->argvList = statePtr->varvList + numLists;
|
| ︙ | ︙ | |||
2615 2616 2617 2618 2619 2620 2621 |
static int
ForeachLoopStep(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 |
static int
ForeachLoopStep(
ClientData data[],
Tcl_Interp *interp,
int result)
{
struct ForeachState *statePtr = (struct ForeachState *)data[0];
/*
* Process the result code from this run of the [foreach] body. Note that
* this switch uses fallthroughs in several places. Maintainer aware!
*/
switch (result) {
|
| ︙ | ︙ | |||
2757 2758 2759 2760 2761 2762 2763 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_FormatObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *resultPtr; /* Where result is stored finally. */
if (objc < 2) {
|
| ︙ | ︙ |
Changes to generic/tclCmdIL.c.
| ︙ | ︙ | |||
31 32 33 34 35 36 37 |
const char *strValuePtr;
Tcl_WideInt wideValue;
double doubleValue;
Tcl_Obj *objValuePtr;
} collationKey;
union { /* Object being sorted, or its index. */
Tcl_Obj *objPtr;
| | | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
const char *strValuePtr;
Tcl_WideInt wideValue;
double doubleValue;
Tcl_Obj *objValuePtr;
} collationKey;
union { /* Object being sorted, or its index. */
Tcl_Obj *objPtr;
int index;
} payload;
struct SortElement *nextPtr;/* Next element in the list, or NULL for end
* of list. */
} SortElement;
/*
* These function pointer types are used with the "lsearch" and "lsort"
|
| ︙ | ︙ | |||
95 96 97 98 99 100 101 | /* * Forward declarations for procedures defined in this file: */ static int DictionaryCompare(const char *left, const char *right); static Tcl_NRPostProc IfConditionCallback; | | < | < | < | < | < | < | < | < | < | < | < | < | < | < < | < | < | < | < | < | < | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 | /* * Forward declarations for procedures defined in this file: */ static int DictionaryCompare(const char *left, const char *right); static Tcl_NRPostProc IfConditionCallback; static Tcl_ObjCmdProc InfoArgsCmd; static Tcl_ObjCmdProc InfoBodyCmd; static Tcl_ObjCmdProc InfoCmdCountCmd; static Tcl_ObjCmdProc InfoCommandsCmd; static Tcl_ObjCmdProc InfoCompleteCmd; static Tcl_ObjCmdProc InfoDefaultCmd; /* TIP #348 - New 'info' subcommand 'errorstack' */ static Tcl_ObjCmdProc InfoErrorStackCmd; /* TIP #280 - New 'info' subcommand 'frame' */ static Tcl_ObjCmdProc InfoFrameCmd; static Tcl_ObjCmdProc InfoFunctionsCmd; static Tcl_ObjCmdProc InfoHostnameCmd; static Tcl_ObjCmdProc InfoLevelCmd; static Tcl_ObjCmdProc InfoLibraryCmd; static Tcl_ObjCmdProc InfoLoadedCmd; static Tcl_ObjCmdProc InfoNameOfExecutableCmd; static Tcl_ObjCmdProc InfoPatchLevelCmd; static Tcl_ObjCmdProc InfoProcsCmd; static Tcl_ObjCmdProc InfoScriptCmd; static Tcl_ObjCmdProc InfoSharedlibCmd; static Tcl_ObjCmdProc InfoCmdTypeCmd; static Tcl_ObjCmdProc InfoTclVersionCmd; static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr, SortInfo *infoPtr); static int SortCompare(SortElement *firstPtr, SortElement *second, SortInfo *infoPtr); static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr, SortInfo *infoPtr); |
| ︙ | ︙ | |||
202 203 204 205 206 207 208 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_IfObjCmd( | | | | | 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_IfObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRIfObjCmd, clientData, objc, objv);
}
int
TclNRIfObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *boolObj;
if (objc <= 1) {
|
| ︙ | ︙ | |||
247 248 249 250 251 252 253 |
IfConditionCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
int objc = PTR2INT(data[0]);
| | | | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 |
IfConditionCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
int objc = PTR2INT(data[0]);
Tcl_Obj *const *objv = (Tcl_Obj *const *)data[1];
int i = PTR2INT(data[2]);
Tcl_Obj *boolObj = (Tcl_Obj *)data[3];
int value, thenScriptIndex = 0;
const char *clause;
if (result != TCL_OK) {
TclDecrRefCount(boolObj);
return result;
}
|
| ︙ | ︙ | |||
385 386 387 388 389 390 391 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_IncrObjCmd( | | | 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_IncrObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *newValuePtr, *incrPtr;
if ((objc != 2) && (objc != 3)) {
|
| ︙ | ︙ | |||
466 467 468 469 470 471 472 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoArgsCmd( | | | | 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoArgsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
const char *name;
Proc *procPtr;
CompiledLocal *localPtr;
Tcl_Obj *listObjPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "procname");
|
| ︙ | ︙ | |||
529 530 531 532 533 534 535 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoBodyCmd( | | | | | 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoBodyCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
const char *name, *bytes;
Proc *procPtr;
int numBytes;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "procname");
return TCL_ERROR;
}
name = TclGetString(objv[1]);
|
| ︙ | ︙ | |||
590 591 592 593 594 595 596 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoCmdCountCmd( | | | 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoCmdCountCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
if (objc != 1) {
|
| ︙ | ︙ | |||
632 633 634 635 636 637 638 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoCommandsCmd( | | | | | 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoCommandsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *cmdName, *pattern;
const char *simplePattern;
Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Namespace *nsPtr;
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
Tcl_Obj *listPtr, *elemObjPtr;
int specificNsInPattern = 0;/* Init. to avoid compiler warning. */
Tcl_Command cmd;
int i;
/*
* Get the pattern and find the "effective namespace" in which to list
* commands.
*/
if (objc == 1) {
|
| ︙ | ︙ | |||
707 708 709 710 711 712 713 |
* Special case for when the pattern doesn't include any of glob's
* special characters. This lets us avoid scans of any hash tables.
*/
entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (entryPtr != NULL) {
if (specificNsInPattern) {
| | | | 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 |
* Special case for when the pattern doesn't include any of glob's
* special characters. This lets us avoid scans of any hash tables.
*/
entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (entryPtr != NULL) {
if (specificNsInPattern) {
cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr);
elemObjPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
} else {
cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
|
| ︙ | ︙ | |||
738 739 740 741 742 743 744 |
}
}
if (entryPtr == NULL) {
tablePtr = &globalNsPtr->cmdTable;
entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern);
}
if (entryPtr != NULL) {
| | | | | 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 |
}
}
if (entryPtr == NULL) {
tablePtr = &globalNsPtr->cmdTable;
entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern);
}
if (entryPtr != NULL) {
cmdName = (const char *)Tcl_GetHashKey(tablePtr, entryPtr);
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(cmdName, -1));
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
}
} else if (nsPtr->commandPathLength == 0 || specificNsInPattern) {
/*
* The pattern is non-trivial, but either there is no explicit path or
* there is an explicit namespace in the pattern. In both cases, the
* old matching scheme is perfect.
*/
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
if (specificNsInPattern) {
cmd = (Tcl_Command)Tcl_GetHashValue(entryPtr);
elemObjPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
} else {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
|
| ︙ | ︙ | |||
780 781 782 783 784 785 786 |
* in only those commands that aren't hidden by a command in the
* effective namespace.
*/
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
| | | 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 |
* in only those commands that aren't hidden by a command in the
* effective namespace.
*/
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(cmdName, -1));
}
}
|
| ︙ | ︙ | |||
811 812 813 814 815 816 817 |
* We keep a hash of the objects already added to the result list.
*/
Tcl_InitObjHashTable(&addedCommandsTable);
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (entryPtr != NULL) {
| | | 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 |
* We keep a hash of the objects already added to the result list.
*/
Tcl_InitObjHashTable(&addedCommandsTable);
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
(void) Tcl_CreateHashEntry(&addedCommandsTable,
elemObjPtr, &isNew);
}
|
| ︙ | ︙ | |||
837 838 839 840 841 842 843 |
continue;
}
if (pathNsPtr == globalNsPtr) {
foundGlobal = 1;
}
entryPtr = Tcl_FirstHashEntry(&pathNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
| | | 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 |
continue;
}
if (pathNsPtr == globalNsPtr) {
foundGlobal = 1;
}
entryPtr = Tcl_FirstHashEntry(&pathNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = (const char *)Tcl_GetHashKey(&pathNsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
(void) Tcl_CreateHashEntry(&addedCommandsTable,
elemObjPtr, &isNew);
if (isNew) {
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
|
| ︙ | ︙ | |||
864 865 866 867 868 869 870 |
* in only those commands that aren't hidden by a command in the
* effective namespace.
*/
if (!foundGlobal) {
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
| | | 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 |
* in only those commands that aren't hidden by a command in the
* effective namespace.
*/
if (!foundGlobal) {
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
if (Tcl_FindHashEntry(&addedCommandsTable,
(char *) elemObjPtr) == NULL) {
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
} else {
|
| ︙ | ︙ | |||
909 910 911 912 913 914 915 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoCompleteCmd( | | | 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoCompleteCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "command");
return TCL_ERROR;
|
| ︙ | ︙ | |||
946 947 948 949 950 951 952 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoDefaultCmd( | | | 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoDefaultCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
const char *procName, *argName;
Proc *procPtr;
|
| ︙ | ︙ | |||
1028 1029 1030 1031 1032 1033 1034 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoErrorStackCmd( | | | 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoErrorStackCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Interp *target;
Interp *iPtr;
|
| ︙ | ︙ | |||
1077 1078 1079 1080 1081 1082 1083 | * error, the result is an error message. * *---------------------------------------------------------------------- */ int TclInfoExistsCmd( | | | 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
int
TclInfoExistsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *varName;
Var *varPtr;
|
| ︙ | ︙ | |||
1122 1123 1124 1125 1126 1127 1128 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoFrameCmd( | | | 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoFrameCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
int level, code = TCL_OK;
CmdFrame *framePtr, **cmdFramePtrPtr = &iPtr->cmdFramePtr;
|
| ︙ | ︙ | |||
1309 1310 1311 1312 1313 1314 1315 |
break;
case TCL_LOCATION_BC: {
/*
* Execution of bytecode. Talk to the BC engine to fill out the frame.
*/
| | | 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 |
break;
case TCL_LOCATION_BC: {
/*
* Execution of bytecode. Talk to the BC engine to fill out the frame.
*/
CmdFrame *fPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
*fPtr = *framePtr;
/*
* Note:
* Type BC => f.data.eval.path is not used.
* f.data.tebc.codePtr is used instead.
|
| ︙ | ︙ | |||
1391 1392 1393 1394 1395 1396 1397 |
*/
TclNewObj(procNameObj);
Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr,
procNameObj);
ADD_PAIR("proc", procNameObj);
} else if (procPtr->cmdPtr->clientData) {
| | | | | 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 |
*/
TclNewObj(procNameObj);
Tcl_GetCommandFullName(interp, (Tcl_Command) procPtr->cmdPtr,
procNameObj);
ADD_PAIR("proc", procNameObj);
} else if (procPtr->cmdPtr->clientData) {
ExtraFrameInfo *efiPtr = (ExtraFrameInfo *)procPtr->cmdPtr->clientData;
int i;
/*
* This is a non-standard command. Luckily, it's told us how to
* render extra information about its frame.
*/
for (i=0 ; i<efiPtr->length ; i++) {
lv[lc++] = Tcl_NewStringObj(efiPtr->fields[i].name, -1);
if (efiPtr->fields[i].proc) {
lv[lc++] =
efiPtr->fields[i].proc(efiPtr->fields[i].clientData);
} else {
lv[lc++] = (Tcl_Obj *)efiPtr->fields[i].clientData;
}
}
}
}
/*
* 'level'. Common to all frame types. Conditional on having an associated
|
| ︙ | ︙ | |||
1462 1463 1464 1465 1466 1467 1468 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoFunctionsCmd( | | | 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoFunctionsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *script;
int code;
|
| ︙ | ︙ | |||
1527 1528 1529 1530 1531 1532 1533 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoHostnameCmd( | | | 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoHostnameCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *name;
if (objc != 1) {
|
| ︙ | ︙ | |||
1573 1574 1575 1576 1577 1578 1579 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoLevelCmd( | | | 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoLevelCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
if (objc == 1) { /* Just "info level" */
|
| ︙ | ︙ | |||
1647 1648 1649 1650 1651 1652 1653 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoLibraryCmd( | | | 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoLibraryCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *libDirName;
if (objc != 1) {
|
| ︙ | ︙ | |||
1694 1695 1696 1697 1698 1699 1700 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoLoadedCmd( | | | 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoLoadedCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *interpName, *packageName;
if (objc > 3) {
|
| ︙ | ︙ | |||
1742 1743 1744 1745 1746 1747 1748 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoNameOfExecutableCmd( | | | 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoNameOfExecutableCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
1778 1779 1780 1781 1782 1783 1784 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoPatchLevelCmd( | | | 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoPatchLevelCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *patchlevel;
if (objc != 1) {
|
| ︙ | ︙ | |||
1825 1826 1827 1828 1829 1830 1831 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoProcsCmd( | | | | 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 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoProcsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *cmdName, *pattern;
const char *simplePattern;
Namespace *nsPtr;
#ifdef INFO_PROCS_SEARCH_GLOBAL_NS
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
#endif
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
Tcl_Obj *listPtr, *elemObjPtr;
int specificNsInPattern = 0;/* Init. to avoid compiler warning. */
Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Command *cmdPtr, *realCmdPtr;
/*
* Get the pattern and find the "effective namespace" in which to list
* procs.
*/
|
| ︙ | ︙ | |||
1891 1892 1893 1894 1895 1896 1897 |
*/
listPtr = Tcl_NewListObj(0, NULL);
#ifndef INFO_PROCS_SEARCH_GLOBAL_NS
if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (entryPtr != NULL) {
| | | 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 |
*/
listPtr = Tcl_NewListObj(0, NULL);
#ifndef INFO_PROCS_SEARCH_GLOBAL_NS
if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (entryPtr != NULL) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
if (!TclIsProc(cmdPtr)) {
realCmdPtr = (Command *)
TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) {
goto simpleProcOK;
}
|
| ︙ | ︙ | |||
1916 1917 1918 1919 1920 1921 1922 |
}
}
} else
#endif /* !INFO_PROCS_SEARCH_GLOBAL_NS */
{
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (entryPtr != NULL) {
| | | | 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 |
}
}
} 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;
}
|
| ︙ | ︙ | |||
1954 1955 1956 1957 1958 1959 1960 | * namespace. */ #ifdef INFO_PROCS_SEARCH_GLOBAL_NS /* * If "info procs" worked like "info commands", returning the commands * also seen in the global namespace, then you would include this | | | | | 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 |
* namespace.
*/
#ifdef INFO_PROCS_SEARCH_GLOBAL_NS
/*
* If "info procs" worked like "info commands", returning the commands
* also seen in the global namespace, then you would include this
* code. As this could break backwards compatibility with 8.0-8.2, we
* decided not to "fix" it in 8.3, leaving the behavior slightly
* different.
*/
if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(cmdName, simplePattern)) {
if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
realCmdPtr = (Command *) TclGetOriginalCommand(
(Tcl_Command) cmdPtr);
if (TclIsProc(cmdPtr) || ((realCmdPtr != NULL)
&& TclIsProc(realCmdPtr))) {
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(cmdName, -1));
|
| ︙ | ︙ | |||
2012 2013 2014 2015 2016 2017 2018 | * script filename. * *---------------------------------------------------------------------- */ static int InfoScriptCmd( | | > | 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 |
* script filename.
*
*----------------------------------------------------------------------
*/
static int
InfoScriptCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
if ((objc != 1) && (objc != 2)) {
Tcl_WrongNumArgs(interp, 1, objv, "?filename?");
return TCL_ERROR;
}
if (objc == 2) {
if (iPtr->scriptFile != NULL) {
|
| ︙ | ︙ | |||
2059 2060 2061 2062 2063 2064 2065 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoSharedlibCmd( | | | 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoSharedlibCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
2097 2098 2099 2100 2101 2102 2103 | * error, the result is an error message. * *---------------------------------------------------------------------- */ static int InfoTclVersionCmd( | | | 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
InfoTclVersionCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *version;
if (objc != 1) {
|
| ︙ | ︙ | |||
2140 2141 2142 2143 2144 2145 2146 | * message. * *---------------------------------------------------------------------- */ static int InfoCmdTypeCmd( | | | 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 |
* message.
*
*----------------------------------------------------------------------
*/
static int
InfoCmdTypeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Command command;
if (objc != 2) {
|
| ︙ | ︙ | |||
2191 2192 2193 2194 2195 2196 2197 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_JoinObjCmd( | | | < | 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_JoinObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int length, listLen;
Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs;
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2277 2278 2279 2280 2281 2282 2283 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LassignObjCmd( | | | 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LassignObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listCopyPtr;
Tcl_Obj **listObjv; /* The contents of the list. */
int listObjc; /* The length of the list. */
|
| ︙ | ︙ | |||
2351 2352 2353 2354 2355 2356 2357 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LindexObjCmd( | | < | 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LindexObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *elemPtr; /* Pointer to the element being extracted. */
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2410 2411 2412 2413 2414 2415 2416 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LinsertObjCmd( | | | < | | 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LinsertObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listPtr;
int index, len, result;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "list index ?element ...?");
return TCL_ERROR;
}
result = TclListObjLength(interp, objv[1], &len);
|
| ︙ | ︙ | |||
2439 2440 2441 2442 2443 2444 2445 |
* appended to the list.
*/
result = TclGetIntForIndexM(interp, objv[2], /*end*/ len, &index);
if (result != TCL_OK) {
return result;
}
| | | | 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 |
* appended to the list.
*/
result = TclGetIntForIndexM(interp, objv[2], /*end*/ len, &index);
if (result != TCL_OK) {
return result;
}
if (index > len) {
index = len;
}
/*
* If the list object is unshared we can modify it directly. Otherwise we
* create a copy to modify: this is "copy on write".
*/
listPtr = objv[1];
if (Tcl_IsShared(listPtr)) {
listPtr = TclListObjCopy(NULL, listPtr);
}
if ((objc == 4) && (index == len)) {
/*
* Special case: insert one element at the end of the list.
*/
Tcl_ListObjAppendElement(NULL, listPtr, objv[3]);
} else {
if (TCL_OK != Tcl_ListObjReplace(interp, listPtr, index, 0,
|
| ︙ | ︙ | |||
2493 2494 2495 2496 2497 2498 2499 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_ListObjCmd( | | | | | 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* The argument objects. */
{
/*
* If there are no list elements, the result is an empty object.
* Otherwise set the interpreter's result object to be a list object.
*/
|
| ︙ | ︙ | |||
2529 2530 2531 2532 2533 2534 2535 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LlengthObjCmd( | | | | 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LlengthObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* Argument objects. */
{
int listLen, result;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "list");
return TCL_ERROR;
|
| ︙ | ︙ | |||
2575 2576 2577 2578 2579 2580 2581 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LpopObjCmd( | | | | 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LpopObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* Argument objects. */
{
int listLen, result;
Tcl_Obj *elemPtr, *stored;
Tcl_Obj *listPtr, **elemPtrs;
if (objc < 2) {
|
| ︙ | ︙ | |||
2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 |
/*
* First, extract the element to be returned.
* TclLindexFlat adds a ref count which is handled.
*/
if (objc == 2) {
elemPtr = elemPtrs[listLen - 1];
Tcl_IncrRefCount(elemPtr);
} else {
elemPtr = TclLindexFlat(interp, listPtr, objc-2, objv+2);
if (elemPtr == NULL) {
return TCL_ERROR;
| > > > > > > > > | 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 |
/*
* First, extract the element to be returned.
* TclLindexFlat adds a ref count which is handled.
*/
if (objc == 2) {
if (!listLen) {
/* empty list, throw the same error as with index "end" */
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"index \"end\" out of range", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
"OUTOFRANGE", NULL);
return TCL_ERROR;
}
elemPtr = elemPtrs[listLen - 1];
Tcl_IncrRefCount(elemPtr);
} else {
elemPtr = TclLindexFlat(interp, listPtr, objc-2, objv+2);
if (elemPtr == NULL) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
2668 2669 2670 2671 2672 2673 2674 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LrangeObjCmd( | | | | < | 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LrangeObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* Argument objects. */
{
int listLen, first, last, result;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "list first last");
return TCL_ERROR;
}
result = TclListObjLength(interp, objv[1], &listLen);
|
| ︙ | ︙ | |||
2725 2726 2727 2728 2729 2730 2731 |
*/
static int
LremoveIndexCompare(
const void *el1Ptr,
const void *el2Ptr)
{
| | | | | | | 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 |
*/
static int
LremoveIndexCompare(
const void *el1Ptr,
const void *el2Ptr)
{
int idx1 = *((const int *) el1Ptr);
int idx2 = *((const int *) el2Ptr);
/*
* This will put the larger element first.
*/
return (idx1 < idx2) ? 1 : (idx1 > idx2) ? -1 : 0;
}
int
Tcl_LremoveObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, idxc;
int listLen, *idxv, prevIdx, first, num;
Tcl_Obj *listObj;
/*
* Parse the arguments.
*/
if (objc < 2) {
|
| ︙ | ︙ | |||
2765 2766 2767 2768 2769 2770 2771 |
}
idxc = objc - 2;
if (idxc == 0) {
Tcl_SetObjResult(interp, listObj);
return TCL_OK;
}
| | | | | 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 |
}
idxc = objc - 2;
if (idxc == 0) {
Tcl_SetObjResult(interp, listObj);
return TCL_OK;
}
idxv = (int *)ckalloc((objc - 2) * sizeof(int));
for (i = 2; i < objc; i++) {
if (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1,
&idxv[i - 2]) != TCL_OK) {
ckfree(idxv);
return TCL_ERROR;
}
}
/*
* Sort the indices, large to small so that when we remove an index we
* don't change the indices still to be processed.
*/
if (idxc > 1) {
qsort(idxv, idxc, sizeof(int), LremoveIndexCompare);
}
/*
* Make our working copy, then do the actual removes piecemeal.
*/
if (Tcl_IsShared(listObj)) {
|
| ︙ | ︙ | |||
2832 2833 2834 2835 2836 2837 2838 |
num = 1;
first = idx;
}
}
if (num != 0) {
(void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL);
}
| | | 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 |
num = 1;
first = idx;
}
}
if (num != 0) {
(void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL);
}
ckfree(idxv);
Tcl_SetObjResult(interp, listObj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2856 2857 2858 2859 2860 2861 2862 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LrepeatObjCmd( | | | | | 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LrepeatObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[])
/* The argument objects. */
{
int elementCount, i, totalElems;
Tcl_Obj *listPtr, **dataArray = NULL;
/*
* Check arguments for legality:
|
| ︙ | ︙ | |||
2924 2925 2926 2927 2928 2929 2930 |
* single value being repeated separately to permit the compiler as much
* room as possible to optimize a loop that might be run a very large
* number of times.
*/
CLANG_ASSERT(dataArray || totalElems == 0 );
if (objc == 1) {
| | | 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 |
* single value being repeated separately to permit the compiler as much
* room as possible to optimize a loop that might be run a very large
* number of times.
*/
CLANG_ASSERT(dataArray || totalElems == 0 );
if (objc == 1) {
Tcl_Obj *tmpPtr = objv[0];
tmpPtr->refCount += elementCount;
for (i=0 ; i<elementCount ; i++) {
dataArray[i] = tmpPtr;
}
} else {
int j, k = 0;
|
| ︙ | ︙ | |||
2965 2966 2967 2968 2969 2970 2971 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LreplaceObjCmd( | | | < | | 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LreplaceObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *listPtr;
int first, last, listLen, numToDelete, result;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"list first last ?element ...?");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
3003 3004 3005 3006 3007 3008 3009 |
result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last);
if (result != TCL_OK) {
return result;
}
if (first == TCL_INDEX_NONE) {
first = 0;
| > | | | | 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 |
result = TclGetIntForIndexM(interp, objv[3], /*end*/ listLen-1, &last);
if (result != TCL_OK) {
return result;
}
if (first == TCL_INDEX_NONE) {
first = 0;
}
if (first > listLen) {
first = listLen;
}
if (last >= listLen) {
last = listLen - 1;
}
if (first <= last) {
numToDelete = last - first + 1;
} else {
numToDelete = 0;
}
/*
* If the list object is unshared we can modify it directly, otherwise we
|
| ︙ | ︙ | |||
3066 3067 3068 3069 3070 3071 3072 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LreverseObjCmd( | | | 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LreverseObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
Tcl_Obj **elemv;
int elemc, i, j;
|
| ︙ | ︙ | |||
3145 3146 3147 3148 3149 3150 3151 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LsearchObjCmd( | | | < | | | 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LsearchObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
const char *bytes, *patternBytes;
int i, match, index, result=TCL_OK, listc, length, elemLen, bisect;
int allocatedIndexVector = 0;
int dataType, isIncreasing, lower, upper, start, groupSize, groupOffset;
Tcl_WideInt patWide, objWide;
int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
double patDouble, objDouble;
SortInfo sortInfo;
Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr;
SortStrCmpFn_t strCmpFn = TclUtfCmp;
Tcl_RegExp regexp = NULL;
static const char *const options[] = {
|
| ︙ | ︙ | |||
3311 3312 3313 3314 3315 3316 3317 | Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-stride\" option must be " "followed by stride length", -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); result = TCL_ERROR; goto done; } | | | | < | 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-stride\" option must be "
"followed by stride length", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
result = TCL_ERROR;
goto done;
}
if (Tcl_GetIntFromObj(interp, objv[i+1], &groupSize) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (groupSize < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"stride length must be at least 1", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
"BADSTRIDE", NULL);
result = TCL_ERROR;
goto done;
}
i++;
break;
case LSEARCH_INDEX: { /* -index */
Tcl_Obj **indices;
int j;
if (allocatedIndexVector) {
|
| ︙ | ︙ | |||
3363 3364 3365 3366 3367 3368 3369 | case 0: sortInfo.indexv = NULL; break; case 1: sortInfo.indexv = &sortInfo.singleIndex; break; default: | | | | | 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 |
case 0:
sortInfo.indexv = NULL;
break;
case 1:
sortInfo.indexv = &sortInfo.singleIndex;
break;
default:
sortInfo.indexv = (int *)
TclStackAlloc(interp, sizeof(int) * sortInfo.indexc);
allocatedIndexVector = 1; /* Cannot use indexc field, as it
* might be decreased by 1 later. */
}
/*
* Fill the array by parsing each index. We don't know whether
* their scale is sensible yet, but we at least perform the
* syntactic check here.
*/
for (j=0 ; j<sortInfo.indexc ; j++) {
int encoded = 0;
if (TclIndexEncode(interp, indices[j], TCL_INDEX_NONE,
TCL_INDEX_NONE, &encoded) != TCL_OK) {
result = TCL_ERROR;
}
if (encoded == (int)TCL_INDEX_NONE) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"index \"%s\" out of range",
TclGetString(indices[j])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
"OUTOFRANGE", NULL);
result = TCL_ERROR;
}
if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (-index option item number %d)", j));
|
| ︙ | ︙ | |||
3483 3484 3485 3486 3487 3488 3489 |
if (sortInfo.indexc > 0) {
/*
* Use the first value in the list supplied to -index as the
* offset of the element within each group by which to sort.
*/
groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1);
| | | 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 |
if (sortInfo.indexc > 0) {
/*
* Use the first value in the list supplied to -index as the
* offset of the element within each group by which to sort.
*/
groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1);
if (groupOffset < 0 || groupOffset >= groupSize) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"when used with \"-stride\", the leading \"-index\""
" value must be within the group", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
"BADINDEX", NULL);
result = TCL_ERROR;
goto done;
|
| ︙ | ︙ | |||
3523 3524 3525 3526 3527 3528 3529 | } /* * If the search started past the end of the list, we just return a * "did not match anything at all" result straight away. [Bug 1374778] */ | | | 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 |
}
/*
* If the search started past the end of the list, we just return a
* "did not match anything at all" result straight away. [Bug 1374778]
*/
if (start > listc-1) {
if (allMatches || inlineReturn) {
Tcl_ResetResult(interp);
} else {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1));
}
goto done;
}
|
| ︙ | ︙ | |||
3654 3655 3656 3657 3658 3659 3660 |
}
break;
}
if (match == 0) {
/*
* Normally, binary search is written to stop when it finds a
* match. If there are duplicates of an element in the list,
| | | | 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 |
}
break;
}
if (match == 0) {
/*
* Normally, binary search is written to stop when it finds a
* match. If there are duplicates of an element in the list,
* our first match might not be the first occurrence.
* Consider: 0 0 0 1 1 1 2 2 2
*
* To maintain consistancy with standard lsearch semantics, we
* must find the leftmost occurrence of the pattern in the
* list. Thus we don't just stop searching here. This
* variation means that a search always makes log n
* comparisons (normal binary search might "get lucky" with an
* early comparison).
*
* In bisect mode though, we want the last of equals.
*/
|
| ︙ | ︙ | |||
3731 3732 3733 3734 3735 3736 3737 |
* This split allows for more optimal compilation of
* memcmp/strcasecmp.
*/
if (noCase) {
match = (TclUtfCasecmp(bytes, patternBytes) == 0);
} else {
| | > | 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 |
* This split allows for more optimal compilation of
* memcmp/strcasecmp.
*/
if (noCase) {
match = (TclUtfCasecmp(bytes, patternBytes) == 0);
} else {
match = (memcmp(bytes, patternBytes,
(size_t) length) == 0);
}
}
break;
case DICTIONARY:
bytes = TclGetString(itemPtr);
match = (DictionaryCompare(bytes, patternBytes) == 0);
|
| ︙ | ︙ | |||
3815 3816 3817 3818 3819 3820 3821 |
} else {
itemPtr = listv[i];
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
}
} else if (returnSubindices) {
int j;
| | | | | | 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 |
} else {
itemPtr = listv[i];
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
}
} else if (returnSubindices) {
int j;
itemPtr = Tcl_NewWideIntObj(i+groupOffset);
for (j=0 ; j<sortInfo.indexc ; j++) {
Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewWideIntObj(
TclIndexDecode(sortInfo.indexv[j], listc)));
}
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;
itemPtr = Tcl_NewWideIntObj(index+groupOffset);
for (j=0 ; j<sortInfo.indexc ; j++) {
Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewWideIntObj(
TclIndexDecode(sortInfo.indexv[j], listc)));
}
Tcl_SetObjResult(interp, itemPtr);
} else {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(index));
}
} else if (index < 0) {
|
| ︙ | ︙ | |||
3898 3899 3900 3901 3902 3903 3904 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LsetObjCmd( | | | 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LsetObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
Tcl_Obj *listPtr; /* Pointer to the list being altered. */
Tcl_Obj *finalValuePtr; /* Value finally assigned to the variable. */
|
| ︙ | ︙ | |||
3983 3984 3985 3986 3987 3988 3989 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_LsortObjCmd( | | | | < < > > | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LsortObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
int i, j, index, indices, length, nocase = 0, indexc;
int sortMode = SORTMODE_ASCII;
int group, groupSize, groupOffset, idx, allocatedIndexVector = 0;
Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr;
size_t elmArrSize;
SortElement *elementArray = NULL, *elementPtr;
SortInfo sortInfo; /* Information about this sort that needs to
* be passed to the comparison function. */
# define MAXCALLOC 1024000
# define NUM_LISTS 30
SortElement *subList[NUM_LISTS+1];
/* This array holds pointers to temporary
* lists built during the merge sort. Element
* i of the array holds a list of length
* 2**i. */
static const char *const switches[] = {
|
| ︙ | ︙ | |||
4069 4070 4071 4072 4073 4074 4075 |
case LSORT_DICTIONARY:
sortInfo.sortMode = SORTMODE_DICTIONARY;
break;
case LSORT_INCREASING:
sortInfo.isIncreasing = 1;
break;
case LSORT_INDEX: {
| | | | | | | | 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 |
case LSORT_DICTIONARY:
sortInfo.sortMode = SORTMODE_DICTIONARY;
break;
case LSORT_INCREASING:
sortInfo.isIncreasing = 1;
break;
case LSORT_INDEX: {
int sortindex;
Tcl_Obj **indexv;
if (i == objc-2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-index\" option must be followed by list index",
-1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
if (TclListObjGetElements(interp, objv[i+1], &sortindex,
&indexv) != TCL_OK) {
sortInfo.resultCode = TCL_ERROR;
goto done;
}
/*
* Check each of the indices for syntactic correctness. Note that
* we do not store the converted values here because we do not
* know if this is the only -index option yet and so we can't
* allocate any space; that happens after the scan through all the
* options is done.
*/
for (j=0 ; j<sortindex ; j++) {
int encoded = 0;
int result = TclIndexEncode(interp, indexv[j],
TCL_INDEX_NONE, TCL_INDEX_NONE, &encoded);
if ((result == TCL_OK) && (encoded == (int)TCL_INDEX_NONE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"index \"%s\" out of range",
TclGetString(indexv[j])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
"OUTOFRANGE", NULL);
result = TCL_ERROR;
}
if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (-index option item number %d)", j));
sortInfo.resultCode = TCL_ERROR;
goto done;
}
}
indexPtr = objv[i+1];
i++;
break;
|
| ︙ | ︙ | |||
4142 4143 4144 4145 4146 4147 4148 | Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-stride\" option must be " "followed by stride length", -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); sortInfo.resultCode = TCL_ERROR; goto done; } | | | < | 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-stride\" option must be "
"followed by stride length", -1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
if (Tcl_GetIntFromObj(interp, objv[i+1], &groupSize) != TCL_OK) {
sortInfo.resultCode = TCL_ERROR;
goto done;
}
if (groupSize < 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"stride length must be at least 2", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
"BADSTRIDE", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
group = 1;
i++;
break;
}
}
if (nocase && (sortInfo.sortMode == SORTMODE_ASCII)) {
sortInfo.sortMode = SORTMODE_ASCII_NC;
|
| ︙ | ︙ | |||
4182 4183 4184 4185 4186 4187 4188 | case 0: sortInfo.indexv = NULL; break; case 1: sortInfo.indexv = &sortInfo.singleIndex; break; default: | | | | 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 |
case 0:
sortInfo.indexv = NULL;
break;
case 1:
sortInfo.indexv = &sortInfo.singleIndex;
break;
default:
sortInfo.indexv = (int *)
TclStackAlloc(interp, sizeof(int) * sortInfo.indexc);
allocatedIndexVector = 1; /* Cannot use indexc field, as it
* might be decreased by 1 later. */
}
for (j=0 ; j<sortInfo.indexc ; j++) {
/* Prescreened values, no errors or out of range possible */
TclIndexEncode(NULL, indexv[j], TCL_INDEX_NONE,
TCL_INDEX_NONE, &sortInfo.indexv[j]);
}
}
listObj = objv[objc-1];
|
| ︙ | ︙ | |||
4262 4263 4264 4265 4266 4267 4268 |
if (sortInfo.indexc > 0) {
/*
* Use the first value in the list supplied to -index as the
* offset of the element within each group by which to sort.
*/
groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1);
| | | 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 |
if (sortInfo.indexc > 0) {
/*
* Use the first value in the list supplied to -index as the
* offset of the element within each group by which to sort.
*/
groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1);
if (groupOffset < 0 || groupOffset >= groupSize) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"when used with \"-stride\", the leading \"-index\""
" value must be within the group", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
"BADINDEX", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
|
| ︙ | ︙ | |||
4320 4321 4322 4323 4324 4325 4326 |
}
/*
* The following loop creates a SortElement for each list element and
* begins sorting it into the sublists as it appears.
*/
| | > > > > > > > > > > > > | 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 |
}
/*
* The following loop creates a SortElement for each list element and
* begins sorting it into the sublists as it appears.
*/
elmArrSize = length * sizeof(SortElement);
if (elmArrSize <= MAXCALLOC) {
elementArray = (SortElement *)ckalloc(elmArrSize);
} else {
elementArray = (SortElement *)malloc(elmArrSize);
}
if (!elementArray) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no enough memory to proccess sort of %d items", length));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
sortInfo.resultCode = TCL_ERROR;
goto done;
}
for (i=0; i < length; i++) {
idx = groupSize * i + groupOffset;
if (indexc) {
/*
* If this is an indexed sort, retrieve the corresponding element
*/
|
| ︙ | ︙ | |||
4416 4417 4418 4419 4420 4421 4422 |
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) {
| | | | 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 |
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) {
objPtr = Tcl_NewWideIntObj(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) {
objPtr = Tcl_NewWideIntObj(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;
|
| ︙ | ︙ | |||
4453 4454 4455 4456 4457 4458 4459 |
TclDecrRefCount(listObj);
sortInfo.compareCmdPtr = NULL;
}
if (allocatedIndexVector) {
TclStackFree(interp, sortInfo.indexv);
}
if (elementArray) {
| > > > | > | 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 |
TclDecrRefCount(listObj);
sortInfo.compareCmdPtr = NULL;
}
if (allocatedIndexVector) {
TclStackFree(interp, sortInfo.indexv);
}
if (elementArray) {
if (elmArrSize <= MAXCALLOC) {
ckfree((char *)elementArray);
} else {
free((char *)elementArray);
}
}
return sortInfo.resultCode;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4695 4696 4697 4698 4699 4700 4701 |
*----------------------------------------------------------------------
*/
static int
DictionaryCompare(
const char *left, const char *right) /* The strings to compare. */
{
| | | 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 |
*----------------------------------------------------------------------
*/
static int
DictionaryCompare(
const char *left, const char *right) /* The strings to compare. */
{
int uniLeft = 0, uniRight = 0, uniLeftLower, uniRightLower;
int diff, zeros;
int secondaryDiff = 0;
while (1) {
if (isdigit(UCHAR(*right)) /* INTL: digit */
&& isdigit(UCHAR(*left))) { /* INTL: digit */
/*
|
| ︙ | ︙ | |||
4764 4765 4766 4767 4768 4769 4770 |
/*
* Convert character to Unicode for comparison purposes. If either
* string is at the terminating null, do a byte-wise comparison and
* bail out immediately.
*/
if ((*left != '\0') && (*right != '\0')) {
| | | | 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 |
/*
* Convert character to Unicode for comparison purposes. If either
* string is at the terminating null, do a byte-wise comparison and
* bail out immediately.
*/
if ((*left != '\0') && (*right != '\0')) {
left += TclUtfToUCS4(left, &uniLeft);
right += TclUtfToUCS4(right, &uniRight);
/*
* Convert both chars to lower for the comparison, because
* dictionary sorts are case insensitve. Covert to lower, not
* upper, so chars between Z and a will sort before A (where most
* other interesting punctuations occur).
*/
|
| ︙ | ︙ |
Changes to generic/tclCmdMZ.c.
| ︙ | ︙ | |||
78 79 80 81 82 83 84 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_PwdObjCmd( | | | 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_PwdObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *retVal;
if (objc != 1) {
|
| ︙ | ︙ | |||
118 119 120 121 122 123 124 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_RegexpObjCmd( | | > | < | | 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_RegexpObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, indices, match, about, offset, all, doinline, numMatchesSaved;
int cflags, eflags, stringLength, matchLength;
Tcl_RegExp regExpr;
Tcl_Obj *objPtr, *startIndex = NULL, *resultPtr = NULL;
Tcl_RegExpInfo info;
static const char *const options[] = {
"-all", "-about", "-indices", "-inline",
"-expanded", "-line", "-linestop", "-lineanchor",
"-nocase", "-start", "--", NULL
};
enum options {
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;
cflags = TCL_REG_ADVANCED;
offset = 0;
all = 0;
doinline = 0;
for (i = 1; i < objc; i++) {
const char *name;
int index;
|
| ︙ | ︙ | |||
187 188 189 190 191 192 193 |
case REGEXP_LINESTOP:
cflags |= TCL_REG_NLSTOP;
break;
case REGEXP_LINEANCHOR:
cflags |= TCL_REG_NLANCH;
break;
case REGEXP_START: {
| | | | 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 |
case REGEXP_LINESTOP:
cflags |= TCL_REG_NLSTOP;
break;
case REGEXP_LINEANCHOR:
cflags |= TCL_REG_NLANCH;
break;
case REGEXP_START: {
int temp;
if (++i >= objc) {
goto endOfForLoop;
}
if (TclGetIntForIndexM(interp, objv[i], INT_MAX - 1, &temp) != TCL_OK) {
goto optionError;
}
if (startIndex) {
Tcl_DecrRefCount(startIndex);
}
startIndex = objv[i];
Tcl_IncrRefCount(startIndex);
|
| ︙ | ︙ | |||
257 258 259 260 261 262 263 |
objPtr = objv[1];
stringLength = Tcl_GetCharLength(objPtr);
if (startIndex) {
TclGetIntForIndexM(interp, startIndex, stringLength, &offset);
Tcl_DecrRefCount(startIndex);
| | | | 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 |
objPtr = objv[1];
stringLength = Tcl_GetCharLength(objPtr);
if (startIndex) {
TclGetIntForIndexM(interp, startIndex, stringLength, &offset);
Tcl_DecrRefCount(startIndex);
if (offset < 0) {
offset = 0;
}
}
regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags);
if (regExpr == NULL) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
302 303 304 305 306 307 308 |
* Pass either 0 or TCL_REG_NOTBOL in the eflags. Passing
* TCL_REG_NOTBOL indicates that the character at offset should not be
* considered the start of the line. If for example the pattern {^} is
* passed and -start is positive, then the pattern will not match the
* start of the string unless the previous character is a newline.
*/
| | | | 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 |
* Pass either 0 or TCL_REG_NOTBOL in the eflags. Passing
* TCL_REG_NOTBOL indicates that the character at offset should not be
* considered the start of the line. If for example the pattern {^} is
* passed and -start is positive, then the pattern will not match the
* start of the string unless the previous character is a newline.
*/
if (offset == 0) {
eflags = 0;
} else if (offset > stringLength) {
eflags = TCL_REG_NOTBOL;
} else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') {
eflags = 0;
} else {
eflags = TCL_REG_NOTBOL;
}
|
| ︙ | ︙ | |||
360 361 362 363 364 365 366 |
resultPtr = Tcl_NewObj();
}
}
for (i = 0; i < objc; i++) {
Tcl_Obj *newPtr;
if (indices) {
| | | | | | | | | | 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 |
resultPtr = Tcl_NewObj();
}
}
for (i = 0; i < objc; i++) {
Tcl_Obj *newPtr;
if (indices) {
int start, end;
Tcl_Obj *objs[2];
/*
* Only adjust the match area if there was a match for that
* area. (Scriptics Bug 4391/SF Bug #219232)
*/
if (i <= info.nsubs && info.matches[i].start >= 0) {
start = offset + info.matches[i].start;
end = offset + info.matches[i].end;
/*
* Adjust index so it refers to the last character in the
* match instead of the first character after the match.
*/
if (end >= offset) {
end--;
}
} else {
start = -1;
end = -1;
}
objs[0] = Tcl_NewWideIntObj(start);
objs[1] = Tcl_NewWideIntObj(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 {
newPtr = Tcl_NewObj();
}
}
|
| ︙ | ︙ | |||
440 441 442 443 444 445 446 |
* these cases we always want to bump the index up one.
*/
if (matchLength == 0) {
offset++;
}
all++;
| | | 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 |
* these cases we always want to bump the index up one.
*/
if (matchLength == 0) {
offset++;
}
all++;
if (offset >= stringLength) {
break;
}
}
/*
* Set the interpreter's object result to an integer object with value 1
* if -all wasn't specified, otherwise it's all-1 (the number of times
|
| ︙ | ︙ | |||
478 479 480 481 482 483 484 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_RegsubObjCmd( | | | < | | | | 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_RegsubObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int idx, result, cflags, all, wlen, wsublen, numMatches, offset;
int start, end, subStart, subEnd, match, command, numParts;
Tcl_RegExp regExpr;
Tcl_RegExpInfo info;
Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL;
Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec = 0, *wend;
static const char *const options[] = {
"-all", "-command", "-expanded", "-line",
"-linestop", "-lineanchor", "-nocase", "-start",
"--", NULL
};
enum options {
REGSUB_ALL, REGSUB_COMMAND, REGSUB_EXPANDED, REGSUB_LINE,
REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_NOCASE, REGSUB_START,
REGSUB_LAST
};
cflags = TCL_REG_ADVANCED;
all = 0;
offset = 0;
command = 0;
resultPtr = NULL;
for (idx = 1; idx < objc; idx++) {
const char *name;
int index;
name = TclGetString(objv[idx]);
if (name[0] != '-') {
break;
}
|
| ︙ | ︙ | |||
543 544 545 546 547 548 549 |
case REGSUB_LINESTOP:
cflags |= TCL_REG_NLSTOP;
break;
case REGSUB_LINEANCHOR:
cflags |= TCL_REG_NLANCH;
break;
case REGSUB_START: {
| | | | | | | | | < | | | | | | 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 |
case REGSUB_LINESTOP:
cflags |= TCL_REG_NLSTOP;
break;
case REGSUB_LINEANCHOR:
cflags |= TCL_REG_NLANCH;
break;
case REGSUB_START: {
int temp;
if (++idx >= objc) {
goto endOfForLoop;
}
if (TclGetIntForIndexM(interp, objv[idx], INT_MAX - 1, &temp) != TCL_OK) {
goto optionError;
}
if (startIndex) {
Tcl_DecrRefCount(startIndex);
}
startIndex = objv[idx];
Tcl_IncrRefCount(startIndex);
break;
}
case REGSUB_LAST:
idx++;
goto endOfForLoop;
}
}
endOfForLoop:
if (objc-idx < 3 || objc-idx > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"?-option ...? exp string subSpec ?varName?");
optionError:
if (startIndex) {
Tcl_DecrRefCount(startIndex);
}
return TCL_ERROR;
}
objc -= idx;
objv += idx;
if (startIndex) {
int stringLength = Tcl_GetCharLength(objv[1]);
TclGetIntForIndexM(interp, startIndex, stringLength, &offset);
Tcl_DecrRefCount(startIndex);
if (offset < 0) {
offset = 0;
}
}
if (all && (offset == 0) && (command == 0)
&& (strpbrk(TclGetString(objv[2]), "&\\") == NULL)
&& (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) {
/*
* This is a simple one pair string map situation. We make use of a
* slightly modified version of the one pair STR_MAP code.
*/
int slen, nocase, wsrclc;
int (*strCmpFn)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long);
Tcl_UniChar *p;
numMatches = 0;
nocase = (cflags & TCL_REG_NOCASE);
strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen);
wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen);
wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen);
wend = wstring + wlen - (slen ? slen - 1 : 0);
result = TCL_OK;
if (slen == 0) {
/*
* regsub behavior for "" matches between each character. 'string
* map' skips the "" case.
|
| ︙ | ︙ | |||
631 632 633 634 635 636 637 |
wlen = 0;
}
} else {
wsrclc = Tcl_UniCharToLower(*wsrc);
for (p = wfirstChar = wstring; wstring < wend; wstring++) {
if ((*wstring == *wsrc ||
(nocase && Tcl_UniCharToLower(*wstring)==wsrclc)) &&
| | > | 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 |
wlen = 0;
}
} else {
wsrclc = Tcl_UniCharToLower(*wsrc);
for (p = wfirstChar = wstring; wstring < wend; wstring++) {
if ((*wstring == *wsrc ||
(nocase && Tcl_UniCharToLower(*wstring)==wsrclc)) &&
(slen==1 || (strCmpFn(wstring, wsrc,
(unsigned long) slen) == 0))) {
if (numMatches == 0) {
resultPtr = Tcl_NewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
}
if (p != wstring) {
Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p);
p = wstring + slen;
|
| ︙ | ︙ | |||
696 697 698 699 700 701 702 |
*/
if (objv[1] == objv[0]) {
objPtr = Tcl_DuplicateObj(objv[1]);
} else {
objPtr = objv[1];
}
| | | | 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 |
*/
if (objv[1] == objv[0]) {
objPtr = Tcl_DuplicateObj(objv[1]);
} else {
objPtr = objv[1];
}
wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen);
if (objv[2] == objv[0]) {
subPtr = Tcl_DuplicateObj(objv[2]);
} else {
subPtr = objv[2];
}
if (!command) {
wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen);
}
result = TCL_OK;
/*
* The following loop is to handle multiple matches within the same source
* string; each iteration handles one match and its corresponding
|
| ︙ | ︙ | |||
741 742 743 744 745 746 747 |
}
if (match == 0) {
break;
}
if (numMatches == 0) {
resultPtr = Tcl_NewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
| | | 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 |
}
if (match == 0) {
break;
}
if (numMatches == 0) {
resultPtr = Tcl_NewUnicodeObj(wstring, 0);
Tcl_IncrRefCount(resultPtr);
if (offset > 0) {
/*
* Copy the initial portion of the string in if an offset was
* specified.
*/
Tcl_AppendUnicodeToObj(resultPtr, wstring, offset);
}
|
| ︙ | ︙ | |||
775 776 777 778 779 780 781 |
if (command) {
Tcl_Obj **args = NULL, **parts;
int numArgs;
Tcl_ListObjGetElements(interp, subPtr, &numParts, &parts);
numArgs = numParts + info.nsubs + 1;
| | | 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 |
if (command) {
Tcl_Obj **args = NULL, **parts;
int numArgs;
Tcl_ListObjGetElements(interp, subPtr, &numParts, &parts);
numArgs = numParts + info.nsubs + 1;
args = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * numArgs);
memcpy(args, parts, sizeof(Tcl_Obj*) * numParts);
for (idx = 0 ; idx <= info.nsubs ; idx++) {
subStart = info.matches[idx].start;
subEnd = info.matches[idx].end;
if ((subStart >= 0) && (subEnd >= 0)) {
args[idx + numParts] = Tcl_NewUnicodeObj(
|
| ︙ | ︙ | |||
805 806 807 808 809 810 811 |
* afterwards; subPtr is handled in the main exit stanza.
*/
result = Tcl_EvalObjv(interp, numArgs, args, 0);
for (idx = 0 ; idx <= info.nsubs ; idx++) {
TclDecrRefCount(args[idx + numParts]);
}
| | | | 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 |
* afterwards; subPtr is handled in the main exit stanza.
*/
result = Tcl_EvalObjv(interp, numArgs, args, 0);
for (idx = 0 ; idx <= info.nsubs ; idx++) {
TclDecrRefCount(args[idx + numParts]);
}
ckfree(args);
if (result != TCL_OK) {
if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (%s substitution computation script)",
options[REGSUB_COMMAND]));
}
goto done;
}
Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp));
Tcl_ResetResult(interp);
/*
* Refetch the unicode, in case the representation was smashed by
* the user code.
*/
wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen);
offset += end;
if (end == 0 || start == end) {
/*
* Always consume at least one character of the input string
* in order to prevent infinite loops, even when we
* technically matched the empty string; we must not match
|
| ︙ | ︙ | |||
999 1000 1001 1002 1003 1004 1005 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_RenameObjCmd( | | | 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_RenameObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *oldName, *newName;
if (objc != 3) {
|
| ︙ | ︙ | |||
1035 1036 1037 1038 1039 1040 1041 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_ReturnObjCmd( | | | 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ReturnObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int code, level;
Tcl_Obj *returnOpts;
|
| ︙ | ︙ | |||
1082 1083 1084 1085 1086 1087 1088 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_SourceObjCmd( | | | | | 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_SourceObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRSourceObjCmd, clientData, objc, objv);
}
int
TclNRSourceObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *encodingName = NULL;
Tcl_Obj *fileName;
int result;
|
| ︙ | ︙ | |||
1133 1134 1135 1136 1137 1138 1139 |
};
int index;
if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], nopkgoptions,
"option", TCL_EXACT, &index)) {
return TCL_ERROR;
}
| | | 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 |
};
int index;
if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], nopkgoptions,
"option", TCL_EXACT, &index)) {
return TCL_ERROR;
}
pkgFiles = (void **)Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
/* Make sure that during the following TclNREvalFile no filenames
* are recorded for inclusion in the "package files" command */
names = *pkgFiles;
*pkgFiles = NULL;
}
result = TclNREvalFile(interp, fileName, encodingName);
if (pkgFiles) {
|
| ︙ | ︙ | |||
1166 1167 1168 1169 1170 1171 1172 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_SplitObjCmd( | | | | | 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_SplitObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int ch = 0;
int len;
const char *splitChars;
const char *stringPtr;
const char *end;
int splitCharLen, stringLen;
Tcl_Obj *listPtr, *objPtr;
if (objc == 2) {
splitChars = " \n\t\r";
splitCharLen = 4;
} else if (objc == 3) {
splitChars = TclGetStringFromObj(objv[2], &splitCharLen);
|
| ︙ | ︙ | |||
1214 1215 1216 1217 1218 1219 1220 |
* is a *major* win when splitting on a long string (especially in the
* megabyte range!) - DKF
*/
Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
for ( ; stringPtr < end; stringPtr += len) {
| < | < < < < < < < < < < < < < | < | | | | | | | | 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 |
* is a *major* win when splitting on a long string (especially in the
* megabyte range!) - DKF
*/
Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS);
for ( ; stringPtr < end; stringPtr += len) {
len = TclUtfToUCS4(stringPtr, &ch);
hPtr = Tcl_CreateHashEntry(&charReuseTable, INT2PTR(ch), &isNew);
if (isNew) {
TclNewStringObj(objPtr, stringPtr, len);
/*
* Don't need to fiddle with refcount...
*/
Tcl_SetHashValue(hPtr, objPtr);
} else {
objPtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
}
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
}
Tcl_DeleteHashTable(&charReuseTable);
} else if (splitCharLen == 1) {
const char *p;
/*
* Handle the special case of splitting on a single character. This is
* only true for the one-char ASCII case, as one unicode char is > 1
* byte in length.
*/
while (*stringPtr && (p=strchr(stringPtr,(int)*splitChars)) != NULL) {
objPtr = Tcl_NewStringObj(stringPtr, p - stringPtr);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
stringPtr = p + 1;
}
TclNewStringObj(objPtr, stringPtr, end - stringPtr);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
} else {
const char *element, *p, *splitEnd;
int splitLen;
int splitChar;
/*
* Normal case: split on any of a given set of characters. Discard
* instances of the split characters.
*/
splitEnd = splitChars + splitCharLen;
for (element = stringPtr; stringPtr < end; stringPtr += len) {
len = TclUtfToUCS4(stringPtr, &ch);
for (p = splitChars; p < splitEnd; p += splitLen) {
splitLen = TclUtfToUCS4(p, &splitChar);
if (ch == splitChar) {
TclNewStringObj(objPtr, element, stringPtr - element);
Tcl_ListObjAppendElement(NULL, listPtr, objPtr);
element = stringPtr + len;
break;
}
}
|
| ︙ | ︙ | |||
1314 1315 1316 1317 1318 1319 1320 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringFirstCmd( | | | | | | < | 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringFirstCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int start = 0;
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"needleString haystackString ?startIndex?");
return TCL_ERROR;
}
if (objc == 4) {
int size = Tcl_GetCharLength(objv[2]);
if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &start)) {
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, TclStringFirst(objv[1], objv[2], start));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringLastCmd --
|
| ︙ | ︙ | |||
1359 1360 1361 1362 1363 1364 1365 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringLastCmd( | | | | | | < | 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringLastCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int last = INT_MAX - 1;
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"needleString haystackString ?lastIndex?");
return TCL_ERROR;
}
if (objc == 4) {
int size = Tcl_GetCharLength(objv[2]);
if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &last)) {
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, TclStringLast(objv[1], objv[2], last));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringIndexCmd --
|
| ︙ | ︙ | |||
1404 1405 1406 1407 1408 1409 1410 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringIndexCmd( | | | | | | | | | | | | 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringIndexCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length, index;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string charIndex");
return TCL_ERROR;
}
/*
* Get the char length to calculate what 'end' means.
*/
length = Tcl_GetCharLength(objv[1]);
if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) {
return TCL_ERROR;
}
if ((index >= 0) && (index < length)) {
int ch = Tcl_GetUniChar(objv[1], index);
if (ch == -1) {
return TCL_OK;
}
/*
* If we have a ByteArray object, we're careful to generate a new
* bytearray for a result.
*/
if (TclIsPureByteArray(objv[1])) {
unsigned char uch = UCHAR(ch);
Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1));
} else {
char buf[4] = "";
length = Tcl_UniCharToUtf(ch, buf);
if ((ch >= 0xD800) && (length < 3)) {
length += Tcl_UniCharToUtf(-1, buf + length);
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length));
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1474 1475 1476 1477 1478 1479 1480 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringInsertCmd( | | | | | | | 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringInsertCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument objects */
{
int length; /* String length */
int index; /* Insert index */
Tcl_Obj *outObj; /* Output object */
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string index insertString");
return TCL_ERROR;
}
length = Tcl_GetCharLength(objv[1]);
if (TclGetIntForIndexM(interp, objv[2], length, &index) != TCL_OK) {
return TCL_ERROR;
}
if (index < 0) {
index = 0;
}
if (index > length) {
index = length;
}
outObj = TclStringReplace(interp, objv[1], index, 0, objv[3],
TCL_STRING_IN_PLACE);
|
| ︙ | ︙ | |||
1531 1532 1533 1534 1535 1536 1537 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringIsCmd( | | < | < < | 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringIsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *end, *stop;
int (*chcomp)(int) = NULL; /* The UniChar comparison function. */
int i, failat = 0, result = 1, strict = 0, index, length1, length2;
Tcl_Obj *objPtr, *failVarObj = NULL;
Tcl_WideInt w;
static const char *const isClasses[] = {
"alnum", "alpha", "ascii", "control",
"boolean", "dict", "digit", "double",
"entier", "false", "graph", "integer",
|
| ︙ | ︙ | |||
1636 1637 1638 1639 1640 1641 1642 |
&& (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) {
if (strict) {
result = 0;
} else {
string1 = TclGetStringFromObj(objPtr, &length1);
result = length1 == 0;
}
| | > | | > | < | | 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 |
&& (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) {
if (strict) {
result = 0;
} else {
string1 = TclGetStringFromObj(objPtr, &length1);
result = length1 == 0;
}
} else if (index != STR_IS_BOOL) {
TclGetBooleanFromObj(NULL, objPtr, &i);
if ((index == STR_IS_TRUE) ^ i) {
result = 0;
}
}
break;
case STR_IS_CONTROL:
chcomp = Tcl_UniCharIsControl;
break;
case STR_IS_DICT: {
int dresult, dsize;
dresult = Tcl_DictObjSize(interp, objPtr, &dsize);
Tcl_ResetResult(interp);
result = (dresult == TCL_OK) ? 1 : 0;
if (dresult != TCL_OK && failVarObj != NULL) {
/*
* Need to figure out where the list parsing failed, which is
* fairly expensive. This is adapted from the core of
* SetDictFromAny().
*/
const char *elemStart, *nextElem;
int lenRemain, elemSize;
const char *p;
string1 = TclGetStringFromObj(objPtr, &length1);
end = string1 + length1;
failat = -1;
for (p=string1, lenRemain=length1; lenRemain > 0;
p=nextElem, lenRemain=end-nextElem) {
if (TCL_ERROR == TclFindElement(NULL, p, lenRemain,
|
| ︙ | ︙ | |||
1827 1828 1829 1830 1831 1832 1833 |
break;
case STR_IS_LIST:
/*
* We ignore the strictness here, since empty strings are always
* well-formed lists.
*/
| | | < | | | 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 |
break;
case STR_IS_LIST:
/*
* We ignore the strictness here, since empty strings are always
* well-formed lists.
*/
if (TCL_OK == TclListObjLength(NULL, objPtr, &length2)) {
break;
}
if (failVarObj != NULL) {
/*
* Need to figure out where the list parsing failed, which is
* fairly expensive. This is adapted from the core of
* SetListFromAny().
*/
const char *elemStart, *nextElem;
int lenRemain, elemSize;
const char *p;
string1 = TclGetStringFromObj(objPtr, &length1);
end = string1 + length1;
failat = -1;
for (p=string1, lenRemain=length1; lenRemain > 0;
p=nextElem, lenRemain=end-nextElem) {
if (TCL_ERROR == TclFindElement(NULL, p, lenRemain,
&elemStart, &nextElem, &elemSize, NULL)) {
Tcl_Obj *tmpStr;
/*
* This is the simplest way of getting the number of
* characters parsed. Note that this is not the same as
* the number of bytes when parsing strings with non-ASCII
* characters in them.
*
* Skip leading spaces first. This is only really an issue
* if it is the first "element" that has the failure.
*/
while (TclIsSpaceProcM(*p)) {
p++;
}
TclNewStringObj(tmpStr, string1, p-string1);
failat = Tcl_GetCharLength(tmpStr);
TclDecrRefCount(tmpStr);
break;
}
|
| ︙ | ︙ | |||
1907 1908 1909 1910 1911 1912 1913 |
if (strict) {
result = 0;
}
goto str_is_done;
}
end = string1 + length1;
for (; string1 < end; string1 += length2, failat++) {
| | < < < < < < | < > | | | 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 |
if (strict) {
result = 0;
}
goto str_is_done;
}
end = string1 + length1;
for (; string1 < end; string1 += length2, failat++) {
int ucs4;
length2 = TclUtfToUCS4(string1, &ucs4);
if (!chcomp(ucs4)) {
result = 0;
break;
}
}
}
/*
* Only set the failVarObj when we will return 0 and we have indicated a
* valid fail index (>= 0).
*/
str_is_done:
if ((result == 0) && (failVarObj != NULL) &&
Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(failat),
TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result));
return TCL_OK;
}
|
| ︙ | ︙ | |||
1972 1973 1974 1975 1976 1977 1978 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringMapCmd( | | | | | 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringMapCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length1, length2, mapElemc, index;
int nocase = 0, mapWithDict = 0, copySource = 0;
Tcl_Obj **mapElemv, *sourceObj, *resultPtr;
Tcl_UniChar *ustring1, *ustring2, *p, *end;
int (*strCmpFn)(const Tcl_UniChar*, const Tcl_UniChar*, unsigned long);
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? charMap string");
return TCL_ERROR;
}
if (objc == 4) {
|
| ︙ | ︙ | |||
2018 2019 2020 2021 2022 2023 2024 | Tcl_DictSearch search; /* * We know the type exactly, so all dict operations will succeed for * sure. This shortens this code quite a bit. */ | | | | | | | < | < | 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 |
Tcl_DictSearch search;
/*
* We know the type exactly, so all dict operations will succeed for
* sure. This shortens this code quite a bit.
*/
Tcl_DictObjSize(interp, objv[objc-2], &mapElemc);
if (mapElemc == 0) {
/*
* Empty charMap, just return whatever string was given.
*/
Tcl_SetObjResult(interp, objv[objc-1]);
return TCL_OK;
}
mapElemc *= 2;
mapWithDict = 1;
/*
* Copy the dictionary out into an array; that's the easiest way to
* adapt this code...
*/
mapElemv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc);
Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0,
mapElemv+1, &done);
for (i=2 ; i<mapElemc ; i+=2) {
Tcl_DictObjNext(&search, mapElemv+i, mapElemv+i+1, &done);
}
Tcl_DictObjDone(&search);
} else {
if (TclListObjGetElements(interp, objv[objc-2], &mapElemc,
&mapElemv) != TCL_OK) {
return TCL_ERROR;
}
if (mapElemc == 0) {
/*
* empty charMap, just return whatever string was given.
*/
Tcl_SetObjResult(interp, objv[objc-1]);
return TCL_OK;
|
| ︙ | ︙ | |||
2081 2082 2083 2084 2085 2086 2087 |
if (objv[objc-2] == objv[objc-1]) {
sourceObj = Tcl_DuplicateObj(objv[objc-1]);
copySource = 1;
} else {
sourceObj = objv[objc-1];
}
| | | 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 |
if (objv[objc-2] == objv[objc-1]) {
sourceObj = Tcl_DuplicateObj(objv[objc-1]);
copySource = 1;
} else {
sourceObj = objv[objc-1];
}
ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1);
if (length1 == 0) {
/*
* Empty input string, just stop now.
*/
goto done;
}
|
| ︙ | ︙ | |||
2107 2108 2109 2110 2111 2112 2113 | /* * Special case for one map pair which avoids the extra for loop and * extra calls to get Unicode data. The algorithm is otherwise * identical to the multi-pair case. This will be >30% faster on * larger strings. */ | | < | | | | < | | | | | | 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 |
/*
* Special case for one map pair which avoids the extra for loop and
* extra calls to get Unicode data. The algorithm is otherwise
* identical to the multi-pair case. This will be >30% faster on
* larger strings.
*/
int mapLen, u2lc;
Tcl_UniChar *mapString;
ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2);
p = ustring1;
if ((length2 > length1) || (length2 == 0)) {
/*
* Match string is either longer than input or empty.
*/
ustring1 = end;
} else {
mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen);
u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0);
for (; ustring1 < end; ustring1++) {
if (((*ustring1 == *ustring2) ||
(nocase&&Tcl_UniCharToLower(*ustring1)==u2lc)) &&
(length2==1 || strCmpFn(ustring1, ustring2,
(unsigned long) length2) == 0)) {
if (p != ustring1) {
Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p);
p = ustring1 + length2;
} else {
p += length2;
}
ustring1 = p - 1;
Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen);
}
}
}
} else {
Tcl_UniChar **mapStrings;
int *mapLens, *u2lc = NULL;
/*
* Precompute pointers to the unicode string and length. This saves us
* repeated function calls later, significantly speeding up the
* algorithm. We only need the lowercase first char in the nocase
* case.
*/
mapStrings = (Tcl_UniChar **)TclStackAlloc(interp, mapElemc*2*sizeof(Tcl_UniChar *));
mapLens = (int *)TclStackAlloc(interp, mapElemc * 2 * sizeof(int));
if (nocase) {
u2lc = (int *)TclStackAlloc(interp, mapElemc * sizeof(int));
}
for (index = 0; index < mapElemc; index++) {
mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index],
mapLens+index);
if (nocase && ((index % 2) == 0)) {
u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]);
}
}
for (p = ustring1; ustring1 < end; ustring1++) {
for (index = 0; index < mapElemc; index += 2) {
/*
* Get the key string to match on.
*/
ustring2 = mapStrings[index];
length2 = mapLens[index];
if ((length2 > 0) && ((*ustring1 == *ustring2) || (nocase &&
(Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) &&
/* Restrict max compare length. */
(end-ustring1 >= length2) && ((length2 == 1) ||
!strCmpFn(ustring2, ustring1, length2))) {
if (p != ustring1) {
/*
* Put the skipped chars onto the result first.
*/
Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p);
|
| ︙ | ︙ | |||
2247 2248 2249 2250 2251 2252 2253 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringMatchCmd( | | | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringMatchCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int nocase = 0;
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? pattern string");
return TCL_ERROR;
}
if (objc == 4) {
int length;
const char *string = TclGetStringFromObj(objv[1], &length);
if ((length > 1) &&
strncmp(string, "-nocase", length) == 0) {
nocase = TCL_MATCH_NOCASE;
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
| ︙ | ︙ | |||
2299 2300 2301 2302 2303 2304 2305 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringRangeCmd( | | | | | | | | | | | | 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringRangeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length, first, last;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string first last");
return TCL_ERROR;
}
/*
* Get the length in actual characters; Then reduce it by one because
* 'end' refers to the last character, not one past it.
*/
length = Tcl_GetCharLength(objv[1]) - 1;
if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK ||
TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK) {
return TCL_ERROR;
}
if (first < 0) {
first = 0;
}
if (last >= length) {
last = length;
}
if (last >= first) {
Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last));
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2355 2356 2357 2358 2359 2360 2361 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringReptCmd( | | | 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringReptCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int count;
Tcl_Obj *resultPtr;
|
| ︙ | ︙ | |||
2411 2412 2413 2414 2415 2416 2417 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringRplcCmd( | | | | > | | | > | | | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringRplcCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int first, last, length, end;
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?");
return TCL_ERROR;
}
length = Tcl_GetCharLength(objv[1]);
end = length - 1;
if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK ||
TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) {
return TCL_ERROR;
}
/*
* The following test screens out most empty substrings as candidates for
* replacement. When they are detected, no replacement is done, and the
* result is the original string.
*/
if ((last < 0) || /* Range ends before start of string */
(first > end) || /* Range begins after end of string */
(last < first)) { /* Range begins after it starts */
/*
* BUT!!! when (end < 0) -- an empty original string -- we can
* have (first <= end < 0 <= last) and an empty string is permitted
* to be replaced.
*/
Tcl_SetObjResult(interp, objv[1]);
} else {
Tcl_Obj *resultPtr;
if (first < 0) {
first = 0;
}
if (last > end) {
last = end;
}
resultPtr = TclStringReplace(interp, objv[1], first,
last + 1 - first, (objc == 5) ? objv[4] : NULL,
TCL_STRING_IN_PLACE);
|
| ︙ | ︙ | |||
2485 2486 2487 2488 2489 2490 2491 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringRevCmd( | | | < < | | | | | | | | | > > | > > | > | > > > > > | | < | | | | | | | | | | | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringRevCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "string");
return TCL_ERROR;
}
Tcl_SetObjResult(interp, TclStringReverse(objv[1], TCL_STRING_IN_PLACE));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringStartCmd --
*
* This procedure is invoked to process the "string wordstart" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringStartCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int ch;
const char *p, *string;
int cur, index, length, numChars;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string index");
return TCL_ERROR;
}
string = TclGetStringFromObj(objv[1], &length);
numChars = Tcl_NumUtfChars(string, length);
if (TclGetIntForIndexM(interp, objv[2], numChars-1, &index) != TCL_OK) {
return TCL_ERROR;
}
string = TclGetStringFromObj(objv[1], &length);
if (index >= numChars) {
index = numChars - 1;
}
cur = 0;
if (index > 0) {
p = Tcl_UtfAtIndex(string, index);
TclUtfToUCS4(p, &ch);
for (cur = index; cur >= 0; cur--) {
int delta = 0;
const char *next;
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
next = TclUtfPrev(p, string);
do {
next += delta;
delta = TclUtfToUCS4(next, &ch);
} while (next + delta < p);
p = next;
}
if (cur != index) {
cur += 1;
}
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(cur));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringEndCmd --
*
* This procedure is invoked to process the "string wordend" Tcl command.
* See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringEndCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int ch;
const char *p, *end, *string;
int cur, index, length, numChars;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "string index");
return TCL_ERROR;
}
string = TclGetStringFromObj(objv[1], &length);
numChars = Tcl_NumUtfChars(string, length);
if (TclGetIntForIndexM(interp, objv[2], numChars-1, &index) != TCL_OK) {
return TCL_ERROR;
}
string = TclGetStringFromObj(objv[1], &length);
if (index < 0) {
index = 0;
}
if (index < numChars) {
p = Tcl_UtfAtIndex(string, index);
end = string+length;
for (cur = index; p < end; cur++) {
p += TclUtfToUCS4(p, &ch);
if (!Tcl_UniCharIsWordChar(ch)) {
break;
}
}
if (cur == index) {
cur++;
}
} else {
cur = numChars;
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(cur));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* StringEqualCmd --
|
| ︙ | ︙ | |||
2643 2644 2645 2646 2647 2648 2649 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringEqualCmd( | | | < | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringEqualCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
/*
* Remember to keep code here in some sync with the byte-compiled versions
* in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as
* the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...).
*/
const char *string2;
int length, i, match, nocase = 0, reqlength = -1;
if (objc < 3 || objc > 6) {
str_cmp_args:
Tcl_WrongNumArgs(interp, 1, objv,
"?-nocase? ?-length int? string1 string2");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2719 2720 2721 2722 2723 2724 2725 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringCmpCmd( | | | 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringCmpCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
/*
* Remember to keep code here in some sync with the byte-compiled versions
* in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as
|
| ︙ | ︙ | |||
2751 2752 2753 2754 2755 2756 2757 |
TclStringCmpOpts(
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[], /* Argument objects. */
int *nocase,
int *reqlength)
{
| | < | 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 |
TclStringCmpOpts(
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[], /* Argument objects. */
int *nocase,
int *reqlength)
{
int i, length;
const char *string;
*reqlength = -1;
*nocase = 0;
if (objc < 3 || objc > 6) {
str_cmp_args:
Tcl_WrongNumArgs(interp, 1, objv,
|
| ︙ | ︙ | |||
2808 2809 2810 2811 2812 2813 2814 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringCatCmd( | | | 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringCatCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *objResultPtr;
if (objc < 2) {
|
| ︙ | ︙ | |||
2851 2852 2853 2854 2855 2856 2857 | * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | | 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 |
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringBytesCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "string");
return TCL_ERROR;
}
(void) TclGetStringFromObj(objv[1], &length);
|
| ︙ | ︙ | |||
2891 2892 2893 2894 2895 2896 2897 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringLenCmd( | | | 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringLenCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "string");
return TCL_ERROR;
|
| ︙ | ︙ | |||
2925 2926 2927 2928 2929 2930 2931 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringLowerCmd( | | | | | | | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringLowerCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length1, length2;
const char *string1;
char *string2;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
string1 = TclGetStringFromObj(objv[1], &length1);
if (objc == 2) {
Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);
length1 = Tcl_UtfToLower(TclGetString(resultPtr));
Tcl_SetObjLength(resultPtr, length1);
Tcl_SetObjResult(interp, resultPtr);
} else {
int first, last;
const char *start, *end;
Tcl_Obj *resultPtr;
length1 = Tcl_NumUtfChars(string1, length1) - 1;
if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) {
return TCL_ERROR;
}
if (first < 0) {
first = 0;
}
last = first;
if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1,
&last) != TCL_OK)) {
return TCL_ERROR;
}
if (last >= length1) {
last = length1;
}
if (last < first) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
string1 = TclGetStringFromObj(objv[1], &length1);
start = Tcl_UtfAtIndex(string1, first);
end = Tcl_UtfAtIndex(start, last - first + 1);
|
| ︙ | ︙ | |||
3010 3011 3012 3013 3014 3015 3016 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringUpperCmd( | | | | | | | | | 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringUpperCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length1, length2;
const char *string1;
char *string2;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
string1 = TclGetStringFromObj(objv[1], &length1);
if (objc == 2) {
Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);
length1 = Tcl_UtfToUpper(TclGetString(resultPtr));
Tcl_SetObjLength(resultPtr, length1);
Tcl_SetObjResult(interp, resultPtr);
} else {
int first, last;
const char *start, *end;
Tcl_Obj *resultPtr;
length1 = Tcl_NumUtfChars(string1, length1) - 1;
if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) {
return TCL_ERROR;
}
if (first < 0) {
first = 0;
}
last = first;
if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1,
&last) != TCL_OK)) {
return TCL_ERROR;
}
if (last >= length1) {
last = length1;
}
if (last < first) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
string1 = TclGetStringFromObj(objv[1], &length1);
start = Tcl_UtfAtIndex(string1, first);
end = Tcl_UtfAtIndex(start, last - first + 1);
|
| ︙ | ︙ | |||
3095 3096 3097 3098 3099 3100 3101 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringTitleCmd( | | | | | | | | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringTitleCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length1, length2;
const char *string1;
char *string2;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "string ?first? ?last?");
return TCL_ERROR;
}
string1 = TclGetStringFromObj(objv[1], &length1);
if (objc == 2) {
Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1);
length1 = Tcl_UtfToTitle(TclGetString(resultPtr));
Tcl_SetObjLength(resultPtr, length1);
Tcl_SetObjResult(interp, resultPtr);
} else {
int first, last;
const char *start, *end;
Tcl_Obj *resultPtr;
length1 = Tcl_NumUtfChars(string1, length1) - 1;
if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) {
return TCL_ERROR;
}
if (first < 0) {
first = 0;
}
last = first;
if ((objc == 4) && (TclGetIntForIndexM(interp, objv[3], length1,
&last) != TCL_OK)) {
return TCL_ERROR;
}
if (last >= length1) {
last = length1;
}
if (last < first) {
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
string1 = TclGetStringFromObj(objv[1], &length1);
start = Tcl_UtfAtIndex(string1, first);
end = Tcl_UtfAtIndex(start, last - first + 1);
|
| ︙ | ︙ | |||
3180 3181 3182 3183 3184 3185 3186 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringTrimCmd( | | | | 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringTrimCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
int triml, trimr, length1, length2;
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
string2 = tclDefaultTrimSet;
length2 = strlen(tclDefaultTrimSet);
} else {
|
| ︙ | ︙ | |||
3227 3228 3229 3230 3231 3232 3233 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringTrimLCmd( | | < | | 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringTrimLCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
int trim, length1, length2;
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
string2 = tclDefaultTrimSet;
length2 = strlen(tclDefaultTrimSet);
} else {
|
| ︙ | ︙ | |||
3274 3275 3276 3277 3278 3279 3280 | * See the user documentation. * *---------------------------------------------------------------------- */ static int StringTrimRCmd( | | < | | 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
StringTrimRCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *string1, *string2;
int trim, length1, length2;
if (objc == 3) {
string2 = TclGetStringFromObj(objv[2], &length2);
} else if (objc == 2) {
string2 = tclDefaultTrimSet;
length2 = strlen(tclDefaultTrimSet);
} else {
|
| ︙ | ︙ | |||
3418 3419 3420 3421 3422 3423 3424 |
}
*flagPtr = flags;
return TCL_OK;
}
int
Tcl_SubstObjCmd(
| | | | | 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 |
}
*flagPtr = flags;
return TCL_OK;
}
int
Tcl_SubstObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRSubstObjCmd, clientData, objc, objv);
}
int
TclNRSubstObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int flags;
if (objc < 2) {
|
| ︙ | ︙ | |||
3466 3467 3468 3469 3470 3471 3472 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_SwitchObjCmd( | | | | | | < | 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_SwitchObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRSwitchObjCmd, clientData, objc, objv);
}
int
TclNRSwitchObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i,j, index, mode, foundmode, splitObjs, numMatchesSaved;
int noCase, patternLength;
const char *pattern;
Tcl_Obj *stringObj, *indexVarObj, *matchVarObj;
Tcl_Obj *const *savedObjv = objv;
Tcl_RegExp regExpr = NULL;
Interp *iPtr = (Interp *) interp;
int pc = 0;
int bidx = 0; /* Index of body argument. */
|
| ︙ | ︙ | |||
3793 3794 3795 3796 3797 3798 3799 |
TclNewObj(indicesObj);
}
for (j=0 ; j<=info.nsubs ; j++) {
if (indexVarObj != NULL) {
Tcl_Obj *rangeObjAry[2];
| | | | | 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 |
TclNewObj(indicesObj);
}
for (j=0 ; j<=info.nsubs ; j++) {
if (indexVarObj != NULL) {
Tcl_Obj *rangeObjAry[2];
if (info.matches[j].end > 0) {
rangeObjAry[0] = Tcl_NewWideIntObj(info.matches[j].start);
rangeObjAry[1] = Tcl_NewWideIntObj(info.matches[j].end-1);
} else {
rangeObjAry[0] = rangeObjAry[1] = Tcl_NewWideIntObj(-1);
}
/*
* Never fails; the object is always clean at this point.
*/
|
| ︙ | ︙ | |||
3859 3860 3861 3862 3863 3864 3865 |
/*
* We've got a match. Find a body to execute, skipping bodies that are
* "-".
*/
matchFound:
| | | 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 |
/*
* We've got a match. Find a body to execute, skipping bodies that are
* "-".
*/
matchFound:
ctxPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
*ctxPtr = *iPtr->cmdFramePtr;
if (splitObjs) {
/*
* We have to perform the GetSrc and other type dependent handling of
* the frame here because we are munging with the line numbers,
* something the other commands like if, etc. are not doing. Them are
|
| ︙ | ︙ | |||
3889 3890 3891 3892 3893 3894 3895 |
* own.
*/
}
if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) {
int bline = ctxPtr->line[bidx];
| | | | | 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 |
* own.
*/
}
if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) {
int bline = ctxPtr->line[bidx];
ctxPtr->line = (int *)ckalloc(objc * sizeof(int));
ctxPtr->nline = objc;
TclListLines(blist, bline, objc, ctxPtr->line, objv);
} else {
/*
* This is either a dynamic code word, when all elements are
* relative to themselves, or something else less expected and
* where we have no information. The result is the same in both
* cases; tell the code to come that it doesn't know where it is,
* which triggers reversion to the old behavior.
*/
int k;
ctxPtr->line = (int *)ckalloc(objc * sizeof(int));
ctxPtr->nline = objc;
for (k=0; k < objc; k++) {
ctxPtr->line[k] = -1;
}
}
}
for (j = i + 1; ; j += 2) {
if (j >= objc) {
/*
* This shouldn't happen since we've checked that the last body is
* not a continuation...
*/
Tcl_Panic("fall-out when searching for body to match pattern");
}
|
| ︙ | ︙ | |||
3943 3944 3945 3946 3947 3948 3949 |
ClientData data[], /* Data passed from Tcl_NRAddCallback above */
Tcl_Interp *interp, /* Tcl interpreter */
int result) /* Result to return*/
{
/* Unpack the preserved data */
int splitObjs = PTR2INT(data[0]);
| | | | | | | | 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 |
ClientData data[], /* Data passed from Tcl_NRAddCallback above */
Tcl_Interp *interp, /* Tcl interpreter */
int result) /* Result to return*/
{
/* Unpack the preserved data */
int splitObjs = PTR2INT(data[0]);
CmdFrame *ctxPtr = (CmdFrame *)data[1];
int pc = PTR2INT(data[2]);
const char *pattern = (const char *)data[3];
int patternLength = strlen(pattern);
/*
* Clean up TIP 280 context information
*/
if (splitObjs) {
ckfree(ctxPtr->line);
if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) {
/*
* Death of SrcInfo reference.
*/
Tcl_DecrRefCount(ctxPtr->data.eval.path);
}
}
/*
* Generate an error message if necessary.
*/
if (result == TCL_ERROR) {
int limit = 50;
int overflow = (patternLength > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (\"%.*s%s\" arm line %d)",
(overflow ? limit : patternLength), pattern,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
TclStackFree(interp, ctxPtr);
return result;
}
/*
|
| ︙ | ︙ | |||
3997 3998 3999 4000 4001 4002 4003 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ThrowObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *options;
int len;
|
| ︙ | ︙ | |||
4062 4063 4064 4065 4066 4067 4068 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_TimeObjCmd( | | | | | 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_TimeObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *objPtr;
Tcl_Obj *objs[4];
int i, result;
int count;
double totalMicroSec;
#ifndef TCL_WIDE_CLICKS
Tcl_Time start, stop;
#else
Tcl_WideInt start, stop;
#endif
|
| ︙ | ︙ | |||
4160 4161 4162 4163 4164 4165 4166 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_TimeRateObjCmd( | | | | | | | | | < | 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_TimeRateObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static double measureOverhead = 0;
/* global measure-overhead */
double overhead = -1; /* given measure-overhead */
Tcl_Obj *objPtr;
int result, i;
Tcl_Obj *calibrate = NULL, *direct = NULL;
TclWideMUInt count = 0; /* Holds repetition count */
Tcl_WideInt maxms = WIDE_MIN;
/* Maximal running time (in milliseconds) */
TclWideMUInt maxcnt = WIDE_MAX;
/* Maximal count of iterations. */
TclWideMUInt threshold = 1; /* Current threshold for check time (faster
* repeat count without time check) */
TclWideMUInt maxIterTm = 1; /* Max time of some iteration as max
* threshold, additionally avoiding divide to
* zero (i.e., never < 1) */
unsigned short factor = 50; /* Factor (4..50) limiting threshold to avoid
* growth of execution time. */
Tcl_WideInt start, middle, stop;
#ifndef TCL_WIDE_CLICKS
Tcl_Time now;
#endif /* !TCL_WIDE_CLICKS */
static const char *const options[] = {
"-direct", "-overhead", "-calibrate", "--", NULL
};
enum options {
TMRT_EV_DIRECT, TMRT_OVERHEAD, TMRT_CALIBRATE, TMRT_LAST
};
NRE_callback *rootPtr;
ByteCode *codePtr = NULL;
for (i = 1; i < objc - 1; i++) {
int index;
if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", TCL_EXACT,
&index) != TCL_OK) {
break;
|
| ︙ | ︙ | |||
4380 4381 4382 4383 4384 4385 4386 |
if (!direct) {
if (TclInterpReady(interp) != TCL_OK) {
return TCL_ERROR;
}
codePtr = TclCompileObj(interp, objPtr, NULL, 0);
TclPreserveByteCode(codePtr);
| < < < < < < < < < | 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 |
if (!direct) {
if (TclInterpReady(interp) != TCL_OK) {
return TCL_ERROR;
}
codePtr = TclCompileObj(interp, objPtr, NULL, 0);
TclPreserveByteCode(codePtr);
}
/*
* Get start and stop time.
*/
#ifdef TCL_WIDE_CLICKS
|
| ︙ | ︙ | |||
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 |
/*
* Evaluate a single iteration.
*/
count++;
if (!direct) { /* precompiled */
rootPtr = TOP_CB(interp);
result = TclNRExecuteByteCode(interp, codePtr);
result = TclNRRunCallbacks(interp, result, rootPtr);
} else { /* eval */
result = TclEvalObjEx(interp, objPtr, 0, NULL, 0);
}
/*
* Allow break and continue from measurement cycle (used for
* conditional stop and flow control of iterations).
*/
switch (result) {
case TCL_OK:
break;
case TCL_BREAK:
/*
* Force stop immediately.
*/
threshold = 1;
maxcnt = 0;
case TCL_CONTINUE:
result = TCL_OK;
break;
default:
goto done;
}
| > > > > > > > | 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 |
/*
* Evaluate a single iteration.
*/
count++;
if (!direct) { /* precompiled */
rootPtr = TOP_CB(interp);
/*
* Use loop optimized TEBC call (TCL_EVAL_DISCARD_RESULT): it's a part of
* iteration, this way evaluation will be more similar to a cycle (also
* avoids extra overhead to set result to interp, etc.)
*/
((Interp *)interp)->evalFlags |= TCL_EVAL_DISCARD_RESULT;
result = TclNRExecuteByteCode(interp, codePtr);
result = TclNRRunCallbacks(interp, result, rootPtr);
} else { /* eval */
result = TclEvalObjEx(interp, objPtr, 0, NULL, 0);
}
/*
* Allow break and continue from measurement cycle (used for
* conditional stop and flow control of iterations).
*/
switch (result) {
case TCL_OK:
break;
case TCL_BREAK:
/*
* Force stop immediately.
*/
threshold = 1;
maxcnt = 0;
/* FALLTHRU */
case TCL_CONTINUE:
result = TCL_OK;
break;
default:
goto done;
}
|
| ︙ | ︙ | |||
4553 4554 4555 4556 4557 4558 4559 |
threshold = maxcnt - count;
}
}
}
{
Tcl_Obj *objarr[8], **objs = objarr;
| | | | 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 |
threshold = maxcnt - count;
}
}
}
{
Tcl_Obj *objarr[8], **objs = objarr;
TclWideMUInt usec, val;
int digits;
/*
* Absolute execution time in microseconds or in wide clicks.
*/
usec = (TclWideMUInt)(middle - start);
#ifdef TCL_WIDE_CLICKS
/*
* convert execution time (in wide clicks) to microsecs.
*/
usec *= TclpWideClickInMicrosec();
|
| ︙ | ︙ | |||
4588 4589 4590 4591 4592 4593 4594 |
*/
if (overhead > 0) {
/*
* Estimate the time of overhead (microsecs).
*/
| | | 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 |
*/
if (overhead > 0) {
/*
* Estimate the time of overhead (microsecs).
*/
TclWideMUInt curOverhead = overhead * count;
if (usec > curOverhead) {
usec -= curOverhead;
} else {
usec = 0;
}
}
|
| ︙ | ︙ | |||
4682 4683 4684 4685 4686 4687 4688 |
TclNewLiteralStringObj(objs[3], "#");
TclNewLiteralStringObj(objs[5], "#/sec");
Tcl_SetObjResult(interp, Tcl_NewListObj(8, objarr));
}
done:
if (codePtr != NULL) {
| < < < < < | 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 |
TclNewLiteralStringObj(objs[3], "#");
TclNewLiteralStringObj(objs[5], "#/sec");
Tcl_SetObjResult(interp, Tcl_NewListObj(8, objarr));
}
done:
if (codePtr != NULL) {
TclReleaseByteCode(codePtr);
}
return result;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
4711 4712 4713 4714 4715 4716 4717 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_TryObjCmd( | | | | | 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_TryObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRTryObjCmd, clientData, objc, objv);
}
int
TclNRTryObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *bodyObj, *handlersObj, *finallyObj = NULL;
int i, bodyShared, haveHandlers, dummy, code;
static const char *const handlerNames[] = {
|
| ︙ | ︙ | |||
4813 4814 4815 4816 4817 4818 4819 |
"ARGUMENT", NULL);
return TCL_ERROR;
}
code = 1;
if (Tcl_ListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad prefix '%s': must be a list",
| | | 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 |
"ARGUMENT", NULL);
return TCL_ERROR;
}
code = 1;
if (Tcl_ListObjLength(NULL, objv[i+1], &dummy) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad prefix '%s': must be a list",
Tcl_GetString(objv[i+1])));
Tcl_DecrRefCount(handlersObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP",
"EXNFORMAT", NULL);
return TCL_ERROR;
}
info[2] = objv[i+1];
|
| ︙ | ︙ | |||
4924 4925 4926 4927 4928 4929 4930 |
static int
TryPostBody(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj *resultObj, *options, *handlersObj, *finallyObj, *cmdObj, **objv;
| | | | | | 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 |
static int
TryPostBody(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj *resultObj, *options, *handlersObj, *finallyObj, *cmdObj, **objv;
int i, code, objc;
int numHandlers = 0;
handlersObj = (Tcl_Obj *)data[0];
finallyObj = (Tcl_Obj *)data[1];
objv = (Tcl_Obj **)data[2];
objc = PTR2INT(data[3]);
cmdObj = objv[0];
/*
* Check for limits/rewinding, which override normal trapping behaviour.
*/
|
| ︙ | ︙ | |||
4975 4976 4977 4978 4979 4980 4981 4982 |
if (handlersObj != NULL) {
int found = 0;
Tcl_Obj **handlers, **info;
Tcl_ListObjGetElements(NULL, handlersObj, &numHandlers, &handlers);
for (i=0 ; i<numHandlers ; i++) {
Tcl_Obj *handlerBodyObj;
| > | | 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 |
if (handlersObj != NULL) {
int found = 0;
Tcl_Obj **handlers, **info;
Tcl_ListObjGetElements(NULL, handlersObj, &numHandlers, &handlers);
for (i=0 ; i<numHandlers ; i++) {
Tcl_Obj *handlerBodyObj;
int numElems = 0;
Tcl_ListObjGetElements(NULL, handlers[i], &numElems, &info);
if (!found) {
Tcl_GetIntFromObj(NULL, info[1], &code);
if (code != result) {
continue;
}
/*
|
| ︙ | ︙ | |||
5038 5039 5040 5041 5042 5043 5044 | /* * Bind the variables. We already know this is a list of variable * names, but it might be empty. */ Tcl_ResetResult(interp); result = TCL_ERROR; | | | | | 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 |
/*
* Bind the variables. We already know this is a list of variable
* names, but it might be empty.
*/
Tcl_ResetResult(interp);
result = TCL_ERROR;
Tcl_ListObjLength(NULL, info[3], &numElems);
if (numElems> 0) {
Tcl_Obj *varName;
Tcl_ListObjIndex(NULL, info[3], 0, &varName);
if (Tcl_ObjSetVar2(interp, varName, NULL, resultObj,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_DecrRefCount(resultObj);
goto handlerFailed;
}
Tcl_DecrRefCount(resultObj);
if (numElems> 1) {
Tcl_ListObjIndex(NULL, info[3], 1, &varName);
if (Tcl_ObjSetVar2(interp, varName, NULL, options,
TCL_LEAVE_ERR_MSG) == NULL) {
goto handlerFailed;
}
}
} else {
|
| ︙ | ︙ | |||
5142 5143 5144 5145 5146 5147 5148 |
Tcl_Interp *interp,
int result)
{
Tcl_Obj *resultObj, *cmdObj, *options, *handlerKindObj, **objv;
Tcl_Obj *finallyObj;
int finally;
| | | | | 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 |
Tcl_Interp *interp,
int result)
{
Tcl_Obj *resultObj, *cmdObj, *options, *handlerKindObj, **objv;
Tcl_Obj *finallyObj;
int finally;
objv = (Tcl_Obj **)data[0];
options = (Tcl_Obj *)data[1];
handlerKindObj = (Tcl_Obj *)data[2];
finally = PTR2INT(data[3]);
cmdObj = objv[0];
finallyObj = finally ? objv[finally] : 0;
/*
* Check for limits/rewinding, which override normal trapping behaviour.
|
| ︙ | ︙ | |||
5226 5227 5228 5229 5230 5231 5232 |
TryPostFinal(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj *resultObj, *options, *cmdObj;
| | | | | 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 |
TryPostFinal(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj *resultObj, *options, *cmdObj;
resultObj = (Tcl_Obj *)data[0];
options = (Tcl_Obj *)data[1];
cmdObj = (Tcl_Obj *)data[2];
/*
* If the result wasn't OK, we need to adjust the result options.
*/
if (result != TCL_OK) {
Tcl_DecrRefCount(resultObj);
|
| ︙ | ︙ | |||
5287 5288 5289 5290 5291 5292 5293 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_WhileObjCmd( | | | | | 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_WhileObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRWhileObjCmd, clientData, objc, objv);
}
int
TclNRWhileObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
ForIterData *iterPtr;
if (objc != 3) {
|
| ︙ | ︙ | |||
5352 5353 5354 5355 5356 5357 5358 |
* contain n elements. */
int line, /* Line the list as a whole starts on. */
int n, /* #elements in lines */
int *lines, /* Array of line numbers, to fill. */
Tcl_Obj *const *elems) /* The list elems as Tcl_Obj*, in need of
* derived continuation data */
{
| | | 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 |
* contain n elements. */
int line, /* Line the list as a whole starts on. */
int n, /* #elements in lines */
int *lines, /* Array of line numbers, to fill. */
Tcl_Obj *const *elems) /* The list elems as Tcl_Obj*, in need of
* derived continuation data */
{
const char *listStr = Tcl_GetString(listObj);
const char *listHead = listStr;
int i, length = strlen(listStr);
const char *element = NULL, *next = NULL;
ContLineLoc *clLocPtr = TclContinuationsGet(listObj);
int *clNext = (clLocPtr ? &clLocPtr->loc[0] : NULL);
for (i = 0; i < n; i++) {
|
| ︙ | ︙ |
Changes to generic/tclCompCmds.c.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 | #include "tclCompile.h" #include <assert.h> /* * Prototypes for procedures defined later in this file: */ | | | | < < | < < | | | < < | < < | < < | < < | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | #include "tclCompile.h" #include <assert.h> /* * Prototypes for procedures defined later in this file: */ static AuxDataDupProc DupDictUpdateInfo; static AuxDataFreeProc FreeDictUpdateInfo; static AuxDataPrintProc PrintDictUpdateInfo; static AuxDataPrintProc DisassembleDictUpdateInfo; static AuxDataDupProc DupForeachInfo; static AuxDataFreeProc FreeForeachInfo; static AuxDataPrintProc PrintForeachInfo; static AuxDataPrintProc DisassembleForeachInfo; static AuxDataPrintProc PrintNewForeachInfo; static AuxDataPrintProc DisassembleNewForeachInfo; static int CompileEachloopCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, CompileEnv *envPtr, int collect); static int CompileDictEachCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr, int collect); |
| ︙ | ︙ | |||
134 135 136 137 138 139 140 141 142 |
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *varTokenPtr, *valueTokenPtr;
int isScalar, localIndex, numWords, i;
| > < | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 |
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *valueTokenPtr;
int isScalar, localIndex, numWords, i;
/* TODO: Consider support for compiling expanded args. */
numWords = parsePtr->numWords;
if (numWords == 1) {
return TCL_ERROR;
} else if (numWords == 2) {
/*
|
| ︙ | ︙ | |||
256 257 258 259 260 261 262 |
*/
int
TclCompileArrayExistsCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 |
*/
int
TclCompileArrayExistsCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int isScalar, localIndex;
if (parsePtr->numWords != 2) {
|
| ︙ | ︙ | |||
399 400 401 402 403 404 405 |
/*
* Prepare for the internal foreach.
*/
keyVar = AnonymousLocal(envPtr);
valVar = AnonymousLocal(envPtr);
| | | | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 |
/*
* Prepare for the internal foreach.
*/
keyVar = AnonymousLocal(envPtr);
valVar = AnonymousLocal(envPtr);
infoPtr = (ForeachInfo *)ckalloc(sizeof(ForeachInfo));
infoPtr->numLists = 1;
infoPtr->varLists[0] = (ForeachVarList *)ckalloc(sizeof(ForeachVarList) + sizeof(int));
infoPtr->varLists[0]->numVars = 2;
infoPtr->varLists[0]->varIndexes[0] = keyVar;
infoPtr->varLists[0]->varIndexes[1] = valVar;
infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr);
/*
* Start issuing instructions to write to the array.
|
| ︙ | ︙ | |||
518 519 520 521 522 523 524 | * runtime. * *---------------------------------------------------------------------- */ int TclCompileBreakCmd( | | | < | 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 |
* runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileBreakCmd(
TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
ExceptionRange *rangePtr;
ExceptionAux *auxPtr;
if (parsePtr->numWords != 1) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
579 580 581 582 583 584 585 |
*/
int
TclCompileCatchCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 |
*/
int
TclCompileCatchCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
JumpFixup jumpFixup;
Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr;
int resultIndex, optsIndex, range, dropScript = 0;
int depth = TclGetStackDepth(envPtr);
/*
* If syntax does not match what we expect for [catch], do not compile.
* Let runtime checks determine if syntax has changed.
*/
|
| ︙ | ︙ | |||
697 698 699 700 701 702 703 |
/* Stack at this point is empty */
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr);
/* Stack at this point on both branches: result returnCode */
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
| | | | 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 |
/* Stack at this point is empty */
TclEmitOpcode( INST_PUSH_RESULT, envPtr);
TclEmitOpcode( INST_PUSH_RETURN_CODE, envPtr);
/* Stack at this point on both branches: result returnCode */
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
Tcl_Panic("TclCompileCatchCmd: bad jump distance %d",
(int)(CurrentOffset(envPtr) - jumpFixup.codeOffset));
}
/*
* Push the return options if the caller wants them. This needs to happen
* before INST_END_CATCH
*/
|
| ︙ | ︙ | |||
761 762 763 764 765 766 767 | * command at runtime. * *---------------------------------------------------------------------- */ int TclCompileClockClicksCmd( | | | < | 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 |
* command at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileClockClicksCmd(
TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token* tokenPtr;
switch (parsePtr->numWords) {
case 1:
/*
|
| ︙ | ︙ | |||
825 826 827 828 829 830 831 | * * Client data is 1 for microseconds, 2 for milliseconds, 3 for seconds. *---------------------------------------------------------------------- */ int TclCompileClockReadingCmd( | | | 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 |
*
* Client data is 1 for microseconds, 2 for milliseconds, 3 for seconds.
*----------------------------------------------------------------------
*/
int
TclCompileClockReadingCmd(
TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
if (parsePtr->numWords != 1) {
|
| ︙ | ︙ | |||
864 865 866 867 868 869 870 |
*/
int
TclCompileConcatCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 |
*/
int
TclCompileConcatCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Obj *objPtr, *listObj;
Tcl_Token *tokenPtr;
int i;
|
| ︙ | ︙ | |||
904 905 906 907 908 909 910 |
}
(void) Tcl_ListObjAppendElement(NULL, listObj, objPtr);
}
if (listObj != NULL) {
Tcl_Obj **objs;
const char *bytes;
int len;
| < | | | 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 |
}
(void) Tcl_ListObjAppendElement(NULL, listObj, objPtr);
}
if (listObj != NULL) {
Tcl_Obj **objs;
const char *bytes;
int len;
Tcl_ListObjGetElements(NULL, listObj, &len, &objs);
objPtr = Tcl_ConcatObj(len, objs);
Tcl_DecrRefCount(listObj);
bytes = TclGetStringFromObj(objPtr, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(objPtr);
return TCL_OK;
}
/*
* General case: runtime concat.
*/
|
| ︙ | ︙ | |||
949 950 951 952 953 954 955 | * runtime. * *---------------------------------------------------------------------- */ int TclCompileContinueCmd( | | | < | 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 |
* runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileContinueCmd(
TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
ExceptionRange *rangePtr;
ExceptionAux *auxPtr;
/*
* There should be no argument after the "continue".
|
| ︙ | ︙ | |||
1015 1016 1017 1018 1019 1020 1021 |
*/
int
TclCompileDictSetCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 |
*/
int
TclCompileDictSetCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int i, dictVarIndex;
Tcl_Token *varTokenPtr;
/*
* There must be at least one argument after the command.
*/
if (parsePtr->numWords < 4) {
|
| ︙ | ︙ | |||
1093 1094 1095 1096 1097 1098 1099 |
/*
* Parse the increment amount, if present.
*/
if (parsePtr->numWords == 4) {
const char *word;
| | < | 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 |
/*
* Parse the increment amount, if present.
*/
if (parsePtr->numWords == 4) {
const char *word;
int numBytes, code;
Tcl_Token *incrTokenPtr;
Tcl_Obj *intObj;
incrTokenPtr = TokenAfter(keyTokenPtr);
if (incrTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
return TclCompileBasic2Or3ArgCmd(interp, parsePtr,cmdPtr, envPtr);
}
|
| ︙ | ︙ | |||
1142 1143 1144 1145 1146 1147 1148 |
}
int
TclCompileDictGetCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 |
}
int
TclCompileDictGetCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int i;
/*
* There must be at least two arguments after the command (the single-arg
* case is legal, but too special and magic for us to deal with here).
*/
/* TODO: Consider support for compiling expanded args. */
|
| ︙ | ︙ | |||
1179 1180 1181 1182 1183 1184 1185 |
}
int
TclCompileDictGetWithDefaultCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 |
}
int
TclCompileDictGetWithDefaultCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int i;
/*
* There must be at least three arguments after the command.
*/
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 4) {
|
| ︙ | ︙ | |||
1211 1212 1213 1214 1215 1216 1217 |
}
int
TclCompileDictExistsCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 |
}
int
TclCompileDictExistsCmd(
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int i;
/*
* There must be at least two arguments after the command (the single-arg
* case is legal, but too special and magic for us to deal with here).
*/
/* TODO: Consider support for compiling expanded args. */
|
| ︙ | ︙ | |||
1252 1253 1254 1255 1256 1257 1258 |
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
| < > | 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 |
Tcl_Interp *interp, /* Used for looking up stuff. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int i, dictVarIndex;
/*
* There must be at least one argument after the variable name for us to
* compile to bytecode.
*/
|
| ︙ | ︙ | |||
1310 1311 1312 1313 1314 1315 1316 |
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
int worker; /* Temp var for building the value in. */
Tcl_Token *tokenPtr;
Tcl_Obj *keyObj, *valueObj, *dictObj;
const char *bytes;
| | < | 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 |
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
int worker; /* Temp var for building the value in. */
Tcl_Token *tokenPtr;
Tcl_Obj *keyObj, *valueObj, *dictObj;
const char *bytes;
int i, len;
if ((parsePtr->numWords & 1) == 0) {
return TCL_ERROR;
}
/*
* See if we can build the value at compile time...
|
| ︙ | ︙ | |||
1594 1595 1596 1597 1598 1599 1600 |
if (Tcl_SplitList(NULL, Tcl_DStringValue(&buffer), &numVars,
&argv) != TCL_OK) {
Tcl_DStringFree(&buffer);
return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
Tcl_DStringFree(&buffer);
if (numVars != 2) {
| | | | 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 |
if (Tcl_SplitList(NULL, Tcl_DStringValue(&buffer), &numVars,
&argv) != TCL_OK) {
Tcl_DStringFree(&buffer);
return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
Tcl_DStringFree(&buffer);
if (numVars != 2) {
ckfree(argv);
return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
nameChars = strlen(argv[0]);
keyVarIndex = LocalScalar(argv[0], nameChars, envPtr);
nameChars = strlen(argv[1]);
valueVarIndex = LocalScalar(argv[1], nameChars, envPtr);
ckfree(argv);
if ((keyVarIndex < 0) || (valueVarIndex < 0)) {
return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
/*
* Allocate a temporary variable to store the iterator reference. The
|
| ︙ | ︙ | |||
1810 1811 1812 1813 1814 1815 1816 |
/*
* Assemble the instruction metadata. This is complex enough that it is
* represented as auxData; it holds an ordered list of variable indices
* that are to be used.
*/
| | | | 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 |
/*
* Assemble the instruction metadata. This is complex enough that it is
* represented as auxData; it holds an ordered list of variable indices
* that are to be used.
*/
duiPtr = (DictUpdateInfo *)ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1));
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.
*/
|
| ︙ | ︙ | |||
1893 1894 1895 1896 1897 1898 1899 |
TclEmitInstInt4( INST_REVERSE, 3, envPtr);
TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
TclEmitInt4( infoIndex, envPtr);
TclEmitInvoke(envPtr,INST_RETURN_STK);
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
| | | | | 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 |
TclEmitInstInt4( INST_REVERSE, 3, envPtr);
TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex, envPtr);
TclEmitInt4( infoIndex, envPtr);
TclEmitInvoke(envPtr,INST_RETURN_STK);
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
}
TclStackFree(interp, keyTokenPtrs);
return TCL_OK;
/*
* Clean up after a failure to create the DictUpdateInfo structure.
*/
failedUpdateInfoAssembly:
ckfree(duiPtr);
TclStackFree(interp, keyTokenPtrs);
issueFallback:
return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
int
TclCompileDictAppendCmd(
|
| ︙ | ︙ | |||
2255 2256 2257 2258 2259 2260 2261 |
TclEmitInvoke(envPtr, INST_RETURN_STK);
/*
* Prepare for the start of the next command.
*/
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
| | | | 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 |
TclEmitInvoke(envPtr, INST_RETURN_STK);
/*
* Prepare for the start of the next command.
*/
if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2289 2290 2291 2292 2293 2294 2295 |
*/
static ClientData
DupDictUpdateInfo(
ClientData clientData)
{
DictUpdateInfo *dui1Ptr, *dui2Ptr;
| | | | | | | | | | | | | | 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 |
*/
static ClientData
DupDictUpdateInfo(
ClientData clientData)
{
DictUpdateInfo *dui1Ptr, *dui2Ptr;
size_t len;
dui1Ptr = (DictUpdateInfo *)clientData;
len = sizeof(DictUpdateInfo) + sizeof(int) * (dui1Ptr->length - 1);
dui2Ptr = (DictUpdateInfo *)ckalloc(len);
memcpy(dui2Ptr, dui1Ptr, len);
return dui2Ptr;
}
static void
FreeDictUpdateInfo(
ClientData clientData)
{
ckfree(clientData);
}
static void
PrintDictUpdateInfo(
ClientData clientData,
Tcl_Obj *appendObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(unsigned int))
{
DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData;
int i;
for (i=0 ; i<duiPtr->length ; i++) {
if (i) {
Tcl_AppendToObj(appendObj, ", ", -1);
}
Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]);
}
}
static void
DisassembleDictUpdateInfo(
ClientData clientData,
Tcl_Obj *dictObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(unsigned int))
{
DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData;
int i;
Tcl_Obj *variables = Tcl_NewObj();
for (i=0 ; i<duiPtr->length ; i++) {
Tcl_ListObjAppendElement(NULL, variables,
Tcl_NewIntObj(duiPtr->varIndices[i]));
}
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("variables", -1),
|
| ︙ | ︙ | |||
2365 2366 2367 2368 2369 2370 2371 |
*/
int
TclCompileErrorCmd(
Tcl_Interp *interp, /* Used for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > > > < < < | 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 |
*/
int
TclCompileErrorCmd(
Tcl_Interp *interp, /* Used for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
/*
* General syntax: [error message ?errorInfo? ?errorCode?]
*/
if (parsePtr->numWords < 2 || parsePtr->numWords > 4) {
return TCL_ERROR;
}
/*
* Handle the message.
*/
|
| ︙ | ︙ | |||
2439 2440 2441 2442 2443 2444 2445 |
*/
int
TclCompileExprCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 |
*/
int
TclCompileExprCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *firstWordPtr;
if (parsePtr->numWords == 1) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2484 2485 2486 2487 2488 2489 2490 |
*/
int
TclCompileForCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 |
*/
int
TclCompileForCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr;
JumpFixup jumpEvalCondFixup;
int bodyCodeOffset, nextCodeOffset, jumpDist;
int bodyRange, nextRange;
if (parsePtr->numWords != 5) {
return TCL_ERROR;
}
/*
* If the test expression requires substitutions, don't compile the for
|
| ︙ | ︙ | |||
2695 2696 2697 2698 2699 2700 2701 |
*/
static int
CompileEachloopCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 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 |
*/
static int
CompileEachloopCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr, /* Holds resulting instructions. */
int collect) /* Select collecting or accumulating mode
* (TCL_EACH_*) */
{
DefineLineInformation; /* TIP #280 */
Proc *procPtr = envPtr->procPtr;
ForeachInfo *infoPtr=NULL; /* Points to the structure describing this
* foreach command. Stored in a AuxData
* record in the ByteCode. */
Tcl_Token *tokenPtr, *bodyTokenPtr;
int jumpBackOffset, infoIndex, range;
int numWords, numLists, i, j, code = TCL_OK;
Tcl_Obj *varListObj = NULL;
/*
* If the foreach command isn't in a procedure, don't compile it inline:
* the payoff is too small.
*/
if (procPtr == NULL) {
|
| ︙ | ︙ | |||
2746 2747 2748 2749 2750 2751 2752 |
/*
* 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;
| | | 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 |
/*
* 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(sizeof(ForeachInfo)
+ (numLists - 1) * 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.
|
| ︙ | ︙ | |||
2780 2781 2782 2783 2784 2785 2786 |
if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) ||
TCL_OK != Tcl_ListObjLength(NULL, varListObj, &numVars) ||
numVars == 0) {
code = TCL_ERROR;
goto done;
}
| | | < < | | | 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 |
if (!TclWordKnownAtCompileTime(tokenPtr, varListObj) ||
TCL_OK != Tcl_ListObjLength(NULL, varListObj, &numVars) ||
numVars == 0) {
code = TCL_ERROR;
goto done;
}
varListPtr = (ForeachVarList *)ckalloc(sizeof(ForeachVarList)
+ (numVars - 1) * sizeof(int));
varListPtr->numVars = numVars;
infoPtr->varLists[i/2] = varListPtr;
infoPtr->numLists++;
for (j = 0; j < numVars; j++) {
Tcl_Obj *varNameObj;
const char *bytes;
int numBytes, varIndex;
Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj);
bytes = TclGetStringFromObj(varNameObj, &numBytes);
varIndex = LocalScalar(bytes, numBytes, envPtr);
if (varIndex < 0) {
code = TCL_ERROR;
goto done;
}
varListPtr->varIndexes[j] = varIndex;
}
Tcl_SetObjLength(varListObj, 0);
|
| ︙ | ︙ | |||
2913 2914 2915 2916 2917 2918 2919 |
*/
static ClientData
DupForeachInfo(
ClientData clientData) /* The foreach command's compilation auxiliary
* data to duplicate. */
{
| | | | | | 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 |
*/
static ClientData
DupForeachInfo(
ClientData clientData) /* The foreach command's compilation auxiliary
* data to duplicate. */
{
ForeachInfo *srcPtr = (ForeachInfo *)clientData;
ForeachInfo *dupPtr;
ForeachVarList *srcListPtr, *dupListPtr;
int numVars, i, j, numLists = srcPtr->numLists;
dupPtr = (ForeachInfo *)ckalloc(sizeof(ForeachInfo)
+ 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(sizeof(ForeachVarList)
+ numVars * sizeof(int));
dupListPtr->numVars = numVars;
for (j = 0; j < numVars; j++) {
dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j];
}
dupPtr->varLists[i] = dupListPtr;
}
|
| ︙ | ︙ | |||
2962 2963 2964 2965 2966 2967 2968 |
*/
static void
FreeForeachInfo(
ClientData clientData) /* The foreach command's compilation auxiliary
* data to free. */
{
| | | | | | | 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 |
*/
static void
FreeForeachInfo(
ClientData clientData) /* The foreach command's compilation auxiliary
* data to free. */
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *listPtr;
int numLists = infoPtr->numLists;
int i;
for (i = 0; i < numLists; i++) {
listPtr = infoPtr->varLists[i];
ckfree(listPtr);
}
ckfree(infoPtr);
}
/*
*----------------------------------------------------------------------
*
* PrintForeachInfo, DisassembleForeachInfo --
*
|
| ︙ | ︙ | |||
2995 2996 2997 2998 2999 3000 3001 |
*----------------------------------------------------------------------
*/
static void
PrintForeachInfo(
ClientData clientData,
Tcl_Obj *appendObj,
| | | | | | 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 |
*----------------------------------------------------------------------
*/
static void
PrintForeachInfo(
ClientData clientData,
Tcl_Obj *appendObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(unsigned int))
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
int i, j;
Tcl_AppendToObj(appendObj, "data=[", -1);
for (i=0 ; i<infoPtr->numLists ; i++) {
if (i) {
Tcl_AppendToObj(appendObj, ", ", -1);
|
| ︙ | ︙ | |||
3035 3036 3037 3038 3039 3040 3041 |
}
}
static void
PrintNewForeachInfo(
ClientData clientData,
Tcl_Obj *appendObj,
| | | | | | 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 |
}
}
static void
PrintNewForeachInfo(
ClientData clientData,
Tcl_Obj *appendObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(unsigned int))
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
int i, j;
Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+d, vars=",
infoPtr->loopCtTemp);
for (i=0 ; i<infoPtr->numLists ; i++) {
if (i) {
Tcl_AppendToObj(appendObj, ",", -1);
|
| ︙ | ︙ | |||
3065 3066 3067 3068 3069 3070 3071 |
}
}
static void
DisassembleForeachInfo(
ClientData clientData,
Tcl_Obj *dictObj,
| | | | | | 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 |
}
}
static void
DisassembleForeachInfo(
ClientData clientData,
Tcl_Obj *dictObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(unsigned int))
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
int i, j;
Tcl_Obj *objPtr, *innerPtr;
/*
* Data stores.
*/
|
| ︙ | ︙ | |||
3112 3113 3114 3115 3116 3117 3118 |
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr);
}
static void
DisassembleNewForeachInfo(
ClientData clientData,
Tcl_Obj *dictObj,
| | | | | | 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 |
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("assign", -1), objPtr);
}
static void
DisassembleNewForeachInfo(
ClientData clientData,
Tcl_Obj *dictObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(unsigned int))
{
ForeachInfo *infoPtr = (ForeachInfo *)clientData;
ForeachVarList *varsPtr;
int i, j;
Tcl_Obj *objPtr, *innerPtr;
/*
* Jump offset.
*/
|
| ︙ | ︙ | |||
3168 3169 3170 3171 3172 3173 3174 |
*/
int
TclCompileFormatCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | | < | 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 |
*/
int
TclCompileFormatCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
Tcl_Obj **objv, *formatObj, *tmpObj;
const char *bytes, *start;
int i, j, len;
/*
* Don't handle any guaranteed-error cases.
*/
if (parsePtr->numWords < 2) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
3200 3201 3202 3203 3204 3205 3206 |
Tcl_IncrRefCount(formatObj);
tokenPtr = TokenAfter(tokenPtr);
if (!TclWordKnownAtCompileTime(tokenPtr, formatObj)) {
Tcl_DecrRefCount(formatObj);
return TCL_ERROR;
}
| | | | | 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 |
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);
objv[i] = Tcl_NewObj();
Tcl_IncrRefCount(objv[i]);
if (!TclWordKnownAtCompileTime(tokenPtr, objv[i])) {
goto checkForStringConcatCase;
}
}
/*
* Everything is a literal, so the result is constant too (or an error if
* the format is broken). Do the format now.
*/
tmpObj = Tcl_Format(interp, Tcl_GetString(formatObj),
parsePtr->numWords-2, objv);
for (; --i>=0 ;) {
Tcl_DecrRefCount(objv[i]);
}
ckfree(objv);
Tcl_DecrRefCount(formatObj);
if (tmpObj == NULL) {
TclCompileSyntaxError(interp, envPtr);
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
3250 3251 3252 3253 3254 3255 3256 |
* First, get the state of the system relatively sensible (cleaning up
* after our attempt to spot a literal).
*/
for (; i>=0 ; i--) {
Tcl_DecrRefCount(objv[i]);
}
| | | | 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 |
* First, get the state of the system relatively sensible (cleaning up
* after our attempt to spot a literal).
*/
for (; i>=0 ; i--) {
Tcl_DecrRefCount(objv[i]);
}
ckfree(objv);
tokenPtr = TokenAfter(parsePtr->tokenPtr);
tokenPtr = TokenAfter(tokenPtr);
i = 0;
/*
* Now scan through and check for non-%s and non-%% substitutions.
*/
for (bytes = Tcl_GetString(formatObj) ; *bytes ; bytes++) {
if (*bytes == '%') {
bytes++;
if (*bytes == 's') {
i++;
continue;
} else if (*bytes == '%') {
continue;
|
| ︙ | ︙ | |||
3292 3293 3294 3295 3296 3297 3298 |
* we'd have the case in the first half of this function) which we will
* concatenate.
*/
i = 0; /* The count of things to concat. */
j = 2; /* The index into the argument tokens, for
* TIP#280 handling. */
| | | | 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 |
* we'd have the case in the first half of this function) which we will
* concatenate.
*/
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. */
tmpObj = Tcl_NewObj(); /* 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) {
|
| ︙ | ︙ | |||
3392 3393 3394 3395 3396 3397 3398 |
}
return index;
}
int
TclLocalScalar(
const char *bytes,
| | | 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 |
}
return index;
}
int
TclLocalScalar(
const char *bytes,
int numBytes,
CompileEnv *envPtr)
{
Tcl_Token token[2] = {{TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1},
{TCL_TOKEN_TEXT, NULL, 0, 0}};
token[1].start = bytes;
token[1].size = numBytes;
|
| ︙ | ︙ | |||
3441 3442 3443 3444 3445 3446 3447 |
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Token *varTokenPtr, /* Points to a variable token. */
CompileEnv *envPtr, /* Holds resulting instructions. */
int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */
int *localIndexPtr, /* Must not be NULL. */
int *isScalarPtr) /* Must not be NULL. */
{
| | | < | | 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 |
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Token *varTokenPtr, /* Points to a variable token. */
CompileEnv *envPtr, /* Holds resulting instructions. */
int flags, /* TCL_NO_LARGE_INDEX | TCL_NO_ELEMENT. */
int *localIndexPtr, /* Must not be NULL. */
int *isScalarPtr) /* Must not be NULL. */
{
const char *p;
const char *last, *name, *elName;
int n;
Tcl_Token *elemTokenPtr = NULL;
int nameLen, elNameLen, simpleVarName, localIndex;
int elemTokenCount = 0, allocedTokens = 0, removedParen = 0;
/*
* Decide if we can use a frame slot for the var/array name or if we need
* to emit code to compute and push the name at runtime. We use a frame
* slot (entry in the array of local vars) if we are compiling a procedure
* body and if the name is simple text that does not include namespace
|
| ︙ | ︙ | |||
3476 3477 3478 3479 3480 3481 3482 |
name = varTokenPtr[1].start;
nameLen = varTokenPtr[1].size;
if (name[nameLen-1] == ')') {
/*
* last char is ')' => potential array reference.
*/
| | | | | < | | | 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 |
name = varTokenPtr[1].start;
nameLen = varTokenPtr[1].size;
if (name[nameLen-1] == ')') {
/*
* last char is ')' => potential array reference.
*/
last = &name[nameLen-1];
if (*last == ')') {
for (p = name; p < last; p++) {
if (*p == '(') {
elName = p + 1;
elNameLen = last - elName;
nameLen = p - name;
break;
}
}
}
if (!(flags & TCL_NO_ELEMENT) && elNameLen) {
/*
* An array element, the element name is a simple string:
* assemble the corresponding token.
*/
elemTokenPtr = (Tcl_Token *)TclStackAlloc(interp, sizeof(Tcl_Token));
allocedTokens = 1;
elemTokenPtr->type = TCL_TOKEN_TEXT;
elemTokenPtr->start = elName;
elemTokenPtr->size = elNameLen;
elemTokenPtr->numComponents = 0;
elemTokenCount = 1;
}
}
} else if (interp && ((n = varTokenPtr->numComponents) > 1)
&& (varTokenPtr[1].type == TCL_TOKEN_TEXT)
&& (varTokenPtr[n].type == TCL_TOKEN_TEXT)
&& (*(varTokenPtr[n].start + varTokenPtr[n].size - 1) == ')')) {
/*
* Check for parentheses inside first token.
*/
simpleVarName = 0;
for (p = varTokenPtr[1].start,
last = p + varTokenPtr[1].size; p < last; p++) {
if (*p == '(') {
simpleVarName = 1;
break;
}
}
if (simpleVarName) {
int remainingLen;
/*
* Check the last token: if it is just ')', do not count it.
* Otherwise, remove the ')' and flag so that it is restored at
* the end.
*/
|
| ︙ | ︙ | |||
3550 3551 3552 3553 3554 3555 3556 |
if (!(flags & TCL_NO_ELEMENT)) {
if (remainingLen) {
/*
* Make a first token with the extra characters in the first
* token.
*/
| | | 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 |
if (!(flags & TCL_NO_ELEMENT)) {
if (remainingLen) {
/*
* Make a first token with the extra characters in the first
* token.
*/
elemTokenPtr = (Tcl_Token *)TclStackAlloc(interp, n * sizeof(Tcl_Token));
allocedTokens = 1;
elemTokenPtr->type = TCL_TOKEN_TEXT;
elemTokenPtr->start = elName;
elemTokenPtr->size = remainingLen;
elemTokenPtr->numComponents = 0;
elemTokenCount = n;
|
| ︙ | ︙ | |||
3583 3584 3585 3586 3587 3588 3589 |
if (simpleVarName) {
/*
* See whether name has any namespace separators (::'s).
*/
int hasNsQualifiers = 0;
| | | 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 |
if (simpleVarName) {
/*
* See whether name has any namespace separators (::'s).
*/
int hasNsQualifiers = 0;
for (p = name, last = p + nameLen-1; p < last; p++) {
if ((*p == ':') && (*(p+1) == ':')) {
hasNsQualifiers = 1;
break;
}
}
/*
|
| ︙ | ︙ |
Changes to generic/tclCompCmdsGR.c.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 |
*
*----------------------------------------------------------------------
*/
int
TclGetIndexFromToken(
Tcl_Token *tokenPtr,
| | | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
*
*----------------------------------------------------------------------
*/
int
TclGetIndexFromToken(
Tcl_Token *tokenPtr,
int before,
int after,
int *indexPtr)
{
Tcl_Obj *tmpObj = Tcl_NewObj();
int result = TCL_ERROR;
if (TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
result = TclIndexEncode(NULL, tmpObj, before, after, indexPtr);
|
| ︙ | ︙ | |||
82 83 84 85 86 87 88 |
*/
int
TclCompileGlobalCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 |
*/
int
TclCompileGlobalCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr;
int localIndex, numWords, i;
/* TODO: Consider support for compiling expanded args. */
numWords = parsePtr->numWords;
if (numWords < 2) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
164 165 166 167 168 169 170 |
*/
int
TclCompileIfCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | < | 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 |
*/
int
TclCompileIfCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
JumpFixupArray jumpFalseFixupArray;
/* Used to fix the ifFalse jump after each
* test when its target PC is determined. */
JumpFixupArray jumpEndFixupArray;
/* Used to fix the jump after each "then" body
* to the end of the "if" when that PC is
* determined. */
Tcl_Token *tokenPtr, *testTokenPtr;
int jumpIndex = 0; /* Avoid compiler warning. */
int jumpFalseDist, numWords, wordIdx, numBytes, j, code;
const char *word;
int realCond = 1; /* Set to 0 for static conditions:
* "if 0 {..}" */
int boolVal; /* Value of static condition. */
int compileScripts = 1;
/*
* Only compile the "if" command if all arguments are simple words, in
* order to insure correct substitution [Bug 219166]
*/
tokenPtr = parsePtr->tokenPtr;
|
| ︙ | ︙ | |||
468 469 470 471 472 473 474 |
*/
int
TclCompileIncrCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 |
*/
int
TclCompileIncrCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *incrTokenPtr;
int isScalar, localIndex, haveImmValue, immValue;
if ((parsePtr->numWords != 2) && (parsePtr->numWords != 3)) {
return TCL_ERROR;
}
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
| ︙ | ︙ | |||
496 497 498 499 500 501 502 |
haveImmValue = 0;
immValue = 1;
if (parsePtr->numWords == 3) {
incrTokenPtr = TokenAfter(varTokenPtr);
if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
const char *word = incrTokenPtr[1].start;
| | | 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 |
haveImmValue = 0;
immValue = 1;
if (parsePtr->numWords == 3) {
incrTokenPtr = TokenAfter(varTokenPtr);
if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
const char *word = incrTokenPtr[1].start;
int numBytes = incrTokenPtr[1].size;
int code;
Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes);
Tcl_IncrRefCount(intObj);
code = TclGetIntFromObj(NULL, intObj, &immValue);
TclDecrRefCount(intObj);
if ((code == TCL_OK) && (-127 <= immValue) && (immValue <= 127)) {
|
| ︙ | ︙ | |||
586 587 588 589 590 591 592 |
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
Tcl_Obj *objPtr;
| | | 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 |
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
Tcl_Obj *objPtr;
const char *bytes;
/*
* We require one compile-time known argument for the case we can compile.
*/
if (parsePtr->numWords == 1) {
return TclCompileBasic0ArgCmd(interp, parsePtr, cmdPtr, envPtr);
|
| ︙ | ︙ | |||
637 638 639 640 641 642 643 |
notCompilable:
Tcl_DecrRefCount(objPtr);
return TclCompileBasic1ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
int
TclCompileInfoCoroutineCmd(
| | | < | 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 |
notCompilable:
Tcl_DecrRefCount(objPtr);
return TclCompileBasic1ArgCmd(interp, parsePtr, cmdPtr, envPtr);
}
int
TclCompileInfoCoroutineCmd(
TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* Only compile [info coroutine] without arguments.
*/
if (parsePtr->numWords != 1) {
|
| ︙ | ︙ | |||
665 666 667 668 669 670 671 |
}
int
TclCompileInfoExistsCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 |
}
int
TclCompileInfoExistsCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int isScalar, localIndex;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
/*
* Decide if we can use a frame slot for the var/array name or if we need
|
| ︙ | ︙ | |||
714 715 716 717 718 719 720 |
}
int
TclCompileInfoLevelCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 |
}
int
TclCompileInfoLevelCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* Only compile [info level] without arguments or with a single argument.
*/
if (parsePtr->numWords == 1) {
|
| ︙ | ︙ | |||
749 750 751 752 753 754 755 |
}
int
TclCompileInfoObjectClassCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | < | 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 |
}
int
TclCompileInfoObjectClassCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
CompileWord(envPtr, tokenPtr, interp, 1);
TclEmitOpcode( INST_TCLOO_CLASS, envPtr);
return TCL_OK;
}
int
TclCompileInfoObjectIsACmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
/*
* We only handle [info object isa object <somevalue>]. The first three
|
| ︙ | ︙ | |||
805 806 807 808 809 810 811 |
}
int
TclCompileInfoObjectNamespaceCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 |
}
int
TclCompileInfoObjectNamespaceCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
if (parsePtr->numWords != 2) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
843 844 845 846 847 848 849 |
*/
int
TclCompileLappendCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 |
*/
int
TclCompileLappendCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *valueTokenPtr;
int isScalar, localIndex, numWords, i;
/* TODO: Consider support for compiling expanded args. */
numWords = parsePtr->numWords;
if (numWords < 3) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
959 960 961 962 963 964 965 |
*/
int
TclCompileLassignCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 |
*/
int
TclCompileLassignCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int isScalar, localIndex, numWords, idx;
numWords = parsePtr->numWords;
/*
* Check for command syntax error, but we'll punt that to runtime.
*/
|
| ︙ | ︙ | |||
1063 1064 1065 1066 1067 1068 1069 |
*/
int
TclCompileLindexCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 |
*/
int
TclCompileLindexCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *idxTokenPtr, *valTokenPtr;
int i, idx, numWords = parsePtr->numWords;
/*
* Quit if too few args.
*/
/* TODO: Consider support for compiling expanded args. */
if (numWords <= 1) {
|
| ︙ | ︙ | |||
1154 1155 1156 1157 1158 1159 1160 |
*/
int
TclCompileListCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 |
*/
int
TclCompileListCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *valueTokenPtr;
int i, numWords, concat, build;
Tcl_Obj *listObj, *objPtr;
|
| ︙ | ︙ | |||
1268 1269 1270 1271 1272 1273 1274 |
*/
int
TclCompileLlengthCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < < > | 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 |
*/
int
TclCompileLlengthCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
varTokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, varTokenPtr, interp, 1);
|
| ︙ | ︙ | |||
1301 1302 1303 1304 1305 1306 1307 |
*/
int
TclCompileLrangeCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
| | < < > | 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 |
*/
int
TclCompileLrangeCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *listTokenPtr;
int idx1, idx2;
if (parsePtr->numWords != 4) {
return TCL_ERROR;
}
listTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
| ︙ | ︙ | |||
1362 1363 1364 1365 1366 1367 1368 |
*/
int
TclCompileLinsertCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
| | < < > | 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 |
*/
int
TclCompileLinsertCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *listTokenPtr;
int idx, i;
if (parsePtr->numWords < 3) {
return TCL_ERROR;
}
listTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
| ︙ | ︙ | |||
1465 1466 1467 1468 1469 1470 1471 |
*/
int
TclCompileLreplaceCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
| | < < > | 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 |
*/
int
TclCompileLreplaceCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *listTokenPtr;
int idx1, idx2, i;
int emptyPrefix=1, suffixStart = 0;
if (parsePtr->numWords < 4) {
return TCL_ERROR;
}
listTokenPtr = TokenAfter(parsePtr->tokenPtr);
|
| ︙ | ︙ | |||
1629 1630 1631 1632 1633 1634 1635 |
*/
int
TclCompileLsetCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
| | < > < | 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 |
*/
int
TclCompileLsetCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
int tempDepth; /* Depth used for emitting one part of the
* code burst. */
Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
* parse of the variable name. */
int localIndex; /* Index of var in local var table. */
int isScalar; /* Flag == 1 if scalar, 0 if array. */
int i;
/*
* Check argument count.
*/
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 3) {
|
| ︙ | ︙ | |||
1773 1774 1775 1776 1777 1778 1779 | * command at runtime. * *---------------------------------------------------------------------- */ int TclCompileNamespaceCurrentCmd( | | | < | 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 |
* command at runtime.
*
*----------------------------------------------------------------------
*/
int
TclCompileNamespaceCurrentCmd(
TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* Only compile [namespace current] without arguments.
*/
if (parsePtr->numWords != 1) {
|
| ︙ | ︙ | |||
1801 1802 1803 1804 1805 1806 1807 |
}
int
TclCompileNamespaceCodeCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < < > | 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 |
}
int
TclCompileNamespaceCodeCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
/*
|
| ︙ | ︙ | |||
1851 1852 1853 1854 1855 1856 1857 |
}
int
TclCompileNamespaceOriginCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < < > | < < > | 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 |
}
int
TclCompileNamespaceOriginCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
TclEmitOpcode( INST_ORIGIN_COMMAND, envPtr);
return TCL_OK;
}
int
TclCompileNamespaceQualifiersCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
int off;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
CompileWord(envPtr, tokenPtr, interp, 1);
|
| ︙ | ︙ | |||
1909 1910 1911 1912 1913 1914 1915 |
}
int
TclCompileNamespaceTailCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < < > | 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 |
}
int
TclCompileNamespaceTailCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
JumpFixup jumpFixup;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
1946 1947 1948 1949 1950 1951 1952 |
}
int
TclCompileNamespaceUpvarCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 |
}
int
TclCompileNamespaceUpvarCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
int localIndex, numWords, i;
if (envPtr->procPtr == NULL) {
return TCL_ERROR;
}
/*
* Only compile [namespace upvar ...]: needs an even number of args, >=4
|
| ︙ | ︙ | |||
2007 2008 2009 2010 2011 2012 2013 |
}
int
TclCompileNamespaceWhichCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 |
}
int
TclCompileNamespaceWhichCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *opt;
int idx;
if (parsePtr->numWords < 2 || parsePtr->numWords > 3) {
|
| ︙ | ︙ | |||
2071 2072 2073 2074 2075 2076 2077 |
*/
int
TclCompileRegexpCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
| | < > < | < | 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 |
*/
int
TclCompileRegexpCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the
* parse of the RE or string. */
int i, len, nocase, exact, sawLast, simple;
const char *str;
/*
* We are only interested in compiling simple regexp cases. Currently
* supported compile cases are:
* regexp ?-nocase? ?--? staticString $var
* regexp ?-nocase? ?--? {^staticString$} $var
*/
|
| ︙ | ︙ | |||
2119 2120 2121 2122 2123 2124 2125 |
}
str = varTokenPtr[1].start;
len = varTokenPtr[1].size;
if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
sawLast++;
i++;
break;
| | | 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 |
}
str = varTokenPtr[1].start;
len = varTokenPtr[1].size;
if ((len == 2) && (str[0] == '-') && (str[1] == '-')) {
sawLast++;
i++;
break;
} else if ((len > 1) && (strncmp(str, "-nocase", len) == 0)) {
nocase = 1;
} else {
/*
* Not an option we recognize.
*/
return TCL_ERROR;
|
| ︙ | ︙ | |||
2237 2238 2239 2240 2241 2242 2243 |
*/
int
TclCompileRegsubCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
| | < | 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 |
*/
int
TclCompileRegsubCmd(
Tcl_Interp *interp, /* Tcl interpreter for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
/*
* We only compile the case with [regsub -all] where the pattern is both
* known at compile time and simple (i.e., no RE metacharacters). That is,
* the pattern must be translatable into a glob like "*foo*" with no other
* glob metacharacters inside it; there must be some "foo" in there too.
|
| ︙ | ︙ | |||
2266 2267 2268 2269 2270 2271 2272 |
*/
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *stringTokenPtr;
Tcl_Obj *patternObj = NULL, *replacementObj = NULL;
Tcl_DString pattern;
const char *bytes;
| | < | 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 |
*/
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *stringTokenPtr;
Tcl_Obj *patternObj = NULL, *replacementObj = NULL;
Tcl_DString pattern;
const char *bytes;
int len, exact, quantified, result = TCL_ERROR;
if (parsePtr->numWords < 5 || parsePtr->numWords > 6) {
return TCL_ERROR;
}
/*
* Parse the "-all", which must be the first argument (other options not
|
| ︙ | ︙ | |||
2345 2346 2347 2348 2349 2350 2351 |
if (bytes[1] == '\0') {
/*
* OK, we've proved there are no metacharacters except for the
* '*' at each end.
*/
len = Tcl_DStringLength(&pattern) - 2;
| | | 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 |
if (bytes[1] == '\0') {
/*
* OK, we've proved there are no metacharacters except for the
* '*' at each end.
*/
len = Tcl_DStringLength(&pattern) - 2;
if (len > 0) {
goto isSimpleGlob;
}
/*
* The pattern is "**"! I believe that should be impossible,
* but we definitely can't handle that at all.
*/
|
| ︙ | ︙ | |||
2413 2414 2415 2416 2417 2418 2419 |
*/
int
TclCompileReturnCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 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 |
*/
int
TclCompileReturnCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
/*
* General syntax: [return ?-option value ...? ?result?]
* An even number of words means an explicit result argument is present.
*/
int level, code, objc, size, status = TCL_OK;
int numWords = parsePtr->numWords;
int explicitResult = (0 == (numWords % 2));
int numOptionWords = numWords - 1 - explicitResult;
Tcl_Obj *returnOpts, **objv;
Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
/*
* Check for special case which can always be compiled:
* return -options <opts> <msg>
* Unlike the normal [return] compilation, this version does everything at
* runtime so it can handle arbitrary words and not just literals. Note
* that if INST_RETURN_STK wasn't already needed for something else
|
| ︙ | ︙ | |||
2454 2455 2456 2457 2458 2459 2460 |
return TCL_OK;
}
/*
* Allocate some working space.
*/
| | | 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 |
return TCL_OK;
}
/*
* Allocate some working space.
*/
objv = (Tcl_Obj **)TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *));
/*
* Scan through the return options. If any are unknown at compile time,
* there is no value in bytecompiling. Save the option values known in an
* objv array for merging into a return options dictionary.
*
* TODO: There is potential for improvement if all option keys are known
|
| ︙ | ︙ | |||
2632 2633 2634 2635 2636 2637 2638 |
void
TclCompileSyntaxError(
Tcl_Interp *interp,
CompileEnv *envPtr)
{
Tcl_Obj *msg = Tcl_GetObjResult(interp);
| | | 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 |
void
TclCompileSyntaxError(
Tcl_Interp *interp,
CompileEnv *envPtr)
{
Tcl_Obj *msg = Tcl_GetObjResult(interp);
int numBytes;
const char *bytes = TclGetStringFromObj(msg, &numBytes);
TclErrorStackResetIf(interp, bytes, numBytes);
TclEmitPush(TclRegisterLiteral(envPtr, bytes, numBytes, 0), envPtr);
CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR)));
Tcl_ResetResult(interp);
|
| ︙ | ︙ | |||
2665 2666 2667 2668 2669 2670 2671 |
*/
int
TclCompileUpvarCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 |
*/
int
TclCompileUpvarCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr;
int localIndex, numWords, i;
Tcl_Obj *objPtr;
if (envPtr->procPtr == NULL) {
return TCL_ERROR;
}
numWords = parsePtr->numWords;
|
| ︙ | ︙ | |||
2772 2773 2774 2775 2776 2777 2778 |
*/
int
TclCompileVariableCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 |
*/
int
TclCompileVariableCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *valueTokenPtr;
int localIndex, numWords, i;
numWords = parsePtr->numWords;
if (numWords < 2) {
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
2854 2855 2856 2857 2858 2859 2860 | * None. * *---------------------------------------------------------------------- */ static int IndexTailVarIfKnown( | | | < | 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 |
* None.
*
*----------------------------------------------------------------------
*/
static int
IndexTailVarIfKnown(
TCL_UNUSED(Tcl_Interp *),
Tcl_Token *varTokenPtr, /* Token representing the variable name */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Obj *tailPtr;
const char *tailName, *p;
int len, n = varTokenPtr->numComponents;
Tcl_Token *lastTokenPtr;
int full, localIndex;
/*
* Determine if the tail is (a) known at compile time, and (b) not an
* array element. Should any of these fail, return an error so that the
* non-compiled command will be called at runtime.
|
| ︙ | ︙ | |||
2947 2948 2949 2950 2951 2952 2953 |
*/
int
TclCompileObjectNextCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 |
*/
int
TclCompileObjectNextCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int i;
if (parsePtr->numWords > 255) {
|
| ︙ | ︙ | |||
2972 2973 2974 2975 2976 2977 2978 |
}
int
TclCompileObjectNextToCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | | < | 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 |
}
int
TclCompileObjectNextToCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int i;
if (parsePtr->numWords < 2 || parsePtr->numWords > 255) {
return TCL_ERROR;
}
for (i=0 ; i<parsePtr->numWords ; i++) {
CompileWord(envPtr, tokenPtr, interp, i);
tokenPtr = TokenAfter(tokenPtr);
}
TclEmitInstInt1( INST_TCLOO_NEXT_CLASS, i, envPtr);
return TCL_OK;
}
int
TclCompileObjectSelfCmd(
TCL_UNUSED(Tcl_Interp *),
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
/*
* We only handle [self] and [self object] (which is the same operation).
* These are the only very common operations on [self] for which
* bytecoding is at all reasonable.
*/
|
| ︙ | ︙ |
Changes to generic/tclCompCmdsSZ.c.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 | #include "tclCompile.h" #include "tclStringTrim.h" /* * Prototypes for procedures defined later in this file: */ | | | | < < | < < | | < | | | | 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 | #include "tclCompile.h" #include "tclStringTrim.h" /* * Prototypes for procedures defined later in this file: */ static AuxDataDupProc DupJumptableInfo; static AuxDataFreeProc FreeJumptableInfo; static AuxDataPrintProc PrintJumptableInfo; static AuxDataPrintProc DisassembleJumptableInfo; static int CompileAssociativeBinaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, const char *identity, int instruction, CompileEnv *envPtr); static int CompileComparisonOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, int instruction, CompileEnv *envPtr); static int CompileStrictlyBinaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, int instruction, CompileEnv *envPtr); static int CompileUnaryOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, int instruction, CompileEnv *envPtr); static void IssueSwitchChainedTests(Tcl_Interp *interp, CompileEnv *envPtr, int mode, int noCase, int numWords, Tcl_Token **bodyToken, int *bodyLines, int **bodyNext); static void IssueSwitchJumpTable(Tcl_Interp *interp, CompileEnv *envPtr, int numWords, Tcl_Token **bodyToken, int *bodyLines, int **bodyContLines); static int IssueTryClausesInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, int numHandlers, int *matchCodes, Tcl_Obj **matchClauses, int *resultVarIndices, int *optionVarIndices, Tcl_Token **handlerTokens); static int IssueTryClausesFinallyInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, |
| ︙ | ︙ | |||
127 128 129 130 131 132 133 |
*/
int
TclCompileSetCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 |
*/
int
TclCompileSetCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr, *valueTokenPtr;
int isAssignment, isScalar, localIndex, numWords;
numWords = parsePtr->numWords;
if ((numWords != 2) && (numWords != 3)) {
return TCL_ERROR;
}
isAssignment = (numWords == 3);
|
| ︙ | ︙ | |||
221 222 223 224 225 226 227 |
*/
int
TclCompileStringCatCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 |
*/
int
TclCompileStringCatCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
int i, numWords = parsePtr->numWords, numArgs;
Tcl_Token *wordTokenPtr;
Tcl_Obj *obj, *folded;
/* Trivial case, no arg */
if (numWords<2) {
PushStringLiteral(envPtr, "");
return TCL_OK;
}
|
| ︙ | ︙ | |||
255 256 257 258 259 260 261 |
Tcl_DecrRefCount(obj);
} else {
folded = obj;
}
} else {
Tcl_DecrRefCount(obj);
if (folded) {
| | | | < | 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 |
Tcl_DecrRefCount(obj);
} else {
folded = obj;
}
} else {
Tcl_DecrRefCount(obj);
if (folded) {
int len;
const char *bytes = TclGetStringFromObj(folded, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(folded);
folded = NULL;
numArgs ++;
}
CompileWord(envPtr, wordTokenPtr, interp, i);
numArgs ++;
if (numArgs >= 254) { /* 254 to take care of the possible +1 of "folded" above */
TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr);
numArgs = 1; /* concat pushes 1 obj, the result */
}
}
wordTokenPtr = TokenAfter(wordTokenPtr);
}
if (folded) {
int len;
const char *bytes = TclGetStringFromObj(folded, &len);
PushLiteral(envPtr, bytes, len);
Tcl_DecrRefCount(folded);
folded = NULL;
numArgs ++;
}
if (numArgs > 1) {
TclEmitInstInt1(INST_STR_CONCAT1, numArgs, envPtr);
}
return TCL_OK;
}
int
TclCompileStringCmpCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
/*
* We don't support any flags; the bytecode isn't that sophisticated.
|
| ︙ | ︙ | |||
325 326 327 328 329 330 331 |
}
int
TclCompileStringEqualCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 |
}
int
TclCompileStringEqualCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
/*
* We don't support any flags; the bytecode isn't that sophisticated.
|
| ︙ | ︙ | |||
357 358 359 360 361 362 363 |
}
int
TclCompileStringFirstCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 |
}
int
TclCompileStringFirstCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
/*
* We don't support any flags; the bytecode isn't that sophisticated.
|
| ︙ | ︙ | |||
389 390 391 392 393 394 395 |
}
int
TclCompileStringLastCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 |
}
int
TclCompileStringLastCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
/*
* We don't support any flags; the bytecode isn't that sophisticated.
|
| ︙ | ︙ | |||
421 422 423 424 425 426 427 |
}
int
TclCompileStringIndexCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 |
}
int
TclCompileStringIndexCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
if (parsePtr->numWords != 3) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
449 450 451 452 453 454 455 |
}
int
TclCompileStringInsertCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < < > | 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 |
}
int
TclCompileStringInsertCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int idx;
if (parsePtr->numWords != 4) {
return TCL_ERROR;
}
/* Compute and push the string in which to insert */
|
| ︙ | ︙ | |||
690 691 692 693 694 695 696 697 698 699 700 701 702 703 |
OP( POP);
PUSH( "1");
}
FIXJUMP1( over);
OP( LNOT);
return TCL_OK;
}
case STR_IS_DOUBLE: {
int satisfied, isEmpty;
if (allowEmpty) {
OP( DUP);
PUSH( "");
| > | 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 |
OP( POP);
PUSH( "1");
}
FIXJUMP1( over);
OP( LNOT);
return TCL_OK;
}
break;
case STR_IS_DOUBLE: {
int satisfied, isEmpty;
if (allowEmpty) {
OP( DUP);
PUSH( "");
|
| ︙ | ︙ | |||
799 800 801 802 803 804 805 |
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
| < | | 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 |
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
int i, length, exactMatch = 0, nocase = 0;
const char *str;
if (parsePtr->numWords < 3 || parsePtr->numWords > 4) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
|
| ︙ | ︙ | |||
875 876 877 878 879 880 881 |
}
int
TclCompileStringLenCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | | | 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 |
}
int
TclCompileStringLenCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
Tcl_Obj *objPtr;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
TclNewObj(objPtr);
if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) {
/*
* Here someone is asking for the length of a static string (or
* something with backslashes). Just push the actual character (not
* byte) length.
*/
char buf[TCL_INTEGER_SPACE];
int len = Tcl_GetCharLength(objPtr);
len = sprintf(buf, "%d", len);
PushLiteral(envPtr, buf, len);
} else {
SetLineInformation(1);
CompileTokens(envPtr, tokenPtr, interp);
TclEmitOpcode(INST_STR_LEN, envPtr);
}
TclDecrRefCount(objPtr);
|
| ︙ | ︙ | |||
922 923 924 925 926 927 928 |
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *mapTokenPtr, *stringTokenPtr;
Tcl_Obj *mapObj, **objv;
| | < | 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 |
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *mapTokenPtr, *stringTokenPtr;
Tcl_Obj *mapObj, **objv;
const char *bytes;
int len;
/*
* We only handle the case:
*
* string map {foo bar} $thing
*
* That is, a literal two-element list (doesn't need to be brace-quoted,
|
| ︙ | ︙ | |||
960 961 962 963 964 965 966 |
/*
* Now issue the opcodes. Note that in the case that we know that the
* first word is an empty word, we don't issue the map at all. That is the
* correct semantics for mapping.
*/
| | | | | | | < | 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 |
/*
* Now issue the opcodes. Note that in the case that we know that the
* first word is an empty word, we don't issue the map at all. That is the
* correct semantics for mapping.
*/
bytes = TclGetStringFromObj(objv[0], &len);
if (len == 0) {
CompileWord(envPtr, stringTokenPtr, interp, 2);
} else {
PushLiteral(envPtr, bytes, len);
bytes = TclGetStringFromObj(objv[1], &len);
PushLiteral(envPtr, bytes, len);
CompileWord(envPtr, stringTokenPtr, interp, 2);
OP(STR_MAP);
}
Tcl_DecrRefCount(mapObj);
return TCL_OK;
}
int
TclCompileStringRangeCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *stringTokenPtr, *fromTokenPtr, *toTokenPtr;
int idx1, idx2;
if (parsePtr->numWords != 4) {
|
| ︙ | ︙ | |||
1055 1056 1057 1058 1059 1060 1061 |
}
int
TclCompileStringReplaceCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
| | < < > | 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 |
}
int
TclCompileStringReplaceCmd(
Tcl_Interp *interp, /* Tcl interpreter for context. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the
* command. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr, *valueTokenPtr;
int first, last;
if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
return TCL_ERROR;
}
/* Bytecode to compute/push string argument being replaced */
|
| ︙ | ︙ | |||
1254 1255 1256 1257 1258 1259 1260 |
}
int
TclCompileStringTrimLCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 |
}
int
TclCompileStringTrimLCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
1282 1283 1284 1285 1286 1287 1288 |
}
int
TclCompileStringTrimRCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 |
}
int
TclCompileStringTrimRCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
1310 1311 1312 1313 1314 1315 1316 |
}
int
TclCompileStringTrimCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 |
}
int
TclCompileStringTrimCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
1431 1432 1433 1434 1435 1436 1437 |
{"lower", Tcl_UniCharIsLower},
{"print", Tcl_UniCharIsPrint},
{"punct", Tcl_UniCharIsPunct},
{"space", Tcl_UniCharIsSpace},
{"upper", Tcl_UniCharIsUpper},
{"word", Tcl_UniCharIsWordChar},
{"xdigit", UniCharIsHexDigit},
| | | 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 |
{"lower", Tcl_UniCharIsLower},
{"print", Tcl_UniCharIsPrint},
{"punct", Tcl_UniCharIsPunct},
{"space", Tcl_UniCharIsSpace},
{"upper", Tcl_UniCharIsUpper},
{"word", Tcl_UniCharIsWordChar},
{"xdigit", UniCharIsHexDigit},
{"", NULL}
};
/*
*----------------------------------------------------------------------
*
* TclCompileSubstCmd --
*
|
| ︙ | ︙ | |||
1459 1460 1461 1462 1463 1464 1465 |
*/
int
TclCompileSubstCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | | 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 |
*/
int
TclCompileSubstCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
int numArgs = parsePtr->numWords - 1;
int numOpts = numArgs - 1;
int objc, flags = TCL_SUBST_ALL;
Tcl_Obj **objv/*, *toSubst = NULL*/;
Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr);
int code = TCL_ERROR;
if (numArgs == 0) {
return TCL_ERROR;
}
objv = (Tcl_Obj **)TclStackAlloc(interp, /*numArgs*/ numOpts * sizeof(Tcl_Obj *));
for (objc = 0; objc < /*numArgs*/ numOpts; objc++) {
objv[objc] = Tcl_NewObj();
Tcl_IncrRefCount(objv[objc]);
if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) {
objc++;
goto cleanup;
|
| ︙ | ︙ | |||
1525 1526 1527 1528 1529 1530 1531 |
return TCL_OK;
}
void
TclSubstCompile(
Tcl_Interp *interp,
const char *bytes,
| | | 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 |
return TCL_OK;
}
void
TclSubstCompile(
Tcl_Interp *interp,
const char *bytes,
int numBytes,
int flags,
int line,
CompileEnv *envPtr)
{
Tcl_Token *endTokenPtr, *tokenPtr;
int breakOffset = 0, count = 0, bline = line;
Tcl_Parse parse;
|
| ︙ | ︙ | |||
1556 1557 1558 1559 1560 1561 1562 |
if (tokenPtr->type != TCL_TOKEN_TEXT && tokenPtr->type != TCL_TOKEN_BS) {
PUSH("");
count++;
}
for (endTokenPtr = tokenPtr + parse.numTokens;
tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) {
| < | | 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 |
if (tokenPtr->type != TCL_TOKEN_TEXT && tokenPtr->type != TCL_TOKEN_BS) {
PUSH("");
count++;
}
for (endTokenPtr = tokenPtr + parse.numTokens;
tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) {
int length, literal, catchRange, breakJump;
char buf[4] = "";
JumpFixup startFixup, okFixup, returnFixup, breakFixup;
JumpFixup continueFixup, otherFixup, endFixup;
switch (tokenPtr->type) {
case TCL_TOKEN_TEXT:
literal = TclRegisterLiteral(envPtr,
|
| ︙ | ︙ | |||
1588 1589 1590 1591 1592 1593 1594 |
* TCL_OK or TCL_ERROR from the substituted variable read; if so,
* there is no need to generate elaborate exception-management
* code. Note that the first component of TCL_TOKEN_VARIABLE is
* always TCL_TOKEN_TEXT...
*/
if (tokenPtr->numComponents > 1) {
| < | | 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 |
* TCL_OK or TCL_ERROR from the substituted variable read; if so,
* there is no need to generate elaborate exception-management
* code. Note that the first component of TCL_TOKEN_VARIABLE is
* always TCL_TOKEN_TEXT...
*/
if (tokenPtr->numComponents > 1) {
int i, foundCommand = 0;
for (i=2 ; i<=tokenPtr->numComponents ; i++) {
if (tokenPtr[i].type == TCL_TOKEN_COMMAND) {
foundCommand = 1;
break;
}
}
|
| ︙ | ︙ | |||
1628 1629 1630 1631 1632 1633 1634 |
/* Jump to the end (all BREAKs land here) */
breakOffset = CurrentOffset(envPtr);
TclEmitInstInt4(INST_JUMP4, 0, envPtr);
/* Start */
if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) {
| | | | 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 |
/* Jump to the end (all BREAKs land here) */
breakOffset = CurrentOffset(envPtr);
TclEmitInstInt4(INST_JUMP4, 0, envPtr);
/* Start */
if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad start jump distance %d",
(int) (CurrentOffset(envPtr) - startFixup.codeOffset));
}
}
envPtr->line = bline;
catchRange = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr);
OP4( BEGIN_CATCH4, catchRange);
ExceptionRangeStarts(envPtr, catchRange);
|
| ︙ | ︙ | |||
1687 1688 1689 1690 1691 1692 1693 |
/* OTHER */
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &otherFixup);
TclAdjustStackDepth(1, envPtr);
/* BREAK destination */
if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) {
| | | | | | | | | | | | | | 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 |
/* OTHER */
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &otherFixup);
TclAdjustStackDepth(1, envPtr);
/* BREAK destination */
if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d",
(int) (CurrentOffset(envPtr) - breakFixup.codeOffset));
}
OP( POP);
OP( POP);
breakJump = CurrentOffset(envPtr) - breakOffset;
if (breakJump > 127) {
OP4(JUMP4, -breakJump);
} else {
OP1(JUMP1, -breakJump);
}
TclAdjustStackDepth(2, envPtr);
/* CONTINUE destination */
if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d",
(int) (CurrentOffset(envPtr) - continueFixup.codeOffset));
}
OP( POP);
OP( POP);
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup);
TclAdjustStackDepth(2, envPtr);
/* RETURN + other destination */
if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad return jump distance %d",
(int) (CurrentOffset(envPtr) - returnFixup.codeOffset));
}
if (TclFixupForwardJumpToHere(envPtr, &otherFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad other jump distance %d",
(int) (CurrentOffset(envPtr) - otherFixup.codeOffset));
}
/*
* Pull the result to top of stack, discard options dict.
*/
OP4( REVERSE, 2);
OP( POP);
/* OK destination */
if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %d",
(int) (CurrentOffset(envPtr) - okFixup.codeOffset));
}
if (count > 1) {
OP1(STR_CONCAT1, count);
count = 1;
}
/* CONTINUE jump to here */
if (TclFixupForwardJumpToHere(envPtr, &endFixup, 127)) {
Tcl_Panic("TclCompileSubstCmd: bad end jump distance %d",
(int) (CurrentOffset(envPtr) - endFixup.codeOffset));
}
bline = envPtr->line;
}
while (count > 255) {
OP1( STR_CONCAT1, 255);
count -= 254;
|
| ︙ | ︙ | |||
1794 1795 1796 1797 1798 1799 1800 |
*/
int
TclCompileSwitchCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 |
*/
int
TclCompileSwitchCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr; /* Pointer to tokens in command. */
int numWords; /* Number of words in command. */
Tcl_Token *valueTokenPtr; /* Token for the value to switch on. */
enum {Switch_Exact, Switch_Glob, Switch_Regexp} mode;
/* What kind of switch are we doing? */
Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */
Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */
int *bodyLines; /* Array of line numbers for body list
* items. */
int **bodyContLines; /* Array of continuation line info. */
int noCase; /* Has the -nocase flag been given? */
int foundMode = 0; /* Have we seen a mode flag yet? */
int i, valueIndex;
int result = TCL_ERROR;
int *clNext = envPtr->clNext;
/*
* Only handle the following versions:
* switch ?--? word {pattern body ...}
* switch -exact ?--? word {pattern body ...}
* switch -glob ?--? word {pattern body ...}
|
| ︙ | ︙ | |||
1862 1863 1864 1865 1866 1867 1868 |
* way to statically avoid the problems you get from strings-to-be-matched
* that start with a - (the interpreted code falls apart if it encounters
* them, so we punt if we *might* encounter them as that is the easiest
* way of emulating the behaviour).
*/
for (; numWords>=3 ; tokenPtr=TokenAfter(tokenPtr),numWords--) {
| | | | 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 |
* way to statically avoid the problems you get from strings-to-be-matched
* that start with a - (the interpreted code falls apart if it encounters
* them, so we punt if we *might* encounter them as that is the easiest
* way of emulating the behaviour).
*/
for (; numWords>=3 ; tokenPtr=TokenAfter(tokenPtr),numWords--) {
unsigned size = tokenPtr[1].size;
const char *chrs = tokenPtr[1].start;
/*
* We only process literal options, and we assume that -e, -g and -n
* are unique prefixes of -exact, -glob and -nocase respectively (true
* at time of writing). Note that -exact and -glob may only be given
* at most once or we bail out (error case).
*/
|
| ︙ | ︙ | |||
1953 1954 1955 1956 1957 1958 1959 |
* copies of the string from the input token for the generated tokens (it
* causes a crash during exception handling). When multiple tokens are
* available at this point, this is pretty easy.
*/
if (numWords == 1) {
const char *bytes;
| | | | | | | 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 |
* copies of the string from the input token for the generated tokens (it
* causes a crash during exception handling). When multiple tokens are
* available at this point, this is pretty easy.
*/
if (numWords == 1) {
const char *bytes;
int maxLen, numBytes;
int bline; /* TIP #280: line of the pattern/action list,
* and start of list for when tracking the
* location. This list comes immediately after
* the value we switch on. */
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
return TCL_ERROR;
}
bytes = tokenPtr[1].start;
numBytes = tokenPtr[1].size;
/* Allocate enough space to work in. */
maxLen = TclMaxListLength(bytes, numBytes, NULL);
if (maxLen < 2) {
return TCL_ERROR;
}
bodyTokenArray = (Tcl_Token *)ckalloc(sizeof(Tcl_Token) * maxLen);
bodyToken = (Tcl_Token **)ckalloc(sizeof(Tcl_Token *) * maxLen);
bodyLines = (int *)ckalloc(sizeof(int) * maxLen);
bodyContLines = (int **)ckalloc(sizeof(int*) * maxLen);
bline = mapPtr->loc[eclIndex].line[valueIndex+1];
numWords = 0;
while (numBytes > 0) {
const char *prevBytes = bytes;
int literal;
|
| ︙ | ︙ | |||
2011 2012 2013 2014 2015 2016 2017 |
TclAdvanceContinuations(&bline, &clNext, bytes - envPtr->source);
numBytes -= (bytes - prevBytes);
numWords++;
}
if (numWords % 2) {
abort:
| | | | | | | | | 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 |
TclAdvanceContinuations(&bline, &clNext, bytes - envPtr->source);
numBytes -= (bytes - prevBytes);
numWords++;
}
if (numWords % 2) {
abort:
ckfree(bodyToken);
ckfree(bodyTokenArray);
ckfree(bodyLines);
ckfree(bodyContLines);
return TCL_ERROR;
}
} else if (numWords % 2 || numWords == 0) {
/*
* Odd number of words (>1) available, or no words at all available.
* Both are error cases, so punt and let the interpreted-version
* generate the error message. Note that the second case probably
* should get caught earlier, but it's easy to check here again anyway
* because it'd cause a nasty crash otherwise.
*/
return TCL_ERROR;
} else {
/*
* Multi-word definition of patterns & actions.
*/
bodyToken = (Tcl_Token **)ckalloc(sizeof(Tcl_Token *) * numWords);
bodyLines = (int *)ckalloc(sizeof(int) * numWords);
bodyContLines = (int **)ckalloc(sizeof(int*) * numWords);
bodyTokenArray = NULL;
for (i=0 ; i<numWords ; i++) {
/*
* We only handle the very simplest case. Anything more complex is
* a good reason to go to the interpreted case anyway due to
* traces, etc.
*/
|
| ︙ | ︙ | |||
2080 2081 2082 2083 2084 2085 2086 |
* but it handles the most common case well enough.
*/
/* Both methods push the value to match against onto the stack. */
CompileWord(envPtr, valueTokenPtr, interp, valueIndex);
if (mode == Switch_Exact) {
| | | | | | | | 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 |
* but it handles the most common case well enough.
*/
/* Both methods push the value to match against onto the stack. */
CompileWord(envPtr, valueTokenPtr, interp, valueIndex);
if (mode == Switch_Exact) {
IssueSwitchJumpTable(interp, envPtr, numWords, bodyToken,
bodyLines, bodyContLines);
} else {
IssueSwitchChainedTests(interp, envPtr, mode, noCase,
numWords, bodyToken, bodyLines, bodyContLines);
}
result = TCL_OK;
/*
* Clean up all our temporary space and return.
*/
freeTemporaries:
ckfree(bodyToken);
ckfree(bodyLines);
ckfree(bodyContLines);
if (bodyTokenArray != NULL) {
ckfree(bodyTokenArray);
}
return result;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2124 2125 2126 2127 2128 2129 2130 |
static void
IssueSwitchChainedTests(
Tcl_Interp *interp, /* Context for compiling script bodies. */
CompileEnv *envPtr, /* Holds resulting instructions. */
int mode, /* Exact, Glob or Regexp */
int noCase, /* Case-insensitivity flag. */
| < | 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 |
static void
IssueSwitchChainedTests(
Tcl_Interp *interp, /* Context for compiling script bodies. */
CompileEnv *envPtr, /* Holds resulting instructions. */
int mode, /* Exact, Glob or Regexp */
int noCase, /* Case-insensitivity flag. */
int numBodyTokens, /* Number of tokens describing things the
* switch can match against and bodies to
* execute when the match succeeds. */
Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */
int *bodyLines, /* Array of line numbers for body list
* items. */
int **bodyContLines) /* Array of continuation line info. */
|
| ︙ | ︙ | |||
2154 2155 2156 2157 2158 2159 2160 |
/*
* Generate a test for each arm.
*/
contFixIndex = -1;
contFixCount = 0;
| | | | 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 |
/*
* Generate a test for each arm.
*/
contFixIndex = -1;
contFixCount = 0;
fixupArray = (JumpFixup *)TclStackAlloc(interp, sizeof(JumpFixup) * numBodyTokens);
fixupTargetArray = (unsigned int *)TclStackAlloc(interp, sizeof(int) * numBodyTokens);
memset(fixupTargetArray, 0, numBodyTokens * sizeof(int));
fixupCount = 0;
foundDefault = 0;
for (i=0 ; i<numBodyTokens ; i+=2) {
nextArmFixupIndex = -1;
if (i!=numBodyTokens-2 || bodyToken[numBodyTokens-2]->size != 7 ||
memcmp(bodyToken[numBodyTokens-2]->start, "default", 7)) {
|
| ︙ | ︙ | |||
2373 2374 2375 2376 2377 2378 2379 |
*----------------------------------------------------------------------
*/
static void
IssueSwitchJumpTable(
Tcl_Interp *interp, /* Context for compiling script bodies. */
CompileEnv *envPtr, /* Holds resulting instructions. */
| < | 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 |
*----------------------------------------------------------------------
*/
static void
IssueSwitchJumpTable(
Tcl_Interp *interp, /* Context for compiling script bodies. */
CompileEnv *envPtr, /* Holds resulting instructions. */
int numBodyTokens, /* Number of tokens describing things the
* switch can match against and bodies to
* execute when the match succeeds. */
Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */
int *bodyLines, /* Array of line numbers for body list
* items. */
int **bodyContLines) /* Array of continuation line info. */
|
| ︙ | ︙ | |||
2398 2399 2400 2401 2402 2403 2404 |
* (relative to the INST_JUMP_TABLE instruction) to jump to. The jump
* table itself is independent of any invokation of the bytecode, and as
* such is stored in an auxData block.
*
* Start by allocating the jump table itself, plus some workspace.
*/
| | | | 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 |
* (relative to the INST_JUMP_TABLE instruction) to jump to. The jump
* table itself is independent of any invokation of the bytecode, and as
* such is stored in an auxData block.
*
* Start by allocating the jump table itself, plus some workspace.
*/
jtPtr = (JumptableInfo *)ckalloc(sizeof(JumptableInfo));
Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr);
finalFixups = (int *)TclStackAlloc(interp, sizeof(int) * (numBodyTokens/2));
foundDefault = 0;
mustGenerate = 1;
/*
* Next, issue the instruction to do the jump, together with what we want
* to do if things do not work out (jump to either the default clause or
* the "default" default, which just sets the result to empty). Note that
|
| ︙ | ︙ | |||
2569 2570 2571 2572 2573 2574 2575 |
*----------------------------------------------------------------------
*/
static ClientData
DupJumptableInfo(
ClientData clientData)
{
| | | | | | | | | | | | | 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 |
*----------------------------------------------------------------------
*/
static ClientData
DupJumptableInfo(
ClientData clientData)
{
JumptableInfo *jtPtr = (JumptableInfo *)clientData;
JumptableInfo *newJtPtr = (JumptableInfo *)ckalloc(sizeof(JumptableInfo));
Tcl_HashEntry *hPtr, *newHPtr;
Tcl_HashSearch search;
int isNew;
Tcl_InitHashTable(&newJtPtr->hashTable, TCL_STRING_KEYS);
hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
while (hPtr != NULL) {
newHPtr = Tcl_CreateHashEntry(&newJtPtr->hashTable,
Tcl_GetHashKey(&jtPtr->hashTable, hPtr), &isNew);
Tcl_SetHashValue(newHPtr, Tcl_GetHashValue(hPtr));
}
return newJtPtr;
}
static void
FreeJumptableInfo(
ClientData clientData)
{
JumptableInfo *jtPtr = (JumptableInfo *)clientData;
Tcl_DeleteHashTable(&jtPtr->hashTable);
ckfree(jtPtr);
}
static void
PrintJumptableInfo(
ClientData clientData,
Tcl_Obj *appendObj,
TCL_UNUSED(ByteCode *),
unsigned int pcOffset)
{
JumptableInfo *jtPtr = (JumptableInfo *)clientData;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
const char *keyPtr;
int offset, i = 0;
hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search);
for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) {
keyPtr = (const char *)Tcl_GetHashKey(&jtPtr->hashTable, hPtr);
offset = PTR2INT(Tcl_GetHashValue(hPtr));
if (i++) {
Tcl_AppendToObj(appendObj, ", ", -1);
if (i%4==0) {
Tcl_AppendToObj(appendObj, "\n\t\t", -1);
}
}
Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d",
keyPtr, pcOffset + offset);
}
}
static void
DisassembleJumptableInfo(
ClientData clientData,
Tcl_Obj *dictObj,
TCL_UNUSED(ByteCode *),
TCL_UNUSED(unsigned int))
{
JumptableInfo *jtPtr = (JumptableInfo *)clientData;
Tcl_Obj *mapping = Tcl_NewObj();
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
const char *keyPtr;
int offset;
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_NewIntObj(offset));
}
Tcl_DictObjPut(NULL, dictObj, Tcl_NewStringObj("mapping", -1), mapping);
}
|
| ︙ | ︙ | |||
2671 2672 2673 2674 2675 2676 2677 |
*/
int
TclCompileTailcallCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 |
*/
int
TclCompileTailcallCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int i;
if (parsePtr->numWords < 2 || parsePtr->numWords > 256
|
| ︙ | ︙ | |||
2718 2719 2720 2721 2722 2723 2724 |
*/
int
TclCompileThrowCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 |
*/
int
TclCompileThrowCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
int numWords = parsePtr->numWords;
Tcl_Token *codeToken, *msgToken;
Tcl_Obj *objPtr;
int codeKnown, codeIsList, codeIsValid, len;
|
| ︙ | ︙ | |||
2822 2823 2824 2825 2826 2827 2828 |
*/
int
TclCompileTryCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 |
*/
int
TclCompileTryCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
int numWords = parsePtr->numWords, numHandlers, result = TCL_ERROR;
Tcl_Token *bodyToken, *finallyToken, *tokenPtr;
Tcl_Token **handlerTokens = NULL;
Tcl_Obj **matchClauses = NULL;
int *matchCodes=NULL, *resultVarIndices=NULL, *optionVarIndices=NULL;
|
| ︙ | ︙ | |||
2859 2860 2861 2862 2863 2864 2865 |
/*
* Extract information about what handlers there are.
*/
numHandlers = numWords >> 2;
numWords -= numHandlers * 4;
if (numHandlers > 0) {
| | | | | | | 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 |
/*
* Extract information about what handlers there are.
*/
numHandlers = numWords >> 2;
numWords -= numHandlers * 4;
if (numHandlers > 0) {
handlerTokens = (Tcl_Token**)TclStackAlloc(interp, sizeof(Tcl_Token*)*numHandlers);
matchClauses = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * numHandlers);
memset(matchClauses, 0, sizeof(Tcl_Obj *) * numHandlers);
matchCodes = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
resultVarIndices = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
optionVarIndices = (int *)TclStackAlloc(interp, sizeof(int) * numHandlers);
for (i=0 ; i<numHandlers ; i++) {
Tcl_Obj *tmpObj, **objv;
int objc;
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
goto failedToCompile;
|
| ︙ | ︙ | |||
2933 2934 2935 2936 2937 2938 2939 |
}
if (Tcl_ListObjGetElements(NULL, tmpObj, &objc, &objv) != TCL_OK
|| (objc > 2)) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
if (objc > 0) {
| | | | 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 |
}
if (Tcl_ListObjGetElements(NULL, tmpObj, &objc, &objv) != TCL_OK
|| (objc > 2)) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
if (objc > 0) {
int len;
const char *varname = TclGetStringFromObj(objv[0], &len);
resultVarIndices[i] = LocalScalar(varname, len, envPtr);
if (resultVarIndices[i] < 0) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
} else {
resultVarIndices[i] = -1;
}
if (objc == 2) {
int len;
const char *varname = TclGetStringFromObj(objv[1], &len);
optionVarIndices[i] = LocalScalar(varname, len, envPtr);
if (optionVarIndices[i] < 0) {
TclDecrRefCount(tmpObj);
goto failedToCompile;
}
|
| ︙ | ︙ | |||
3064 3065 3066 3067 3068 3069 3070 |
int *resultVars,
int *optionVars,
Tcl_Token **handlerTokens)
{
DefineLineInformation; /* TIP #280 */
int range, resultVar, optionsVar;
int i, j, len, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0;
| < | 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 |
int *resultVars,
int *optionVars,
Tcl_Token **handlerTokens)
{
DefineLineInformation; /* TIP #280 */
int range, resultVar, optionsVar;
int i, j, len, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0;
int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
int *noError;
char buf[TCL_INTEGER_SPACE];
resultVar = AnonymousLocal(envPtr);
optionsVar = AnonymousLocal(envPtr);
if (resultVar < 0 || optionsVar < 0) {
|
| ︙ | ︙ | |||
3126 3127 3128 3129 3130 3131 3132 |
/*
* Now we handle all the registered 'on' and 'trap' handlers in order.
* For us to be here, there must be at least one handler.
*
* Slight overallocation, but reduces size of this function.
*/
| | | | | 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 |
/*
* Now we handle all the registered 'on' and 'trap' handlers in order.
* For us to be here, there must be at least one handler.
*
* Slight overallocation, but reduces size of this function.
*/
addrsToFix = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers);
forwardsToFix = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers);
noError = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers);
for (i=0 ; i<numHandlers ; i++) {
noError[i] = -1;
sprintf(buf, "%d", matchCodes[i]);
OP( DUP);
PushLiteral(envPtr, buf, strlen(buf));
OP( EQ);
|
| ︙ | ︙ | |||
3150 3151 3152 3153 3154 3155 3156 | */ LOAD( optionsVar); PUSH( "-errorcode"); OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); | | | | | 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 |
*/
LOAD( optionsVar);
PUSH( "-errorcode");
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
p = TclGetStringFromObj(matchClauses[i], &len);
PushLiteral(envPtr, p, len);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
} else {
notECJumpSource = -1;
}
OP( POP);
/*
* There is no finally clause, so we can avoid wrapping a catch
* context around the handler. That simplifies what instructions need
* to be issued a lot since we can let errors just fall through.
|
| ︙ | ︙ | |||
3278 3279 3280 3281 3282 3283 3284 |
Tcl_Token *finallyToken) /* Not NULL */
{
DefineLineInformation; /* TIP #280 */
int range, resultVar, optionsVar, i, j, len, forwardsNeedFixing = 0;
int trapZero = 0, afterBody = 0, finalOK, finalError, noFinalError;
int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
char buf[TCL_INTEGER_SPACE];
| < | 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 |
Tcl_Token *finallyToken) /* Not NULL */
{
DefineLineInformation; /* TIP #280 */
int range, resultVar, optionsVar, i, j, len, forwardsNeedFixing = 0;
int trapZero = 0, afterBody = 0, finalOK, finalError, noFinalError;
int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource;
char buf[TCL_INTEGER_SPACE];
resultVar = AnonymousLocal(envPtr);
optionsVar = AnonymousLocal(envPtr);
if (resultVar < 0 || optionsVar < 0) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
3338 3339 3340 3341 3342 3343 3344 |
/*
* Now we handle all the registered 'on' and 'trap' handlers in order.
*
* Slight overallocation, but reduces size of this function.
*/
| | | | 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 |
/*
* Now we handle all the registered 'on' and 'trap' handlers in order.
*
* Slight overallocation, but reduces size of this function.
*/
addrsToFix = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers);
forwardsToFix = (int *)TclStackAlloc(interp, sizeof(int)*numHandlers);
for (i=0 ; i<numHandlers ; i++) {
int noTrapError, trapError;
const char *p;
sprintf(buf, "%d", matchCodes[i]);
OP( DUP);
|
| ︙ | ︙ | |||
3362 3363 3364 3365 3366 3367 3368 | */ LOAD( optionsVar); PUSH( "-errorcode"); OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); | | | | | 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 |
*/
LOAD( optionsVar);
PUSH( "-errorcode");
OP4( DICT_GET, 1);
TclAdjustStackDepth(-1, envPtr);
OP44( LIST_RANGE_IMM, 0, len-1);
p = TclGetStringFromObj(matchClauses[i], &len);
PushLiteral(envPtr, p, len);
OP( STR_EQ);
JUMP4( JUMP_FALSE, notECJumpSource);
} else {
notECJumpSource = -1;
}
OP( POP);
/*
* There is a finally clause, so we need a fairly complex sequence of
* instructions to deal with an on/trap handler because we must call
* the finally handler *and* we need to substitute the result from a
|
| ︙ | ︙ | |||
3634 3635 3636 3637 3638 3639 3640 |
*/
int
TclCompileUnsetCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 |
*/
int
TclCompileUnsetCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *varTokenPtr;
int isScalar, localIndex, flags = 1, i, varCount = 0, haveFlags = 0;
/* TODO: Consider support for compiling expanded args. */
/*
* Verify that all words - except the first non-option one - are known at
* compile time so that we can handle them without needing to do a nasty
* push/rotate. [Bug 3970f54c4e]
|
| ︙ | ︙ | |||
3688 3689 3690 3691 3692 3693 3694 |
continue;
}
}
return TCL_ERROR;
}
if (varCount == 0) {
const char *bytes;
| | | 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 |
continue;
}
}
return TCL_ERROR;
}
if (varCount == 0) {
const char *bytes;
int len;
bytes = TclGetStringFromObj(leadingWord, &len);
if (i == 1 && len == 11 && !strncmp("-nocomplain", bytes, 11)) {
flags = 0;
haveFlags++;
} else if (i == (2 - flags) && len == 2 && !strncmp("--", bytes, 2)) {
haveFlags++;
|
| ︙ | ︙ | |||
3772 3773 3774 3775 3776 3777 3778 |
*/
int
TclCompileWhileCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < > < | 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 |
*/
int
TclCompileWhileCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *testTokenPtr, *bodyTokenPtr;
JumpFixup jumpEvalCondFixup;
int testCodeOffset, bodyCodeOffset, jumpDist, range, code, boolVal;
int loopMayEnd = 1; /* This is set to 0 if it is recognized as an
* infinite loop. */
Tcl_Obj *boolObj;
if (parsePtr->numWords != 3) {
return TCL_ERROR;
}
/*
* If the test expression requires substitutions, don't compile the while
|
| ︙ | ︙ | |||
3950 3951 3952 3953 3954 3955 3956 |
*/
int
TclCompileYieldCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 |
*/
int
TclCompileYieldCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
if (parsePtr->numWords < 1 || parsePtr->numWords > 2) {
return TCL_ERROR;
}
if (parsePtr->numWords == 1) {
|
| ︙ | ︙ | |||
3993 3994 3995 3996 3997 3998 3999 |
*/
int
TclCompileYieldToCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 |
*/
int
TclCompileYieldToCmd(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
int i;
if (parsePtr->numWords < 2) {
|
| ︙ | ︙ | |||
4040 4041 4042 4043 4044 4045 4046 |
static int
CompileUnaryOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
int instruction,
CompileEnv *envPtr)
{
| < > | 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 |
static int
CompileUnaryOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
int instruction,
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
if (parsePtr->numWords != 2) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
TclEmitOpcode(instruction, envPtr);
|
| ︙ | ︙ | |||
4082 4083 4084 4085 4086 4087 4088 |
CompileAssociativeBinaryOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
const char *identity,
int instruction,
CompileEnv *envPtr)
{
| < > | 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 |
CompileAssociativeBinaryOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
const char *identity,
int instruction,
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int words;
/* TODO: Consider support for compiling expanded args. */
for (words=1 ; words<parsePtr->numWords ; words++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, words);
}
|
| ︙ | ︙ | |||
4167 4168 4169 4170 4171 4172 4173 |
static int
CompileComparisonOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
int instruction,
CompileEnv *envPtr)
{
| < > | 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 |
static int
CompileComparisonOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
int instruction,
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr;
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords < 3) {
PUSH("1");
} else if (parsePtr->numWords == 3) {
tokenPtr = TokenAfter(parsePtr->tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 1);
|
| ︙ | ︙ | |||
4243 4244 4245 4246 4247 4248 4249 |
*----------------------------------------------------------------------
*/
int
TclCompileInvertOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
| | < | < | < | < | < | < | < | < > > > > < < < < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < < > | 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 |
*----------------------------------------------------------------------
*/
int
TclCompileInvertOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileUnaryOpCmd(interp, parsePtr, INST_BITNOT, envPtr);
}
int
TclCompileNotOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileUnaryOpCmd(interp, parsePtr, INST_LNOT, envPtr);
}
int
TclCompileAddOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_ADD,
envPtr);
}
int
TclCompileMulOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "1", INST_MULT,
envPtr);
}
int
TclCompileAndOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "-1", INST_BITAND,
envPtr);
}
int
TclCompileOrOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITOR,
envPtr);
}
int
TclCompileXorOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileAssociativeBinaryOpCmd(interp, parsePtr, "0", INST_BITXOR,
envPtr);
}
int
TclCompilePowOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int words;
/*
* This one has its own implementation because the ** operator is the only
* one with right associativity.
*/
for (words=1 ; words<parsePtr->numWords ; words++) {
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, words);
}
if (parsePtr->numWords <= 2) {
PUSH("1");
words++;
}
while (--words > 1) {
TclEmitOpcode(INST_EXPON, envPtr);
}
return TCL_OK;
}
int
TclCompileLshiftOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LSHIFT, envPtr);
}
int
TclCompileRshiftOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_RSHIFT, envPtr);
}
int
TclCompileModOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_MOD, envPtr);
}
int
TclCompileNeqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_NEQ, envPtr);
}
int
TclCompileStrneqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_STR_NEQ, envPtr);
}
int
TclCompileInOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_IN, envPtr);
}
int
TclCompileNiOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileStrictlyBinaryOpCmd(interp, parsePtr, INST_LIST_NOT_IN,
envPtr);
}
int
TclCompileLessOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_LT, envPtr);
}
int
TclCompileLeqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_LE, envPtr);
}
int
TclCompileGreaterOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_GT, envPtr);
}
int
TclCompileGeqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_GE, envPtr);
}
int
TclCompileEqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_EQ, envPtr);
}
int
TclCompileStreqOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_STR_EQ, envPtr);
}
int
TclCompileStrLtOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_STR_LT, envPtr);
}
int
TclCompileStrLeOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_STR_LE, envPtr);
}
int
TclCompileStrGtOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_STR_GT, envPtr);
}
int
TclCompileStrGeOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
return CompileComparisonOpCmd(interp, parsePtr, INST_STR_GE, envPtr);
}
int
TclCompileMinusOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int words;
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords == 1) {
/*
* Fallback to direct eval to report syntax error.
*/
|
| ︙ | ︙ | |||
4590 4591 4592 4593 4594 4595 4596 |
return TCL_OK;
}
int
TclCompileDivOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
| | < < > | 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 |
return TCL_OK;
}
int
TclCompileDivOpCmd(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
TCL_UNUSED(Command *),
CompileEnv *envPtr)
{
DefineLineInformation; /* TIP #280 */
Tcl_Token *tokenPtr = parsePtr->tokenPtr;
int words;
/* TODO: Consider support for compiling expanded args. */
if (parsePtr->numWords == 1) {
/*
* Fallback to direct eval to report syntax error.
*/
|
| ︙ | ︙ |
Changes to generic/tclCompExpr.c.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 | * Expression parsing takes place in the routine ParseExpr(). It takes a * string as input, parses that string, and generates a representation of the * expression in the form of a tree of operators, a list of literals, a list * of function names, and an array of Tcl_Token's within a Tcl_Parse struct. * The tree is composed of OpNodes. */ | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
* Expression parsing takes place in the routine ParseExpr(). It takes a
* string as input, parses that string, and generates a representation of the
* expression in the form of a tree of operators, a list of literals, a list
* of function names, and an array of Tcl_Token's within a Tcl_Parse struct.
* The tree is composed of OpNodes.
*/
typedef struct OpNode {
int left; /* "Pointer" to the left operand. */
int right; /* "Pointer" to the right operand. */
union {
int parent; /* "Pointer" to the parent operand. */
int prev; /* "Pointer" joining incomplete tree stack */
} p;
unsigned char lexeme; /* Code that identifies the operator. */
|
| ︙ | ︙ | |||
505 506 507 508 509 510 511 | * Declarations for local functions to this file: */ static void CompileExprTree(Tcl_Interp *interp, OpNode *nodes, int index, Tcl_Obj *const **litObjvPtr, Tcl_Obj *const *funcObjv, Tcl_Token *tokenPtr, CompileEnv *envPtr, int optimize); | | | | | 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 | * Declarations for local functions to this file: */ static void CompileExprTree(Tcl_Interp *interp, OpNode *nodes, int index, Tcl_Obj *const **litObjvPtr, Tcl_Obj *const *funcObjv, Tcl_Token *tokenPtr, CompileEnv *envPtr, int optimize); static void ConvertTreeToTokens(const char *start, int numBytes, OpNode *nodes, Tcl_Token *tokenPtr, Tcl_Parse *parsePtr); static int ExecConstantExprTree(Tcl_Interp *interp, OpNode *nodes, int index, Tcl_Obj * const **litObjvPtr); static int ParseExpr(Tcl_Interp *interp, const char *start, int numBytes, OpNode **opTreePtr, Tcl_Obj *litList, Tcl_Obj *funcList, Tcl_Parse *parsePtr, int parseOnly); static int ParseLexeme(const char *start, int numBytes, unsigned char *lexemePtr, Tcl_Obj **literalPtr); /* *---------------------------------------------------------------------- * * ParseExpr -- * |
| ︙ | ︙ | |||
540 541 542 543 544 545 546 | * last four arguments. If the string cannot be parsed as a valid Tcl * expression, TCL_ERROR is returned, and if interp is non-NULL, an error * message is written to interp. * * Side effects: * Memory will be allocated. If TCL_OK is returned, the caller must clean * up the returned data structures. The (OpNode *) value written to | | | | 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 |
* last four arguments. If the string cannot be parsed as a valid Tcl
* expression, TCL_ERROR is returned, and if interp is non-NULL, an error
* message is written to interp.
*
* Side effects:
* Memory will be allocated. If TCL_OK is returned, the caller must clean
* up the returned data structures. The (OpNode *) value written to
* opTreePtr should be passed to ckfree() and the parsePtr argument
* should be passed to Tcl_FreeParse(). The elements appended to the
* litList and funcList will automatically be freed whenever the refcount
* on those lists indicates they can be freed.
*
*----------------------------------------------------------------------
*/
static int
ParseExpr(
Tcl_Interp *interp, /* Used for error reporting. */
const char *start, /* Start of source string to parse. */
int numBytes, /* Number of bytes in string. */
OpNode **opTreePtr, /* Points to space where a pointer to the
* allocated OpNode tree should go. */
Tcl_Obj *litList, /* List to append literals to. */
Tcl_Obj *funcList, /* List to append function names to. */
Tcl_Parse *parsePtr, /* Structure to fill with tokens representing
* those operands that require run time
* substitutions. */
|
| ︙ | ︙ | |||
575 576 577 578 579 580 581 |
unsigned int nodesAvailable = 64; /* Initial size of the storage array. This
* value establishes a minimum tree memory
* cost of only about 1 kibyte, and is large
* enough for most expressions to parse with
* no need for array growth and
* reallocation. */
unsigned int nodesUsed = 0; /* Number of OpNodes filled. */
| | | 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 |
unsigned int nodesAvailable = 64; /* Initial size of the storage array. This
* value establishes a minimum tree memory
* cost of only about 1 kibyte, and is large
* enough for most expressions to parse with
* no need for array growth and
* reallocation. */
unsigned int nodesUsed = 0; /* Number of OpNodes filled. */
int scanned = 0; /* Capture number of byte scanned by parsing
* routines. */
int lastParsed; /* Stores info about what the lexeme parsed
* the previous pass through the parsing loop
* was. If it was an operator, lastParsed is
* the index of the OpNode for that operator.
* If it was not an operator, lastParsed holds
* an OperandTypes value encoding what we need
|
| ︙ | ︙ | |||
619 620 621 622 623 624 625 |
* message where the error location is
* reported, this "mark" substring is inserted
* into the string being parsed to aid in
* pinpointing the location of the syntax
* error in the expression. */
int insertMark = 0; /* A boolean controlling whether the "mark"
* should be inserted. */
| | | | 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 |
* message where the error location is
* reported, this "mark" substring is inserted
* into the string being parsed to aid in
* pinpointing the location of the syntax
* error in the expression. */
int insertMark = 0; /* A boolean controlling whether the "mark"
* should be inserted. */
const int limit = 25; /* Portions of the error message are
* constructed out of substrings of the
* original expression. In order to keep the
* error message readable, we impose this
* limit on the substring size we extract. */
TclParseInit(interp, start, numBytes, parsePtr);
nodes = (OpNode *)attemptckalloc(nodesAvailable * sizeof(OpNode));
if (nodes == NULL) {
TclNewLiteralStringObj(msg, "not enough memory to parse expression");
errCode = "NOMEM";
goto error;
}
/*
|
| ︙ | ︙ | |||
671 672 673 674 675 676 677 |
if (nodesUsed >= nodesAvailable) {
unsigned int size = nodesUsed * 2;
OpNode *newPtr = NULL;
do {
if (size <= UINT_MAX/sizeof(OpNode)) {
| | | 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 |
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";
|
| ︙ | ︙ | |||
706 707 708 709 710 711 712 |
if ((NODE_TYPE & lexeme) == 0) {
int b;
switch (lexeme) {
case INVALID:
msg = Tcl_ObjPrintf("invalid character \"%.*s\"",
| | | | 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 |
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\"",
scanned, start);
errCode = "PARTOP";
goto error;
case BAREWORD:
/*
* Most barewords in an expression are a syntax error. The
* exceptions are that when a bareword is followed by an open
|
| ︙ | ︙ | |||
740 741 742 743 744 745 746 |
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\"",
| | | | | | 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 |
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,
start, (scanned < limit) ? "" : "...",
(scanned < limit) ? scanned : limit - 3,
start, (scanned < limit) ? "" : "...");
Tcl_AppendPrintfToObj(post, " or \"%.*s%s(...)\" or ...",
(scanned < limit) ? scanned : limit - 3,
start, (scanned < limit) ? "" : "...");
errCode = "BAREWORD";
if (start[0] == '0') {
const char *stop;
TclParseNumber(NULL, NULL, NULL, start, scanned,
&stop, TCL_PARSE_NO_WHITESPACE);
|
| ︙ | ︙ | |||
915 916 917 918 919 920 921 |
errCode = "BADCHAR";
goto error;
}
scanned = tokenPtr->size;
break;
case SCRIPT: {
| | | 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 |
errCode = "BADCHAR";
goto error;
}
scanned = tokenPtr->size;
break;
case SCRIPT: {
Tcl_Parse *nestedPtr = (Tcl_Parse *)
TclStackAlloc(interp, sizeof(Tcl_Parse));
tokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
tokenPtr->type = TCL_TOKEN_COMMAND;
tokenPtr->start = start;
tokenPtr->numComponents = 0;
|
| ︙ | ︙ | |||
1381 1382 1383 1384 1385 1386 1387 |
}
/*
* Free any partial parse tree we've built.
*/
if (nodes != NULL) {
| | | 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 |
}
/*
* Free any partial parse tree we've built.
*/
if (nodes != NULL) {
ckfree(nodes);
}
if (interp == NULL) {
/*
* Nowhere to report an error message, so just free it.
*/
|
| ︙ | ︙ | |||
1410 1411 1412 1413 1414 1415 1416 | * Add a detailed quote from the bad expression, displaying and * sometimes marking the precise location of the syntax error. */ Tcl_AppendPrintfToObj(msg, "\nin expression \"%s%.*s%.*s%s%s%.*s%s\"", ((start - limit) < parsePtr->string) ? "" : "...", ((start - limit) < parsePtr->string) | | | | | 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 | * Add a detailed quote from the bad expression, displaying and * sometimes marking the precise location of the syntax error. */ Tcl_AppendPrintfToObj(msg, "\nin expression \"%s%.*s%.*s%s%s%.*s%s\"", ((start - limit) < parsePtr->string) ? "" : "...", ((start - limit) < parsePtr->string) ? (int) (start - parsePtr->string) : limit - 3, ((start - limit) < parsePtr->string) ? parsePtr->string : start - limit + 3, (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "...", insertMark ? mark : "", (start + scanned + limit > parsePtr->end) ? (int) (parsePtr->end - start) - scanned : limit-3, start + scanned, (start + scanned + limit > parsePtr->end) ? "" : "..."); /* * Next, append any postscript message. */ |
| ︙ | ︙ | |||
1438 1439 1440 1441 1442 1443 1444 | /* * Finally, place context information in the errorInfo. */ numBytes = parsePtr->end - parsePtr->string; Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (parsing expression \"%.*s%s\")", | | | 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 |
/*
* Finally, place context information in the errorInfo.
*/
numBytes = parsePtr->end - parsePtr->string;
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (parsing expression \"%.*s%s\")",
(numBytes < limit) ? numBytes : limit - 3,
parsePtr->string, (numBytes < limit) ? "" : "..."));
if (errCode) {
Tcl_SetErrorCode(interp, "TCL", "PARSE", "EXPR", errCode,
subErrCode, NULL);
}
}
|
| ︙ | ︙ | |||
1475 1476 1477 1478 1479 1480 1481 |
*
*----------------------------------------------------------------------
*/
static void
ConvertTreeToTokens(
const char *start,
| | | 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 |
*
*----------------------------------------------------------------------
*/
static void
ConvertTreeToTokens(
const char *start,
int numBytes,
OpNode *nodes,
Tcl_Token *tokenPtr,
Tcl_Parse *parsePtr)
{
int subExprTokenIdx = 0;
OpNode *nodePtr = nodes;
int next = nodePtr->right;
|
| ︙ | ︙ | |||
1564 1565 1566 1567 1568 1569 1570 | * Single element word. Copy tokens and convert the leading * token to TCL_TOKEN_SUB_EXPR. */ TclGrowParseTokenArray(parsePtr, toCopy); subExprTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; memcpy(subExprTokenPtr, tokenPtr, | | | | 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 |
* Single element word. Copy tokens and convert the leading
* token to TCL_TOKEN_SUB_EXPR.
*/
TclGrowParseTokenArray(parsePtr, toCopy);
subExprTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
memcpy(subExprTokenPtr, tokenPtr,
(size_t) toCopy * sizeof(Tcl_Token));
subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR;
parsePtr->numTokens += toCopy;
} else {
/*
* Multiple element word. Create a TCL_TOKEN_SUB_EXPR token to
* lead, with fields initialized from the leading token, then
* copy entire set of word tokens.
*/
TclGrowParseTokenArray(parsePtr, toCopy+1);
subExprTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
*subExprTokenPtr = *tokenPtr;
subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR;
subExprTokenPtr->numComponents++;
subExprTokenPtr++;
memcpy(subExprTokenPtr, tokenPtr,
(size_t) toCopy * sizeof(Tcl_Token));
parsePtr->numTokens += toCopy + 1;
}
scanned = tokenPtr->start + tokenPtr->size - start;
start += scanned;
numBytes -= scanned;
tokenPtr += toCopy;
|
| ︙ | ︙ | |||
1823 1824 1825 1826 1827 1828 1829 |
*----------------------------------------------------------------------
*/
int
Tcl_ParseExpr(
Tcl_Interp *interp, /* Used for error reporting. */
const char *start, /* Start of source string to parse. */
| | | | | | | > | 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 |
*----------------------------------------------------------------------
*/
int
Tcl_ParseExpr(
Tcl_Interp *interp, /* Used for error reporting. */
const char *start, /* Start of source string to parse. */
int numBytes, /* Number of bytes in string. If < 0, the
* string consists of all bytes up to the
* 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 = Tcl_NewObj(); /* List to hold the literals. */
Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names. */
Tcl_Parse *exprParsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
/* Holds the Tcl_Tokens of substitutions. */
if (numBytes < 0) {
numBytes = (start ? strlen(start) : 0);
}
code = ParseExpr(interp, start, numBytes, &opTree, litList, funcList,
exprParsePtr, 1 /* parseOnly */);
Tcl_DecrRefCount(funcList);
Tcl_DecrRefCount(litList);
TclParseInit(interp, start, numBytes, parsePtr);
if (code == TCL_OK) {
ConvertTreeToTokens(start, numBytes,
opTree, exprParsePtr->tokenPtr, parsePtr);
} else {
parsePtr->term = exprParsePtr->term;
parsePtr->errorType = exprParsePtr->errorType;
}
Tcl_FreeParse(exprParsePtr);
TclStackFree(interp, exprParsePtr);
ckfree(opTree);
return code;
}
/*
*----------------------------------------------------------------------
*
* ParseLexeme --
*
* Parse a single lexeme from the start of a string, scanning no more
* than numBytes bytes.
*
* Results:
* Returns the number of bytes scanned to produce the lexeme.
*
* Side effects:
* Code identifying lexeme parsed is writen to *lexemePtr.
*
*----------------------------------------------------------------------
*/
static int
ParseLexeme(
const char *start, /* Start of lexeme to parse. */
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;
Tcl_UniChar ch = 0;
Tcl_Obj *literal = NULL;
unsigned char byte;
if (numBytes == 0) {
*lexemePtr = END;
return 0;
|
| ︙ | ︙ | |||
2095 2096 2097 2098 2099 2100 2101 |
/*
* 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 == '_') {
| < | 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 |
/*
* 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 (Tcl_UtfCharComplete(start, numBytes)) {
scanned = TclUtfToUniChar(start, &ch);
} else {
char utfBytes[4];
memcpy(utfBytes, start, numBytes);
utfBytes[numBytes] = '\0';
|
| ︙ | ︙ | |||
2145 2146 2147 2148 2149 2150 2151 |
*----------------------------------------------------------------------
*/
void
TclCompileExpr(
Tcl_Interp *interp, /* Used for error reporting. */
const char *script, /* The source script to compile. */
| | | | 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 |
*----------------------------------------------------------------------
*/
void
TclCompileExpr(
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 = Tcl_NewObj(); /* List to hold the literals */
Tcl_Obj *funcList = Tcl_NewObj(); /* List to hold the functon names*/
Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
/* Holds the Tcl_Tokens of substitutions */
int code = ParseExpr(interp, script, numBytes, &opTree, litList,
funcList, parsePtr, 0 /* parseOnly */);
if (code == TCL_OK) {
/*
|
| ︙ | ︙ | |||
2183 2184 2185 2186 2187 2188 2189 |
TclCompileSyntaxError(interp, envPtr);
}
Tcl_FreeParse(parsePtr);
TclStackFree(interp, parsePtr);
Tcl_DecrRefCount(funcList);
Tcl_DecrRefCount(litList);
| | | 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 |
TclCompileSyntaxError(interp, envPtr);
}
Tcl_FreeParse(parsePtr);
TclStackFree(interp, parsePtr);
Tcl_DecrRefCount(funcList);
Tcl_DecrRefCount(litList);
ckfree(opTree);
}
/*
*----------------------------------------------------------------------
*
* ExecConstantExprTree --
* Compiles and executes bytecode for the subexpression tree at index
|
| ︙ | ︙ | |||
2222 2223 2224 2225 2226 2227 2228 |
/*
* Note we are compiling an expression with literal arguments. This means
* there can be no [info frame] calls when we execute the resulting
* bytecode, so there's no need to tend to TIP 280 issues.
*/
| | | 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 |
/*
* Note we are compiling an expression with literal arguments. This means
* there can be no [info frame] calls when we execute the resulting
* bytecode, so there's no need to tend to TIP 280 issues.
*/
envPtr = (CompileEnv *)TclStackAlloc(interp, sizeof(CompileEnv));
TclInitCompileEnv(interp, envPtr, NULL, 0, NULL, 0);
CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr,
0 /* optimize */);
TclEmitOpcode(INST_DONE, envPtr);
byteCodePtr = TclInitByteCode(envPtr);
TclFreeCompileEnv(envPtr);
TclStackFree(interp, envPtr);
|
| ︙ | ︙ | |||
2293 2294 2295 2296 2297 2298 2299 |
} else if (nodePtr->mark == MARK_RIGHT) {
next = nodePtr->right;
switch (nodePtr->lexeme) {
case FUNCTION: {
Tcl_DString cmdName;
const char *p;
| | | 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 |
} else if (nodePtr->mark == MARK_RIGHT) {
next = nodePtr->right;
switch (nodePtr->lexeme) {
case FUNCTION: {
Tcl_DString cmdName;
const char *p;
int length;
Tcl_DStringInit(&cmdName);
TclDStringAppendLiteral(&cmdName, "tcl::mathfunc::");
p = TclGetStringFromObj(*funcObjv, &length);
funcObjv++;
Tcl_DStringAppend(&cmdName, p, length);
TclEmitPush(TclRegisterLiteral(envPtr,
|
| ︙ | ︙ | |||
2317 2318 2319 2320 2321 2322 2323 | */ nodePtr->left = numWords; numWords = 2; /* Command plus one argument */ break; } case QUESTION: | | | | | 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 |
*/
nodePtr->left = numWords;
numWords = 2; /* Command plus one argument */
break;
}
case QUESTION:
newJump = (JumpList *)TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump);
break;
case COLON:
newJump = (JumpList *)TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
&jumpPtr->jump);
TclAdjustStackDepth(-1, envPtr);
if (convert) {
jumpPtr->jump.jumpType = TCL_TRUE_JUMP;
}
convert = 1;
break;
case AND:
case OR:
newJump = (JumpList *)TclStackAlloc(interp, sizeof(JumpList));
newJump->next = jumpPtr;
jumpPtr = newJump;
TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND)
? TCL_FALSE_JUMP : TCL_TRUE_JUMP, &jumpPtr->jump);
break;
}
} else {
|
| ︙ | ︙ | |||
2452 2453 2454 2455 2456 2457 2458 |
numWords = 1; /* No arguments, so just the command */
break;
case OT_LITERAL: {
Tcl_Obj *const *litObjv = *litObjvPtr;
Tcl_Obj *literal = *litObjv;
if (optimize) {
| | | 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 |
numWords = 1; /* No arguments, so just the command */
break;
case OT_LITERAL: {
Tcl_Obj *const *litObjv = *litObjvPtr;
Tcl_Obj *literal = *litObjv;
if (optimize) {
int length;
const char *bytes = TclGetStringFromObj(literal, &length);
int index = TclRegisterLiteral(envPtr, bytes, length, 0);
Tcl_Obj *objPtr = TclFetchLiteral(envPtr, index);
if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) {
/*
* Would like to do this:
|
| ︙ | ︙ | |||
2511 2512 2513 2514 2515 2516 2517 |
/*
* 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;
| | | | 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 |
/*
* 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);
index = TclRegisterLiteral(envPtr, bytes, numBytes, 0);
tableValue = TclFetchLiteral(envPtr, index);
if ((tableValue->typePtr == NULL) &&
(objPtr->typePtr != NULL)) {
/*
* Same intrep surgery as for OT_LITERAL.
|
| ︙ | ︙ | |||
2569 2570 2571 2572 2573 2574 2575 |
int
TclSingleOpCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| | | 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 |
int
TclSingleOpCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
unsigned char lexeme;
OpNode nodes[2];
Tcl_Obj *const *litObjv = objv + 1;
if (objc != 1 + occdPtr->i.numArgs) {
Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected);
return TCL_ERROR;
|
| ︙ | ︙ | |||
2627 2628 2629 2630 2631 2632 2633 |
Tcl_Obj *const objv[])
{
int code = TCL_OK;
if (objc < 3) {
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1));
} else {
| | | | | 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 |
Tcl_Obj *const objv[])
{
int code = TCL_OK;
if (objc < 3) {
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1));
} else {
TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
Tcl_Obj **litObjv = (Tcl_Obj **)TclStackAlloc(interp,
2 * (objc-2) * sizeof(Tcl_Obj *));
OpNode *nodes = (OpNode *)TclStackAlloc(interp, 2 * (objc-2) * sizeof(OpNode));
unsigned char lexeme;
int i, lastAnd = 1;
Tcl_Obj *const *litObjPtrPtr = litObjv;
ParseLexeme(occdPtr->op, strlen(occdPtr->op), &lexeme, NULL);
litObjv[0] = objv[1];
|
| ︙ | ︙ | |||
2702 2703 2704 2705 2706 2707 2708 |
int
TclVariadicOpCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| | | 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 |
int
TclVariadicOpCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
unsigned char lexeme;
int code;
if (objc < 2) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(occdPtr->i.identity));
return TCL_OK;
}
|
| ︙ | ︙ | |||
2757 2758 2759 2760 2761 2762 2763 |
code = ExecConstantExprTree(interp, nodes, 0, &litObjPtrPtr);
Tcl_DecrRefCount(litObjv[decrMe]);
return code;
} else {
Tcl_Obj *const *litObjv = objv + 1;
| | | 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 |
code = ExecConstantExprTree(interp, nodes, 0, &litObjPtrPtr);
Tcl_DecrRefCount(litObjv[decrMe]);
return code;
} else {
Tcl_Obj *const *litObjv = objv + 1;
OpNode *nodes = (OpNode *)TclStackAlloc(interp, (objc-1) * sizeof(OpNode));
int i, lastOp = OT_LITERAL;
nodes[0].lexeme = START;
nodes[0].mark = MARK_RIGHT;
if (lexeme == EXPON) {
for (i=objc-2; i>0; i--) {
nodes[i].lexeme = lexeme;
|
| ︙ | ︙ | |||
2821 2822 2823 2824 2825 2826 2827 |
int
TclNoIdentOpCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| | | 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 |
int
TclNoIdentOpCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected);
return TCL_ERROR;
}
return TclVariadicOpCmd(clientData, interp, objc, objv);
}
|
| ︙ | ︙ |
Changes to generic/tclCompile.c.
| ︙ | ︙ | |||
125 126 127 128 129 130 131 132 133 134 135 136 137 138 |
{"jumpTrue4", 5, -1, 1, {OPERAND_OFFSET4}},
/* Jump relative to (pc + op4) if stktop expr object is true */
{"jumpFalse1", 2, -1, 1, {OPERAND_OFFSET1}},
/* Jump relative to (pc + op1) if stktop expr object is false */
{"jumpFalse4", 5, -1, 1, {OPERAND_OFFSET4}},
/* Jump relative to (pc + op4) if stktop expr object is false */
{"bitor", 1, -1, 0, {OPERAND_NONE}},
/* Bitwise or: push (stknext | stktop) */
{"bitxor", 1, -1, 0, {OPERAND_NONE}},
/* Bitwise xor push (stknext ^ stktop) */
{"bitand", 1, -1, 0, {OPERAND_NONE}},
/* Bitwise and: push (stknext & stktop) */
{"eq", 1, -1, 0, {OPERAND_NONE}},
| > > > > | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 |
{"jumpTrue4", 5, -1, 1, {OPERAND_OFFSET4}},
/* Jump relative to (pc + op4) if stktop expr object is true */
{"jumpFalse1", 2, -1, 1, {OPERAND_OFFSET1}},
/* Jump relative to (pc + op1) if stktop expr object is false */
{"jumpFalse4", 5, -1, 1, {OPERAND_OFFSET4}},
/* Jump relative to (pc + op4) if stktop expr object is false */
{"lor", 1, -1, 0, {OPERAND_NONE}},
/* Logical or: push (stknext || stktop) */
{"land", 1, -1, 0, {OPERAND_NONE}},
/* Logical and: push (stknext && stktop) */
{"bitor", 1, -1, 0, {OPERAND_NONE}},
/* Bitwise or: push (stknext | stktop) */
{"bitxor", 1, -1, 0, {OPERAND_NONE}},
/* Bitwise xor push (stknext ^ stktop) */
{"bitand", 1, -1, 0, {OPERAND_NONE}},
/* Bitwise and: push (stknext & stktop) */
{"eq", 1, -1, 0, {OPERAND_NONE}},
|
| ︙ | ︙ | |||
165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 |
/* Unary plus: push +stktop */
{"uminus", 1, 0, 0, {OPERAND_NONE}},
/* Unary minus: push -stktop */
{"bitnot", 1, 0, 0, {OPERAND_NONE}},
/* Bitwise not: push ~stktop */
{"not", 1, 0, 0, {OPERAND_NONE}},
/* Logical not: push !stktop */
{"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}},
/* Try converting stktop to first int then double if possible. */
{"break", 1, 0, 0, {OPERAND_NONE}},
/* Abort closest enclosing loop; if none, return TCL_BREAK code. */
{"continue", 1, 0, 0, {OPERAND_NONE}},
/* Skip to next iteration of closest enclosing loop; if none, return
* TCL_CONTINUE code. */
{"beginCatch4", 5, 0, 1, {OPERAND_UINT4}},
/* Record start of catch with the operand's exception index. Push the
* current stack depth onto a special catch stack. */
{"endCatch", 1, 0, 0, {OPERAND_NONE}},
/* End of last catch. Pop the bytecode interpreter's catch stack. */
{"pushResult", 1, +1, 0, {OPERAND_NONE}},
| > > > > > > > > > > > | 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 |
/* Unary plus: push +stktop */
{"uminus", 1, 0, 0, {OPERAND_NONE}},
/* Unary minus: push -stktop */
{"bitnot", 1, 0, 0, {OPERAND_NONE}},
/* Bitwise not: push ~stktop */
{"not", 1, 0, 0, {OPERAND_NONE}},
/* Logical not: push !stktop */
{"callBuiltinFunc1", 2, 1, 1, {OPERAND_UINT1}},
/* Call builtin math function with index op1; any args are on stk */
{"callFunc1", 2, INT_MIN, 1, {OPERAND_UINT1}},
/* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */
{"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}},
/* Try converting stktop to first int then double if possible. */
{"break", 1, 0, 0, {OPERAND_NONE}},
/* Abort closest enclosing loop; if none, return TCL_BREAK code. */
{"continue", 1, 0, 0, {OPERAND_NONE}},
/* Skip to next iteration of closest enclosing loop; if none, return
* TCL_CONTINUE code. */
{"foreach_start4", 5, 0, 1, {OPERAND_AUX4}},
/* Initialize execution of a foreach loop. Operand is aux data index
* of the ForeachInfo structure for the foreach command. */
{"foreach_step4", 5, +1, 1, {OPERAND_AUX4}},
/* "Step" or begin next iteration of foreach loop. Push 0 if to
* terminate loop, else push 1. */
{"beginCatch4", 5, 0, 1, {OPERAND_UINT4}},
/* Record start of catch with the operand's exception index. Push the
* current stack depth onto a special catch stack. */
{"endCatch", 1, 0, 0, {OPERAND_NONE}},
/* End of last catch. Pop the bytecode interpreter's catch stack. */
{"pushResult", 1, +1, 0, {OPERAND_NONE}},
|
| ︙ | ︙ | |||
321 322 323 324 325 326 327 328 329 330 331 332 333 334 |
* indicated by op4 to hold the iterator state. The local scalar
* should not refer to a named variable as the value is not wholly
* managed correctly.
* Stack: ... dict => ... value key doneBool */
{"dictNext", 5, +3, 1, {OPERAND_LVT4}},
/* Get the next iteration from the iterator in op4's local scalar.
* Stack: ... => ... value key doneBool */
{"dictUpdateStart", 9, 0, 2, {OPERAND_LVT4, OPERAND_AUX4}},
/* Create the variables (described in the aux data referred to by the
* second immediate argument) to mirror the state of the dictionary in
* the variable referred to by the first immediate argument. The list
* of keys (top of the stack, not popped) must be the same length as
* the list of variables.
* Stack: ... keyList => ... keyList */
| > > > | 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 |
* indicated by op4 to hold the iterator state. The local scalar
* should not refer to a named variable as the value is not wholly
* managed correctly.
* Stack: ... dict => ... value key doneBool */
{"dictNext", 5, +3, 1, {OPERAND_LVT4}},
/* Get the next iteration from the iterator in op4's local scalar.
* Stack: ... => ... value key doneBool */
{"dictDone", 5, 0, 1, {OPERAND_LVT4}},
/* Terminate the iterator in op4's local scalar. Use unsetScalar
* instead (with 0 for flags). */
{"dictUpdateStart", 9, 0, 2, {OPERAND_LVT4, OPERAND_AUX4}},
/* Create the variables (described in the aux data referred to by the
* second immediate argument) to mirror the state of the dictionary in
* the variable referred to by the first immediate argument. The list
* of keys (top of the stack, not popped) must be the same length as
* the list of variables.
* Stack: ... keyList => ... keyList */
|
| ︙ | ︙ | |||
675 676 677 678 679 680 681 | static void EnterCmdExtentData(CompileEnv *envPtr, int cmdNumber, int numSrcBytes, int numCodeBytes); static void EnterCmdStartData(CompileEnv *envPtr, int cmdNumber, int srcOffset, int codeOffset); static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); | | < | 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 | static void EnterCmdExtentData(CompileEnv *envPtr, int cmdNumber, int numSrcBytes, int numCodeBytes); static void EnterCmdStartData(CompileEnv *envPtr, int cmdNumber, int srcOffset, int codeOffset); static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); static int IsCompactibleCompileEnv(CompileEnv *envPtr); static void PreventCycle(Tcl_Obj *objPtr, CompileEnv *envPtr); #ifdef TCL_COMPILE_STATS static void RecordByteCodeStats(ByteCode *codePtr); #endif /* TCL_COMPILE_STATS */ static int SetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void StartExpanding(CompileEnv *envPtr); |
| ︙ | ︙ | |||
775 776 777 778 779 780 781 |
const char *stringPtr;
Proc *procPtr = iPtr->compiledProcPtr;
ContLineLoc *clLocPtr;
#ifdef TCL_COMPILE_DEBUG
if (!traceInitialized) {
if (Tcl_LinkVar(interp, "tcl_traceCompile",
| | | > | 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 |
const char *stringPtr;
Proc *procPtr = iPtr->compiledProcPtr;
ContLineLoc *clLocPtr;
#ifdef TCL_COMPILE_DEBUG
if (!traceInitialized) {
if (Tcl_LinkVar(interp, "tcl_traceCompile",
&tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
}
traceInitialized = 1;
}
#endif
stringPtr = TclGetString(objPtr);
length = objPtr->length;
/*
* TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and
* use to initialize the tracking in the compiler. This information was
* stored by TclCompEvalObj and ProcCompileProc.
*/
|
| ︙ | ︙ | |||
828 829 830 831 832 833 834 |
* 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_GetMaster(interp) == NULL &&
!Tcl_LimitTypeEnabled(interp, TCL_LIMIT_COMMANDS|TCL_LIMIT_TIME)
| | | | | 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 |
* 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_GetMaster(interp) == NULL &&
!Tcl_LimitTypeEnabled(interp, TCL_LIMIT_COMMANDS|TCL_LIMIT_TIME)
&& IsCompactibleCompileEnv(&compEnv)) {
TclFreeCompileEnv(&compEnv);
iPtr->compiledProcPtr = procPtr;
TclInitCompileEnv(interp, &compEnv, stringPtr, length,
iPtr->invokeCmdFramePtr, iPtr->invokeWord);
if (clLocPtr) {
compEnv.clNext = &clLocPtr->loc[0];
}
compEnv.atCmdStart = 2; /* The disabling magic. */
TclCompileScript(interp, stringPtr, length, &compEnv);
assert (compEnv.atCmdStart > 1);
TclEmitOpcode(INST_DONE, &compEnv);
assert (compEnv.atCmdStart > 1);
}
/*
* Apply some peephole optimizations that can cross specific/generic
* instruction generator boundaries.
*/
if (iPtr->extra.optimizer) {
(iPtr->extra.optimizer)(&compEnv);
}
/*
* Invoke the compilation hook procedure if one exists.
*/
if (hookProc) {
|
| ︙ | ︙ | |||
939 940 941 942 943 944 945 | * None. * *---------------------------------------------------------------------- */ static void DupByteCodeInternalRep( | | | | 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 |
* None.
*
*----------------------------------------------------------------------
*/
static void
DupByteCodeInternalRep(
TCL_UNUSED(Tcl_Obj *) /*srcPtr*/,
TCL_UNUSED(Tcl_Obj *) /*copyPtr*/)
{
return;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
967 968 969 970 971 972 973 | * cleanup is delayed until the last execution of the code completes. * *---------------------------------------------------------------------- */ static void FreeByteCodeInternalRep( | | | 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 |
* cleanup is delayed until the last execution of the code completes.
*
*----------------------------------------------------------------------
*/
static void
FreeByteCodeInternalRep(
Tcl_Obj *objPtr) /* Object whose internal rep to free. */
{
ByteCode *codePtr;
ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr);
assert(codePtr != NULL);
TclReleaseByteCode(codePtr);
|
| ︙ | ︙ | |||
998 999 1000 1001 1002 1003 1004 | * Also releases its literals and frees its auxiliary data items. * *---------------------------------------------------------------------- */ void TclPreserveByteCode( | | | | | | | 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 |
* Also releases its literals and frees its auxiliary data items.
*
*----------------------------------------------------------------------
*/
void
TclPreserveByteCode(
ByteCode *codePtr)
{
codePtr->refCount++;
}
void
TclReleaseByteCode(
ByteCode *codePtr)
{
if (codePtr->refCount-- > 1) {
return;
}
/* Just dropped to refcount==0. Clean up. */
CleanupByteCode(codePtr);
}
static void
CleanupByteCode(
ByteCode *codePtr) /* Points to the ByteCode to free. */
{
Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle;
Interp *iPtr = (Interp *) interp;
int numLitObjects = codePtr->numLitObjects;
int numAuxDataItems = codePtr->numAuxDataItems;
Tcl_Obj **objArrayPtr, *objPtr;
const AuxData *auxDataPtr;
int i;
#ifdef TCL_COMPILE_STATS
if (interp != NULL) {
ByteCodeStats *statsPtr;
Tcl_Time destroyTime;
int lifetimeSec, lifetimeMicroSec, log2;
|
| ︙ | ︙ | |||
1125 1126 1127 1128 1129 1130 1131 |
*/
if (iPtr) {
Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr,
(char *) codePtr);
if (hePtr) {
| | | | < | 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 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 |
*/
if (iPtr) {
Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr,
(char *) codePtr);
if (hePtr) {
ReleaseCmdWordData((ExtCmdLoc *)Tcl_GetHashValue(hePtr));
Tcl_DeleteHashEntry(hePtr);
}
}
if (codePtr->localCachePtr && (--codePtr->localCachePtr->refCount == 0)) {
TclFreeLocalCache(interp, codePtr->localCachePtr);
}
TclHandleRelease(codePtr->interpHandle);
ckfree(codePtr);
}
/*
* ---------------------------------------------------------------------
*
* IsCompactibleCompileEnv --
*
* Checks to see if we may apply some basic compaction optimizations to a
* piece of bytecode. Idempotent.
*
* ---------------------------------------------------------------------
*/
static int
IsCompactibleCompileEnv(
CompileEnv *envPtr)
{
unsigned char *pc;
int size;
/*
* Special: procedures in the '::tcl' namespace (or its children) are
|
| ︙ | ︙ | |||
1320 1321 1322 1323 1324 1325 1326 |
iPtr->varFramePtr->localCachePtr)) {
Tcl_StoreIntRep(objPtr, &substCodeType, NULL);
codePtr = NULL;
}
}
if (codePtr == NULL) {
CompileEnv compEnv;
| | | 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 |
iPtr->varFramePtr->localCachePtr)) {
Tcl_StoreIntRep(objPtr, &substCodeType, NULL);
codePtr = NULL;
}
}
if (codePtr == NULL) {
CompileEnv compEnv;
int numBytes;
const char *bytes = TclGetStringFromObj(objPtr, &numBytes);
/* TODO: Check for more TIP 280 */
TclInitCompileEnv(interp, &compEnv, bytes, numBytes, NULL, 0);
TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv);
|
| ︙ | ︙ | |||
1369 1370 1371 1372 1373 1374 1375 | * the cleanup is delayed until the last execution of the code completes. * *---------------------------------------------------------------------- */ static void FreeSubstCodeInternalRep( | | | | | | | 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 |
* the cleanup is delayed until the last execution of the code completes.
*
*----------------------------------------------------------------------
*/
static void
FreeSubstCodeInternalRep(
Tcl_Obj *objPtr) /* Object whose internal rep to free. */
{
ByteCode *codePtr;
ByteCodeGetIntRep(objPtr, &substCodeType, codePtr);
assert(codePtr != NULL);
TclReleaseByteCode(codePtr);
}
static void
ReleaseCmdWordData(
ExtCmdLoc *eclPtr)
{
int i;
if (eclPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(eclPtr->path);
}
for (i=0 ; i<eclPtr->nuloc ; i++) {
ckfree(eclPtr->loc[i].line);
}
if (eclPtr->loc != NULL) {
ckfree(eclPtr->loc);
}
ckfree(eclPtr);
}
/*
*----------------------------------------------------------------------
*
* TclInitCompileEnv --
*
|
| ︙ | ︙ | |||
1420 1421 1422 1423 1424 1425 1426 |
*----------------------------------------------------------------------
*/
void
TclInitCompileEnv(
Tcl_Interp *interp, /* The interpreter for which a CompileEnv
* structure is initialized. */
| | | | | 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 |
*----------------------------------------------------------------------
*/
void
TclInitCompileEnv(
Tcl_Interp *interp, /* The interpreter for which a CompileEnv
* structure is initialized. */
CompileEnv *envPtr,/* Points to the CompileEnv structure to
* initialize. */
const char *stringPtr, /* The source string to be compiled. */
int numBytes, /* Number of bytes in source string. */
const CmdFrame *invoker, /* Location context invoking the bcc */
int word) /* Index of the word in that context getting
* compiled */
{
Interp *iPtr = (Interp *) interp;
assert(tclInstructionTable[LAST_INST_OPCODE+1].name == NULL);
envPtr->iPtr = iPtr;
envPtr->source = stringPtr;
envPtr->numSrcBytes = numBytes;
envPtr->procPtr = iPtr->compiledProcPtr;
iPtr->compiledProcPtr = NULL;
envPtr->numCommands = 0;
|
| ︙ | ︙ | |||
1475 1476 1477 1478 1479 1480 1481 |
* the context invoking the byte code compiler. This structure is used to
* keep the per-word line information for all compiled commands.
*
* See also tclBasic.c, TclEvalObjEx, for the equivalent code in the
* non-compiling evaluator
*/
| | | 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 |
* the context invoking the byte code compiler. This structure is used to
* keep the per-word line information for all compiled commands.
*
* See also tclBasic.c, TclEvalObjEx, for the equivalent code in the
* non-compiling evaluator
*/
envPtr->extCmdMapPtr = (ExtCmdLoc *)ckalloc(sizeof(ExtCmdLoc));
envPtr->extCmdMapPtr->loc = NULL;
envPtr->extCmdMapPtr->nloc = 0;
envPtr->extCmdMapPtr->nuloc = 0;
envPtr->extCmdMapPtr->path = NULL;
if (invoker == NULL) {
/*
|
| ︙ | ︙ | |||
1531 1532 1533 1534 1535 1536 1537 | /* * Initialize the compiler using the context, making counting absolute * to that context. Note that the context can be byte code execution. * In that case we have to fill out the missing pieces (line, path, * ...) which may make change the type as well. */ | | | 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 |
/*
* Initialize the compiler using the context, making counting absolute
* to that context. Note that the context can be byte code execution.
* In that case we have to fill out the missing pieces (line, path,
* ...) which may make change the type as well.
*/
CmdFrame *ctxPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
int pc = 0;
*ctxPtr = *invoker;
if (invoker->type == TCL_LOCATION_BC) {
/*
* Note: Type BC => ctx.data.eval.path is not used.
* ctx.data.tebc.codePtr is used instead.
|
| ︙ | ︙ | |||
1627 1628 1629 1630 1631 1632 1633 | * corresponding ByteCode structure. * *---------------------------------------------------------------------- */ void TclFreeCompileEnv( | | | | 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 |
* corresponding ByteCode structure.
*
*----------------------------------------------------------------------
*/
void
TclFreeCompileEnv(
CompileEnv *envPtr)/* Points to the CompileEnv structure. */
{
if (envPtr->localLitTable.buckets != envPtr->localLitTable.staticBuckets){
ckfree(envPtr->localLitTable.buckets);
envPtr->localLitTable.buckets = envPtr->localLitTable.staticBuckets;
}
if (envPtr->iPtr) {
/*
* We never converted to Bytecode, so free the things we would
* have transferred to it.
*/
|
| ︙ | ︙ | |||
1660 1661 1662 1663 1664 1665 1666 |
if (auxDataPtr->type->freeProc != NULL) {
auxDataPtr->type->freeProc(auxDataPtr->clientData);
}
auxDataPtr++;
}
}
if (envPtr->mallocedCodeArray) {
| | | | | | | | 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 |
if (auxDataPtr->type->freeProc != NULL) {
auxDataPtr->type->freeProc(auxDataPtr->clientData);
}
auxDataPtr++;
}
}
if (envPtr->mallocedCodeArray) {
ckfree(envPtr->codeStart);
}
if (envPtr->mallocedLiteralArray) {
ckfree(envPtr->literalArrayPtr);
}
if (envPtr->mallocedExceptArray) {
ckfree(envPtr->exceptArrayPtr);
ckfree(envPtr->exceptAuxArrayPtr);
}
if (envPtr->mallocedCmdMap) {
ckfree(envPtr->cmdMapPtr);
}
if (envPtr->mallocedAuxDataArray) {
ckfree(envPtr->auxDataArrayPtr);
}
if (envPtr->extCmdMapPtr) {
ReleaseCmdWordData(envPtr->extCmdMapPtr);
envPtr->extCmdMapPtr = NULL;
}
}
|
| ︙ | ︙ | |||
1739 1740 1741 1742 1743 1744 1745 |
Tcl_AppendToObj(tempPtr, tokenPtr->start, tokenPtr->size);
}
break;
case TCL_TOKEN_BS:
if (tempPtr != NULL) {
char utfBuf[4] = "";
| | | 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 |
Tcl_AppendToObj(tempPtr, tokenPtr->start, tokenPtr->size);
}
break;
case TCL_TOKEN_BS:
if (tempPtr != NULL) {
char utfBuf[4] = "";
int length = TclParseBackslash(tokenPtr->start,
tokenPtr->size, NULL, utfBuf);
Tcl_AppendToObj(tempPtr, utfBuf, length);
}
break;
default:
|
| ︙ | ︙ | |||
1782 1783 1784 1785 1786 1787 1788 |
*
*----------------------------------------------------------------------
*/
static int
ExpandRequested(
Tcl_Token *tokenPtr,
| | > < | | | < < > | 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 |
*
*----------------------------------------------------------------------
*/
static int
ExpandRequested(
Tcl_Token *tokenPtr,
int numWords)
{
/* Determine whether any words of the command require expansion */
while (numWords--) {
if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
return 1;
}
tokenPtr = TokenAfter(tokenPtr);
}
return 0;
}
static void
CompileCmdLiteral(
Tcl_Interp *interp,
Tcl_Obj *cmdObj,
CompileEnv *envPtr)
{
int numBytes;
const char *bytes;
Command *cmdPtr;
int cmdLitIdx, extraLiteralFlags = LITERAL_CMD_NAME;
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
bytes = TclGetStringFromObj(cmdObj, &numBytes);
cmdLitIdx = TclRegisterLiteral(envPtr, bytes, numBytes, extraLiteralFlags);
if (cmdPtr) {
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr);
}
TclEmitPush(cmdLitIdx, envPtr);
}
void
TclCompileInvocation(
Tcl_Interp *interp,
Tcl_Token *tokenPtr,
Tcl_Obj *cmdObj,
int numWords,
CompileEnv *envPtr)
{
DefineLineInformation;
int wordIdx = 0, depth = TclGetStackDepth(envPtr);
if (cmdObj) {
CompileCmdLiteral(interp, cmdObj, envPtr);
wordIdx = 1;
tokenPtr = TokenAfter(tokenPtr);
}
|
| ︙ | ︙ | |||
1872 1873 1874 1875 1876 1877 1878 |
CompileExpanded(
Tcl_Interp *interp,
Tcl_Token *tokenPtr,
Tcl_Obj *cmdObj,
int numWords,
CompileEnv *envPtr)
{
| < > | 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 |
CompileExpanded(
Tcl_Interp *interp,
Tcl_Token *tokenPtr,
Tcl_Obj *cmdObj,
int numWords,
CompileEnv *envPtr)
{
DefineLineInformation;
int wordIdx = 0;
int depth = TclGetStackDepth(envPtr);
StartExpanding(envPtr);
if (cmdObj) {
CompileCmdLiteral(interp, cmdObj, envPtr);
wordIdx = 1;
tokenPtr = TokenAfter(tokenPtr);
|
| ︙ | ︙ | |||
1931 1932 1933 1934 1935 1936 1937 |
static int
CompileCmdCompileProc(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
Command *cmdPtr,
CompileEnv *envPtr)
{
| < > | 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 |
static int
CompileCmdCompileProc(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
Command *cmdPtr,
CompileEnv *envPtr)
{
DefineLineInformation;
int unwind = 0, incrOffset = -1;
int depth = TclGetStackDepth(envPtr);
/*
* Emit of the INST_START_CMD instruction is controlled by the value of
* envPtr->atCmdStart:
*
* atCmdStart == 2 : We are not using the INST_START_CMD instruction.
|
| ︙ | ︙ | |||
1993 1994 1995 1996 1997 1998 1999 |
/*
* Throw out any line information generated by the failed compile attempt.
*/
while (mapPtr->nuloc - 1 > eclIndex) {
mapPtr->nuloc--;
| | | 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 |
/*
* Throw out any line information generated by the failed compile attempt.
*/
while (mapPtr->nuloc - 1 > eclIndex) {
mapPtr->nuloc--;
ckfree(mapPtr->loc[mapPtr->nuloc].line);
mapPtr->loc[mapPtr->nuloc].line = NULL;
}
/*
* Reset the index of next command. Toss out any from failed nested
* partial compiles.
*/
|
| ︙ | ︙ | |||
2111 2112 2113 2114 2115 2116 2117 |
/*
* TIP #280: Free full form of per-word line data and insert the reduced
* form now
*/
envPtr->line = cmdLine;
envPtr->clNext = clNext;
| | | | > > > > > > > > > > > > > > | > | > > > > > | > > | | | | > | | | | | | | | | > > > > > > | > > | | > > > | 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 |
/*
* TIP #280: Free full form of per-word line data and insert the reduced
* form now
*/
envPtr->line = cmdLine;
envPtr->clNext = clNext;
ckfree(eclPtr->loc[wlineat].line);
ckfree(eclPtr->loc[wlineat].next);
eclPtr->loc[wlineat].line = wlines;
eclPtr->loc[wlineat].next = NULL;
TclCheckStackDepth(depth, envPtr);
return cmdIdx;
}
void
TclCompileScript(
Tcl_Interp *interp, /* Used for error and status reporting. Also
* serves as context for finding and compiling
* commands. May not be NULL. */
const char *script, /* The source script to compile. */
int numBytes, /* Number of bytes in script. If < 0, the
* script consists of all bytes up to the
* first null character. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
int lastCmdIdx = -1; /* Index into envPtr->cmdMapPtr of the last
* command this routine compiles into bytecode.
* Initial value of -1 indicates this routine
* has not yet generated any bytecode. */
const char *p = script; /* Where we are in our compile. */
int depth = TclGetStackDepth(envPtr);
Interp *iPtr = (Interp *) interp;
if (envPtr->iPtr == NULL) {
Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv");
}
/*
* Check depth to avoid overflow of the C execution stack by too many
* nested calls of TclCompileScript (considering interp recursionlimit).
* Factor 5/4 (1.25) is used to avoid too mistaken limit recognition
* during "mixed" evaluation and compilation process (nested eval+compile)
* and is good enough for default recursionlimit (1000).
*/
if (iPtr->numLevels / 5 > iPtr->maxNestingDepth / 4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"too many nested compilations (infinite loop?)", -1));
Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", NULL);
TclCompileSyntaxError(interp, envPtr);
return;
}
/* Each iteration compiles one command from the script. */
if (numBytes > 0) {
/*
* Don't use system stack (size of Tcl_Parse is ca. 400 bytes), so
* many nested compilations (body enclosed in body) can cause abnormal
* program termination with a stack overflow exception, bug [fec0c17d39].
*/
Tcl_Parse *parsePtr = (Tcl_Parse *)ckalloc(sizeof(Tcl_Parse));
do {
const char *next;
if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, parsePtr)) {
/*
* Compile bytecodes to report the parsePtr error at runtime.
*/
Tcl_LogCommandInfo(interp, script, parsePtr->commandStart,
parsePtr->term + 1 - parsePtr->commandStart);
TclCompileSyntaxError(interp, envPtr);
ckfree(parsePtr);
return;
}
#ifdef TCL_COMPILE_DEBUG
/*
* If tracing, print a line for each top level command compiled.
* TODO: Suppress when numWords == 0 ?
*/
if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
int commandLength = parsePtr->term - parsePtr->commandStart;
fprintf(stdout, " Compiling: ");
TclPrintSource(stdout, parsePtr->commandStart,
TclMin(commandLength, 55));
fprintf(stdout, "\n");
}
#endif
/*
* TIP #280: Count newlines before the command start.
* (See test info-30.33).
*/
TclAdvanceLines(&envPtr->line, p, parsePtr->commandStart);
TclAdvanceContinuations(&envPtr->line, &envPtr->clNext,
parsePtr->commandStart - envPtr->source);
/*
* Advance parser to the next command in the script.
*/
next = parsePtr->commandStart + parsePtr->commandSize;
numBytes -= next - p;
p = next;
if (parsePtr->numWords == 0) {
/*
* The "command" parsed has no words. In this case we can skip
* the rest of the loop body. With no words, clearly
* CompileCommandTokens() has nothing to do. Since the parser
* aggressively sucks up leading comment and white space,
* including newlines, parsePtr->commandStart must be pointing at
* either the end of script, or a command-terminating semi-colon.
* In either case, the TclAdvance*() calls have nothing to do.
* Finally, when no words are parsed, no tokens have been
* allocated at parsePtr->tokenPtr so there's also nothing for
* Tcl_FreeParse() to do.
*
* The advantage of this shortcut is that CompileCommandTokens()
* can be written with an assumption that parsePtr->numWords > 0, with
* the implication the CCT() always generates bytecode.
*/
continue;
}
/*
* Avoid stack exhaustion by too many nested calls of TclCompileScript
* (considering interp recursionlimit).
*/
iPtr->numLevels++;
lastCmdIdx = CompileCommandTokens(interp, parsePtr, envPtr);
iPtr->numLevels--;
/*
* TIP #280: Track lines in the just compiled command.
*/
TclAdvanceLines(&envPtr->line, parsePtr->commandStart, p);
TclAdvanceContinuations(&envPtr->line, &envPtr->clNext,
p - envPtr->source);
Tcl_FreeParse(parsePtr);
} while (numBytes > 0);
ckfree(parsePtr);
}
if (lastCmdIdx == -1) {
/*
* Compiling the script yielded no bytecode. The script must be all
* whitespace, comments, and empty commands. Such scripts are defined
* to successfully produce the empty string result, so we emit the
|
| ︙ | ︙ | |||
2279 2280 2281 2282 2283 2284 2285 |
void
TclCompileVarSubst(
Tcl_Interp *interp,
Tcl_Token *tokenPtr,
CompileEnv *envPtr)
{
const char *p, *name = tokenPtr[1].start;
| | | | 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 |
void
TclCompileVarSubst(
Tcl_Interp *interp,
Tcl_Token *tokenPtr,
CompileEnv *envPtr)
{
const char *p, *name = tokenPtr[1].start;
int nameBytes = tokenPtr[1].size;
int i, localVar, localVarName = 1;
/*
* Determine how the variable name should be handled: if it contains any
* namespace qualifiers it is not a local variable (localVarName=-1); if
* it looks like an array element and the token has a single component, it
* should not be created here [Bug 569438] (localVarName=0); otherwise,
* the local variable can safely be created (localVarName=1).
|
| ︙ | ︙ | |||
2354 2355 2356 2357 2358 2359 2360 |
int count, /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
Tcl_DString textBuffer; /* Holds concatenated chars from adjacent
* TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
char buffer[4] = "";
| | < | 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 |
int count, /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
Tcl_DString textBuffer; /* Holds concatenated chars from adjacent
* TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
char buffer[4] = "";
int i, numObjsToConcat, length, adjust;
unsigned char *entryCodeNext = envPtr->codeNext;
#define NUM_STATIC_POS 20
int isLiteral, maxNumCL, numCL;
int *clPosition = NULL;
int depth = TclGetStackDepth(envPtr);
/*
|
| ︙ | ︙ | |||
2390 2391 2392 2393 2394 2395 2396 |
isLiteral = 0;
break;
}
}
if (isLiteral) {
maxNumCL = NUM_STATIC_POS;
| | | 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 |
isLiteral = 0;
break;
}
}
if (isLiteral) {
maxNumCL = NUM_STATIC_POS;
clPosition = (int *)ckalloc(maxNumCL * sizeof(int));
}
adjust = 0;
Tcl_DStringInit(&textBuffer);
numObjsToConcat = 0;
for ( ; count > 0; count--, tokenPtr++) {
switch (tokenPtr->type) {
|
| ︙ | ︙ | |||
2431 2432 2433 2434 2435 2436 2437 |
if ((length == 1) && (buffer[0] == ' ') &&
(tokenPtr->start[1] == '\n')) {
if (isLiteral) {
int clPos = Tcl_DStringLength(&textBuffer);
if (numCL >= maxNumCL) {
maxNumCL *= 2;
| | | 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 |
if ((length == 1) && (buffer[0] == ' ') &&
(tokenPtr->start[1] == '\n')) {
if (isLiteral) {
int clPos = Tcl_DStringLength(&textBuffer);
if (numCL >= maxNumCL) {
maxNumCL *= 2;
clPosition = (int *)ckrealloc(clPosition,
maxNumCL * sizeof(int));
}
clPosition[numCL] = clPos;
numCL ++;
}
adjust++;
}
|
| ︙ | ︙ | |||
2489 2490 2491 2492 2493 2494 2495 |
numObjsToConcat++;
count -= tokenPtr->numComponents;
tokenPtr += tokenPtr->numComponents;
break;
default:
Tcl_Panic("Unexpected token type in TclCompileTokens: %d; %.*s",
| | | 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 |
numObjsToConcat++;
count -= tokenPtr->numComponents;
tokenPtr += tokenPtr->numComponents;
break;
default:
Tcl_Panic("Unexpected token type in TclCompileTokens: %d; %.*s",
tokenPtr->type, tokenPtr->size, tokenPtr->start);
}
}
/*
* Push any accumulated characters appearing at the end.
*/
|
| ︙ | ︙ | |||
2536 2537 2538 2539 2540 2541 2542 |
/*
* Release the temp table we used to collect the locations of continuation
* lines, if any.
*/
if (maxNumCL) {
| | | 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 |
/*
* Release the temp table we used to collect the locations of continuation
* lines, if any.
*/
if (maxNumCL) {
ckfree(clPosition);
}
TclCheckStackDepth(depth+1, envPtr);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2682 2683 2684 2685 2686 2687 2688 |
*/
int
TclCompileNoOp(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
| | < | 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 |
*/
int
TclCompileNoOp(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
TCL_UNUSED(Command *),
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr;
int i;
tokenPtr = parsePtr->tokenPtr;
for (i = 1; i < parsePtr->numWords; i++) {
|
| ︙ | ︙ | |||
2747 2748 2749 2750 2751 2752 2753 |
* reach zero, and memory may leak. Bugs 467523, 3357771
*
* NOTE: [Bugs 3392070, 3389764] We make a copy based completely
* on the string value, and do not call Tcl_DuplicateObj() so we
* can be sure we do not have any lingering cycles hiding in
* the intrep.
*/
| | | | | | 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 |
* reach zero, and memory may leak. Bugs 467523, 3357771
*
* NOTE: [Bugs 3392070, 3389764] We make a copy based completely
* on the string value, and do not call Tcl_DuplicateObj() so we
* can be sure we do not have any lingering cycles hiding in
* the intrep.
*/
int numBytes;
const char *bytes = TclGetStringFromObj(objPtr, &numBytes);
Tcl_Obj *copyPtr = Tcl_NewStringObj(bytes, numBytes);
Tcl_IncrRefCount(copyPtr);
TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, objPtr);
envPtr->literalArrayPtr[i].objPtr = copyPtr;
}
}
}
ByteCode *
TclInitByteCode(
CompileEnv *envPtr)/* Points to the CompileEnv structure from
* which to create a ByteCode structure. */
{
ByteCode *codePtr;
size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;
size_t auxDataArrayBytes, structureSize;
unsigned char *p;
#ifdef TCL_COMPILE_DEBUG
unsigned char *nextPtr;
#endif
int numLitObjects = envPtr->literalArrayNext;
Namespace *namespacePtr;
int i, isNew;
Interp *iPtr;
|
| ︙ | ︙ | |||
2805 2806 2807 2808 2809 2810 2811 |
if (envPtr->iPtr->varFramePtr != NULL) {
namespacePtr = envPtr->iPtr->varFramePtr->nsPtr;
} else {
namespacePtr = envPtr->iPtr->globalNsPtr;
}
| | | 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 |
if (envPtr->iPtr->varFramePtr != NULL) {
namespacePtr = envPtr->iPtr->varFramePtr->nsPtr;
} else {
namespacePtr = envPtr->iPtr->globalNsPtr;
}
p = (unsigned char *)ckalloc(structureSize);
codePtr = (ByteCode *) p;
codePtr->interpHandle = TclHandlePreserve(iPtr->handle);
codePtr->compileEpoch = iPtr->compileEpoch;
codePtr->nsPtr = namespacePtr;
codePtr->nsEpoch = namespacePtr->resolverEpoch;
codePtr->refCount = 0;
TclPreserveByteCode(codePtr);
|
| ︙ | ︙ | |||
2902 2903 2904 2905 2906 2907 2908 |
ByteCode *
TclInitByteCodeObj(
Tcl_Obj *objPtr, /* Points object that should be initialized,
* and whose string rep contains the source
* code. */
const Tcl_ObjType *typePtr,
| | | 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 |
ByteCode *
TclInitByteCodeObj(
Tcl_Obj *objPtr, /* Points object that should be initialized,
* and whose string rep contains the source
* code. */
const Tcl_ObjType *typePtr,
CompileEnv *envPtr)/* Points to the CompileEnv structure from
* which to create a ByteCode structure. */
{
ByteCode *codePtr;
PreventCycle(objPtr, envPtr);
codePtr = TclInitByteCode(envPtr);
|
| ︙ | ︙ | |||
2947 2948 2949 2950 2951 2952 2953 | * variable is unknown, or if the name is NULL. * *---------------------------------------------------------------------- */ int TclFindCompiledLocal( | | | | | | | > | | | 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 |
* variable is unknown, or if the name is NULL.
*
*----------------------------------------------------------------------
*/
int
TclFindCompiledLocal(
const char *name, /* Points to first character of the name of a
* scalar or array variable. If NULL, a
* temporary var should be created. */
int nameBytes, /* Number of bytes in the name. */
int create, /* If 1, allocate a local frame entry for the
* variable if it is new. */
CompileEnv *envPtr) /* Points to the current compile environment*/
{
CompiledLocal *localPtr;
int localVar = -1;
int i;
Proc *procPtr;
/*
* If not creating a temporary, does a local variable of the specified
* name already exist?
*/
procPtr = envPtr->procPtr;
if (procPtr == NULL) {
/*
* Compiling a non-body script: give it read access to the LVT in the
* current localCache
*/
LocalCache *cachePtr = envPtr->iPtr->varFramePtr->localCachePtr;
const char *localName;
Tcl_Obj **varNamePtr;
int len;
if (!cachePtr || !name) {
return -1;
}
varNamePtr = &cachePtr->varName0;
for (i=0; i < cachePtr->numVars; varNamePtr++, i++) {
if (*varNamePtr) {
localName = TclGetString(*varNamePtr);
len = (*varNamePtr)->length;
if ((len == nameBytes) && !strncmp(name, localName, len)) {
return i;
}
}
}
return -1;
}
if (name != NULL) {
int localCt = procPtr->numCompiledLocals;
localPtr = procPtr->firstLocalPtr;
for (i = 0; i < localCt; i++) {
if (!TclIsVarTemporary(localPtr)) {
char *localName = localPtr->name;
if ((nameBytes == localPtr->nameLength) &&
(strncmp(name, localName, nameBytes) == 0)) {
return i;
}
}
localPtr = localPtr->nextPtr;
}
}
/*
* Create a new variable if appropriate.
*/
if (create || (name == NULL)) {
localVar = procPtr->numCompiledLocals;
localPtr = (CompiledLocal *)ckalloc(offsetof(CompiledLocal, name) + nameBytes + 1);
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
procPtr->lastLocalPtr->nextPtr = localPtr;
procPtr->lastLocalPtr = localPtr;
}
localPtr->nextPtr = NULL;
|
| ︙ | ︙ | |||
3067 3068 3069 3070 3071 3072 3073 |
*/
void
TclExpandCodeArray(
void *envArgPtr) /* Points to the CompileEnv whose code array
* must be enlarged. */
{
| | | | | | | 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 |
*/
void
TclExpandCodeArray(
void *envArgPtr) /* Points to the CompileEnv whose code array
* must be enlarged. */
{
CompileEnv *envPtr = (CompileEnv *)envArgPtr;
/* The CompileEnv containing the code array to
* be doubled in size. */
/*
* envPtr->codeNext is equal to envPtr->codeEnd. The currently defined
* code bytes are stored between envPtr->codeStart and envPtr->codeNext-1
* [inclusive].
*/
size_t currBytes = envPtr->codeNext - envPtr->codeStart;
size_t newBytes = 2 * (envPtr->codeEnd - envPtr->codeStart);
if (envPtr->mallocedCodeArray) {
envPtr->codeStart = (unsigned char *)ckrealloc(envPtr->codeStart, newBytes);
} else {
/*
* envPtr->codeStart isn't a ckalloc'd pointer, so we must code a
* ckrealloc equivalent for ourselves.
*/
unsigned char *newPtr = (unsigned char *)ckalloc(newBytes);
memcpy(newPtr, envPtr->codeStart, currBytes);
envPtr->codeStart = newPtr;
envPtr->mallocedCodeArray = 1;
}
envPtr->codeNext = envPtr->codeStart + currBytes;
|
| ︙ | ︙ | |||
3148 3149 3150 3151 3152 3153 3154 |
size_t currElems = envPtr->cmdMapEnd;
size_t newElems = 2 * currElems;
size_t currBytes = currElems * sizeof(CmdLocation);
size_t newBytes = newElems * sizeof(CmdLocation);
if (envPtr->mallocedCmdMap) {
| | | | | | 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 |
size_t currElems = envPtr->cmdMapEnd;
size_t newElems = 2 * currElems;
size_t currBytes = currElems * sizeof(CmdLocation);
size_t newBytes = newElems * sizeof(CmdLocation);
if (envPtr->mallocedCmdMap) {
envPtr->cmdMapPtr = (CmdLocation *)ckrealloc(envPtr->cmdMapPtr, newBytes);
} else {
/*
* envPtr->cmdMapPtr isn't a ckalloc'd pointer, so we must code a
* ckrealloc equivalent for ourselves.
*/
CmdLocation *newPtr = (CmdLocation *)ckalloc(newBytes);
memcpy(newPtr, envPtr->cmdMapPtr, currBytes);
envPtr->cmdMapPtr = newPtr;
envPtr->mallocedCmdMap = 1;
}
envPtr->cmdMapEnd = newElems;
}
|
| ︙ | ︙ | |||
3273 3274 3275 3276 3277 3278 3279 | * to eclPtr->loc[eclPtr->nuloc-1] (inclusive). */ size_t currElems = eclPtr->nloc; size_t newElems = (currElems ? 2*currElems : 1); size_t newBytes = newElems * sizeof(ECL); | | | | | | 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 |
* to eclPtr->loc[eclPtr->nuloc-1] (inclusive).
*/
size_t currElems = eclPtr->nloc;
size_t newElems = (currElems ? 2*currElems : 1);
size_t newBytes = newElems * sizeof(ECL);
eclPtr->loc = (ECL *)ckrealloc(eclPtr->loc, newBytes);
eclPtr->nloc = newElems;
}
ePtr = &eclPtr->loc[eclPtr->nuloc];
ePtr->srcOffset = srcOffset;
ePtr->line = (int *)ckalloc(numWords * sizeof(int));
ePtr->next = (int **)ckalloc(numWords * sizeof(int *));
ePtr->nline = numWords;
wwlines = (int *)ckalloc(numWords * sizeof(int));
last = cmd;
wordLine = line;
wordNext = clNext;
for (wordIdx=0 ; wordIdx<numWords;
wordIdx++, tokenPtr += tokenPtr->numComponents + 1) {
TclAdvanceLines(&wordLine, last, tokenPtr->start);
|
| ︙ | ︙ | |||
3328 3329 3330 3331 3332 3333 3334 |
*
*----------------------------------------------------------------------
*/
int
TclCreateExceptRange(
ExceptionRangeType type, /* The kind of ExceptionRange desired. */
| | | | | | | | | | | 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 |
*
*----------------------------------------------------------------------
*/
int
TclCreateExceptRange(
ExceptionRangeType type, /* The kind of ExceptionRange desired. */
CompileEnv *envPtr)/* Points to CompileEnv for which to create a
* new ExceptionRange structure. */
{
ExceptionRange *rangePtr;
ExceptionAux *auxPtr;
int index = envPtr->exceptArrayNext;
if (index >= envPtr->exceptArrayEnd) {
/*
* Expand the ExceptionRange array. The currently allocated entries
* are stored between elements 0 and (envPtr->exceptArrayNext - 1)
* [inclusive].
*/
size_t currBytes =
envPtr->exceptArrayNext * sizeof(ExceptionRange);
size_t currBytes2 = envPtr->exceptArrayNext * sizeof(ExceptionAux);
int newElems = 2*envPtr->exceptArrayEnd;
size_t newBytes = newElems * sizeof(ExceptionRange);
size_t newBytes2 = newElems * sizeof(ExceptionAux);
if (envPtr->mallocedExceptArray) {
envPtr->exceptArrayPtr =
(ExceptionRange *)ckrealloc(envPtr->exceptArrayPtr, newBytes);
envPtr->exceptAuxArrayPtr =
(ExceptionAux *)ckrealloc(envPtr->exceptAuxArrayPtr, newBytes2);
} else {
/*
* envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must
* code a ckrealloc equivalent for ourselves.
*/
ExceptionRange *newPtr = (ExceptionRange *)ckalloc(newBytes);
ExceptionAux *newPtr2 = (ExceptionAux *)ckalloc(newBytes2);
memcpy(newPtr, envPtr->exceptArrayPtr, currBytes);
memcpy(newPtr2, envPtr->exceptAuxArrayPtr, currBytes2);
envPtr->exceptArrayPtr = newPtr;
envPtr->exceptAuxArrayPtr = newPtr2;
envPtr->mallocedExceptArray = 1;
}
|
| ︙ | ︙ | |||
3464 3465 3466 3467 3468 3469 3470 |
Tcl_Panic("trying to add 'break' fixup to full exception range");
}
if (++auxPtr->numBreakTargets > auxPtr->allocBreakTargets) {
auxPtr->allocBreakTargets *= 2;
auxPtr->allocBreakTargets += 2;
if (auxPtr->breakTargets) {
| | | | 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 |
Tcl_Panic("trying to add 'break' fixup to full exception range");
}
if (++auxPtr->numBreakTargets > auxPtr->allocBreakTargets) {
auxPtr->allocBreakTargets *= 2;
auxPtr->allocBreakTargets += 2;
if (auxPtr->breakTargets) {
auxPtr->breakTargets = (unsigned int *)ckrealloc(auxPtr->breakTargets,
sizeof(int) * auxPtr->allocBreakTargets);
} else {
auxPtr->breakTargets =
(unsigned int *)ckalloc(sizeof(int) * auxPtr->allocBreakTargets);
}
}
auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr);
TclEmitInstInt4(INST_JUMP4, 0, envPtr);
}
void
|
| ︙ | ︙ | |||
3490 3491 3492 3493 3494 3495 3496 |
Tcl_Panic("trying to add 'continue' fixup to full exception range");
}
if (++auxPtr->numContinueTargets > auxPtr->allocContinueTargets) {
auxPtr->allocContinueTargets *= 2;
auxPtr->allocContinueTargets += 2;
if (auxPtr->continueTargets) {
| | | | 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 |
Tcl_Panic("trying to add 'continue' fixup to full exception range");
}
if (++auxPtr->numContinueTargets > auxPtr->allocContinueTargets) {
auxPtr->allocContinueTargets *= 2;
auxPtr->allocContinueTargets += 2;
if (auxPtr->continueTargets) {
auxPtr->continueTargets = (unsigned int *)ckrealloc(auxPtr->continueTargets,
sizeof(int) * auxPtr->allocContinueTargets);
} else {
auxPtr->continueTargets =
(unsigned int *)ckalloc(sizeof(int) * auxPtr->allocContinueTargets);
}
}
auxPtr->continueTargets[auxPtr->numContinueTargets - 1] =
CurrentOffset(envPtr);
TclEmitInstInt4(INST_JUMP4, 0, envPtr);
}
|
| ︙ | ︙ | |||
3656 3657 3658 3659 3660 3661 3662 |
}
/*
* Drop the arrays we were holding the only reference to.
*/
if (auxPtr->breakTargets) {
| | | | 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 |
}
/*
* Drop the arrays we were holding the only reference to.
*/
if (auxPtr->breakTargets) {
ckfree(auxPtr->breakTargets);
auxPtr->breakTargets = NULL;
auxPtr->numBreakTargets = 0;
}
if (auxPtr->continueTargets) {
ckfree(auxPtr->continueTargets);
auxPtr->continueTargets = NULL;
auxPtr->numContinueTargets = 0;
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
3696 3697 3698 3699 3700 3701 3702 |
int
TclCreateAuxData(
ClientData clientData, /* The compilation auxiliary data to store in
* the new aux data record. */
const AuxDataType *typePtr, /* Pointer to the type to attach to this
* AuxData */
| | | | | | | | 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 |
int
TclCreateAuxData(
ClientData clientData, /* The compilation auxiliary data to store in
* the new aux data record. */
const AuxDataType *typePtr, /* Pointer to the type to attach to this
* AuxData */
CompileEnv *envPtr)/* Points to the CompileEnv for which a new
* aux data structure is to be allocated. */
{
int index; /* Index for the new AuxData structure. */
AuxData *auxDataPtr;
/* Points to the new AuxData structure */
index = envPtr->auxDataArrayNext;
if (index >= envPtr->auxDataArrayEnd) {
/*
* Expand the AuxData array. The currently allocated entries are
* stored between elements 0 and (envPtr->auxDataArrayNext - 1)
* [inclusive].
*/
size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
int newElems = 2*envPtr->auxDataArrayEnd;
size_t newBytes = newElems * sizeof(AuxData);
if (envPtr->mallocedAuxDataArray) {
envPtr->auxDataArrayPtr =
(AuxData *)ckrealloc(envPtr->auxDataArrayPtr, newBytes);
} else {
/*
* envPtr->auxDataArrayPtr isn't a ckalloc'd pointer, so we must
* code a ckrealloc equivalent for ourselves.
*/
AuxData *newPtr = (AuxData *)ckalloc(newBytes);
memcpy(newPtr, envPtr->auxDataArrayPtr, currBytes);
envPtr->auxDataArrayPtr = newPtr;
envPtr->mallocedAuxDataArray = 1;
}
envPtr->auxDataArrayEnd = newElems;
}
|
| ︙ | ︙ | |||
3759 3760 3761 3762 3763 3764 3765 | * The JumpFixupArray structure is initialized. * *---------------------------------------------------------------------- */ void TclInitJumpFixupArray( | | | 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 |
* The JumpFixupArray structure is initialized.
*
*----------------------------------------------------------------------
*/
void
TclInitJumpFixupArray(
JumpFixupArray *fixupArrayPtr)
/* Points to the JumpFixupArray structure to
* initialize. */
{
fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace;
fixupArrayPtr->next = 0;
fixupArrayPtr->end = JUMPFIXUP_INIT_ENTRIES - 1;
fixupArrayPtr->mallocedArray = 0;
|
| ︙ | ︙ | |||
3791 3792 3793 3794 3795 3796 3797 | * array to the new one. * *---------------------------------------------------------------------- */ void TclExpandJumpFixupArray( | | | | | | | 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 |
* array to the new one.
*
*----------------------------------------------------------------------
*/
void
TclExpandJumpFixupArray(
JumpFixupArray *fixupArrayPtr)
/* Points to the JumpFixupArray structure to
* enlarge. */
{
/*
* The currently allocated jump fixup entries are stored from fixup[0] up
* to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume
* fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd.
*/
size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
int newElems = 2*(fixupArrayPtr->end + 1);
size_t newBytes = newElems * sizeof(JumpFixup);
if (fixupArrayPtr->mallocedArray) {
fixupArrayPtr->fixup = (JumpFixup *)ckrealloc(fixupArrayPtr->fixup, newBytes);
} else {
/*
* fixupArrayPtr->fixup isn't a ckalloc'd pointer, so we must code a
* ckrealloc equivalent for ourselves.
*/
JumpFixup *newPtr = (JumpFixup *)ckalloc(newBytes);
memcpy(newPtr, fixupArrayPtr->fixup, currBytes);
fixupArrayPtr->fixup = newPtr;
fixupArrayPtr->mallocedArray = 1;
}
fixupArrayPtr->end = newElems;
}
|
| ︙ | ︙ | |||
3840 3841 3842 3843 3844 3845 3846 | * Allocated storage in the JumpFixupArray structure is freed. * *---------------------------------------------------------------------- */ void TclFreeJumpFixupArray( | | | | 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 |
* Allocated storage in the JumpFixupArray structure is freed.
*
*----------------------------------------------------------------------
*/
void
TclFreeJumpFixupArray(
JumpFixupArray *fixupArrayPtr)
/* Points to the JumpFixupArray structure to
* free. */
{
if (fixupArrayPtr->mallocedArray) {
ckfree(fixupArrayPtr->fixup);
}
}
/*
*----------------------------------------------------------------------
*
* TclEmitForwardJump --
|
| ︙ | ︙ | |||
3945 3946 3947 3948 3949 3950 3951 |
* describes the forward jump. */
int jumpDist, /* Jump distance to set in jump instr. */
int distThreshold) /* Maximum distance before the two byte jump
* is grown to five bytes. */
{
unsigned char *jumpPc, *p;
int firstCmd, lastCmd, firstRange, lastRange, k;
| | | 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 |
* describes the forward jump. */
int jumpDist, /* Jump distance to set in jump instr. */
int distThreshold) /* Maximum distance before the two byte jump
* is grown to five bytes. */
{
unsigned char *jumpPc, *p;
int firstCmd, lastCmd, firstRange, lastRange, k;
unsigned numBytes;
if (jumpDist <= distThreshold) {
jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset;
switch (jumpFixupPtr->jumpType) {
case TCL_UNCONDITIONAL_JUMP:
TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc);
break;
|
| ︙ | ︙ | |||
4287 4288 4289 4290 4291 4292 4293 |
static int
GetCmdLocEncodingSize(
CompileEnv *envPtr) /* Points to compilation environment structure
* containing the CmdLocation structure to
* encode. */
{
| | | 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 |
static int
GetCmdLocEncodingSize(
CompileEnv *envPtr) /* Points to compilation environment structure
* containing the CmdLocation structure to
* encode. */
{
CmdLocation *mapPtr = envPtr->cmdMapPtr;
int numCmds = envPtr->numCommands;
int codeDelta, codeLen, srcDelta, srcLen;
int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext;
/* The offsets in their respective byte
* sequences where the next encoded offset or
* length should go. */
int prevCodeOffset, prevSrcOffset, i;
|
| ︙ | ︙ | |||
4371 4372 4373 4374 4375 4376 4377 |
* encode. */
ByteCode *codePtr, /* ByteCode in which to encode envPtr's
* command location information. */
unsigned char *startPtr) /* Points to the first byte in codePtr's
* memory block where the location information
* is to be stored. */
{
| | | | | 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 |
* encode. */
ByteCode *codePtr, /* ByteCode in which to encode envPtr's
* command location information. */
unsigned char *startPtr) /* Points to the first byte in codePtr's
* memory block where the location information
* is to be stored. */
{
CmdLocation *mapPtr = envPtr->cmdMapPtr;
int numCmds = envPtr->numCommands;
unsigned char *p = startPtr;
int codeDelta, codeLen, srcDelta, srcLen, prevOffset;
int i;
/*
* Encode the code offset for each command as a sequence of deltas.
*/
codePtr->codeDeltaStart = p;
prevOffset = 0;
|
| ︙ | ︙ | |||
4489 4490 4491 4492 4493 4494 4495 |
void
RecordByteCodeStats(
ByteCode *codePtr) /* Points to ByteCode structure with info
* to add to accumulated statistics. */
{
Interp *iPtr = (Interp *) *codePtr->interpHandle;
| | | 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 |
void
RecordByteCodeStats(
ByteCode *codePtr) /* Points to ByteCode structure with info
* to add to accumulated statistics. */
{
Interp *iPtr = (Interp *) *codePtr->interpHandle;
ByteCodeStats *statsPtr;
if (iPtr == NULL) {
/* Avoid segfaulting in case we're called in a deleted interp */
return;
}
statsPtr = &(iPtr->stats);
|
| ︙ | ︙ |
Changes to generic/tclCompile.h.
| ︙ | ︙ | |||
83 84 85 86 87 88 89 |
* and continue "exceptions" cause jumps to
* appropriate PC offsets. */
CATCH_EXCEPTION_RANGE /* Exception's range is controlled by a catch
* command. Errors in the range cause a jump
* to a catch PC offset. */
} ExceptionRangeType;
| | | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 |
* and continue "exceptions" cause jumps to
* appropriate PC offsets. */
CATCH_EXCEPTION_RANGE /* Exception's range is controlled by a catch
* command. Errors in the range cause a jump
* to a catch PC offset. */
} ExceptionRangeType;
typedef struct ExceptionRange {
ExceptionRangeType type; /* The kind of ExceptionRange. */
int nestingLevel; /* Static depth of the exception range. Used
* to find the most deeply-nested range
* surrounding a PC at runtime. */
int codeOffset; /* Offset of the first instruction byte of the
* code range. */
int numCodeBytes; /* Number of bytes in the code range. */
|
| ︙ | ︙ | |||
158 159 160 161 162 163 164 | * Structure used to map between instruction pc and source locations. It * defines for each compiled Tcl command its code's starting offset and its * source's starting offset and length. Note that the code offset increases * monotonically: that is, the table is sorted in code offset order. The * source offset is not monotonic. */ | | | | | | 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 |
* Structure used to map between instruction pc and source locations. It
* defines for each compiled Tcl command its code's starting offset and its
* source's starting offset and length. Note that the code offset increases
* monotonically: that is, the table is sorted in code offset order. The
* source offset is not monotonic.
*/
typedef struct CmdLocation {
int codeOffset; /* Offset of first byte of command code. */
int numCodeBytes; /* Number of bytes for command's code. */
int srcOffset; /* Offset of first char of the command. */
int numSrcBytes; /* Number of command source chars. */
} CmdLocation;
/*
* TIP #280
* Structure to record additional location information for byte code. This
* information is internal and not saved. i.e. tbcload'ed code will not have
* this information. It records the lines for all words of all commands found
* in the byte code. The association with a ByteCode structure BC is done
* through the 'lineBCPtr' HashTable in Interp, keyed by the address of BC.
* Also recorded is information coming from the context, i.e. type of the
* frame and associated information, like the path of a sourced file.
*/
typedef struct ECL {
int srcOffset; /* Command location to find the entry. */
int nline; /* Number of words in the command */
int *line; /* Line information for all words in the
* command. */
int **next; /* Transient information used by the compiler
* for tracking of hidden continuation
* lines. */
} ECL;
typedef struct ExtCmdLoc {
int type; /* Context type. */
int start; /* Starting line for compiled script. Needed
* for the extended recompile check in
* tclCompileObj. */
Tcl_Obj *path; /* Path of the sourced file the command is
* in. */
ECL *loc; /* Command word locations (lines). */
|
| ︙ | ︙ | |||
213 214 215 216 217 218 219 | * * The following definitions declare the types of procedures that are called * to duplicate or free this auxiliary data when the containing ByteCode * objects are duplicated and freed. Pointers to these procedures are kept in * the AuxData structure. */ | | | | | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 | * * The following definitions declare the types of procedures that are called * to duplicate or free this auxiliary data when the containing ByteCode * objects are duplicated and freed. Pointers to these procedures are kept in * the AuxData structure. */ typedef ClientData (AuxDataDupProc) (ClientData clientData); typedef void (AuxDataFreeProc) (ClientData clientData); typedef void (AuxDataPrintProc)(ClientData clientData, Tcl_Obj *appendObj, struct ByteCode *codePtr, unsigned int pcOffset); /* * We define a separate AuxDataType struct to hold type-related information * for the AuxData structure. This separation makes it possible for clients * outside of the TCL core to manipulate (in a limited fashion!) AuxData; for |
| ︙ | ︙ | |||
413 414 415 416 417 418 419 |
typedef struct ByteCode {
TclHandle interpHandle; /* Handle for interpreter containing the
* compiled code. Commands and their compile
* procs are specific to an interpreter so the
* code emitted will depend on the
* interpreter. */
| | | | | 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 |
typedef struct ByteCode {
TclHandle interpHandle; /* Handle for interpreter containing the
* compiled code. Commands and their compile
* procs are specific to an interpreter so the
* code emitted will depend on the
* interpreter. */
unsigned int compileEpoch; /* Value of iPtr->compileEpoch when this
* ByteCode was compiled. Used to invalidate
* code when, e.g., commands with compile
* procs are redefined. */
Namespace *nsPtr; /* Namespace context in which this code was
* compiled. If the code is executed if a
* different namespace, it must be
* recompiled. */
unsigned int nsEpoch; /* Value of nsPtr->resolverEpoch when this
* ByteCode was compiled. Used to invalidate
* code when new namespace resolution rules
* are put into effect. */
unsigned int refCount; /* Reference count: set 1 when created plus 1
* for each execution of the code currently
* active. This structure can be freed when
* refCount becomes zero. */
unsigned int flags; /* flags describing state for the codebyte.
* this variable holds ORed values from the
* TCL_BYTECODE_ masks defined above */
const char *source; /* The source string from which this ByteCode
|
| ︙ | ︙ | |||
525 526 527 528 529 530 531 |
#define ByteCodeGetIntRep(objPtr, typePtr, codePtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), (typePtr)); \
| | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | | | | | | | | | | | | | | | | | | | | > > | | | | > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | > | | | | > | | > | | > | | | | | | | > | | > | > | | > | | | | | > | | | | | | | | > | | | | | | > | | | | | > | | | | > | | > | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 |
#define ByteCodeGetIntRep(objPtr, typePtr, codePtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), (typePtr)); \
(codePtr) = irPtr ? (ByteCode*)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
* Opcodes for the Tcl bytecode instructions. These must correspond to the
* entries in the table of instruction descriptions, tclInstructionTable, in
* tclCompile.c. Also, the order and number of the expression opcodes (e.g.,
* INST_LOR) must match the entries in the array operatorStrings in
* tclExecute.c.
*/
/* Opcodes 0 to 9 */
#define INST_DONE 0
#define INST_PUSH1 1
#define INST_PUSH4 2
#define INST_POP 3
#define INST_DUP 4
#define INST_STR_CONCAT1 5
#define INST_INVOKE_STK1 6
#define INST_INVOKE_STK4 7
#define INST_EVAL_STK 8
#define INST_EXPR_STK 9
/* Opcodes 10 to 23 */
#define INST_LOAD_SCALAR1 10
#define INST_LOAD_SCALAR4 11
#define INST_LOAD_SCALAR_STK 12
#define INST_LOAD_ARRAY1 13
#define INST_LOAD_ARRAY4 14
#define INST_LOAD_ARRAY_STK 15
#define INST_LOAD_STK 16
#define INST_STORE_SCALAR1 17
#define INST_STORE_SCALAR4 18
#define INST_STORE_SCALAR_STK 19
#define INST_STORE_ARRAY1 20
#define INST_STORE_ARRAY4 21
#define INST_STORE_ARRAY_STK 22
#define INST_STORE_STK 23
/* Opcodes 24 to 33 */
#define INST_INCR_SCALAR1 24
#define INST_INCR_SCALAR_STK 25
#define INST_INCR_ARRAY1 26
#define INST_INCR_ARRAY_STK 27
#define INST_INCR_STK 28
#define INST_INCR_SCALAR1_IMM 29
#define INST_INCR_SCALAR_STK_IMM 30
#define INST_INCR_ARRAY1_IMM 31
#define INST_INCR_ARRAY_STK_IMM 32
#define INST_INCR_STK_IMM 33
/* Opcodes 34 to 39 */
#define INST_JUMP1 34
#define INST_JUMP4 35
#define INST_JUMP_TRUE1 36
#define INST_JUMP_TRUE4 37
#define INST_JUMP_FALSE1 38
#define INST_JUMP_FALSE4 39
/* Opcodes 40 to 64 */
#define INST_LOR 40
#define INST_LAND 41
#define INST_BITOR 42
#define INST_BITXOR 43
#define INST_BITAND 44
#define INST_EQ 45
#define INST_NEQ 46
#define INST_LT 47
#define INST_GT 48
#define INST_LE 49
#define INST_GE 50
#define INST_LSHIFT 51
#define INST_RSHIFT 52
#define INST_ADD 53
#define INST_SUB 54
#define INST_MULT 55
#define INST_DIV 56
#define INST_MOD 57
#define INST_UPLUS 58
#define INST_UMINUS 59
#define INST_BITNOT 60
#define INST_LNOT 61
#define INST_CALL_BUILTIN_FUNC1 62
#define INST_CALL_FUNC1 63
#define INST_TRY_CVT_TO_NUMERIC 64
/* Opcodes 65 to 66 */
#define INST_BREAK 65
#define INST_CONTINUE 66
/* Opcodes 67 to 68 */
#define INST_FOREACH_START4 67 /* DEPRECATED */
#define INST_FOREACH_STEP4 68 /* DEPRECATED */
/* Opcodes 69 to 72 */
#define INST_BEGIN_CATCH4 69
#define INST_END_CATCH 70
#define INST_PUSH_RESULT 71
#define INST_PUSH_RETURN_CODE 72
/* Opcodes 73 to 78 */
#define INST_STR_EQ 73
#define INST_STR_NEQ 74
#define INST_STR_CMP 75
#define INST_STR_LEN 76
#define INST_STR_INDEX 77
#define INST_STR_MATCH 78
/* Opcodes 78 to 81 */
#define INST_LIST 79
#define INST_LIST_INDEX 80
#define INST_LIST_LENGTH 81
/* Opcodes 82 to 87 */
#define INST_APPEND_SCALAR1 82
#define INST_APPEND_SCALAR4 83
#define INST_APPEND_ARRAY1 84
#define INST_APPEND_ARRAY4 85
#define INST_APPEND_ARRAY_STK 86
#define INST_APPEND_STK 87
/* Opcodes 88 to 93 */
#define INST_LAPPEND_SCALAR1 88
#define INST_LAPPEND_SCALAR4 89
#define INST_LAPPEND_ARRAY1 90
#define INST_LAPPEND_ARRAY4 91
#define INST_LAPPEND_ARRAY_STK 92
#define INST_LAPPEND_STK 93
/* TIP #22 - LINDEX operator with flat arg list */
#define INST_LIST_INDEX_MULTI 94
/*
* TIP #33 - 'lset' command. Code gen also required a Forth-like
* OVER operation.
*/
#define INST_OVER 95
#define INST_LSET_LIST 96
#define INST_LSET_FLAT 97
/* TIP#90 - 'return' command. */
#define INST_RETURN_IMM 98
/* TIP#123 - exponentiation operator. */
#define INST_EXPON 99
/* TIP #157 - {*}... (word expansion) language syntax support. */
#define INST_EXPAND_START 100
#define INST_EXPAND_STKTOP 101
#define INST_INVOKE_EXPANDED 102
/*
* TIP #57 - 'lassign' command. Code generation requires immediate
* LINDEX and LRANGE operators.
*/
#define INST_LIST_INDEX_IMM 103
#define INST_LIST_RANGE_IMM 104
#define INST_START_CMD 105
#define INST_LIST_IN 106
#define INST_LIST_NOT_IN 107
#define INST_PUSH_RETURN_OPTIONS 108
#define INST_RETURN_STK 109
/*
* Dictionary (TIP#111) related commands.
*/
#define INST_DICT_GET 110
#define INST_DICT_SET 111
#define INST_DICT_UNSET 112
#define INST_DICT_INCR_IMM 113
#define INST_DICT_APPEND 114
#define INST_DICT_LAPPEND 115
#define INST_DICT_FIRST 116
#define INST_DICT_NEXT 117
#define INST_DICT_DONE 118
#define INST_DICT_UPDATE_START 119
#define INST_DICT_UPDATE_END 120
/*
* Instruction to support jumps defined by tables (instead of the classic
* [switch] technique of chained comparisons).
*/
#define INST_JUMP_TABLE 121
/*
* Instructions to support compilation of global, variable, upvar and
* [namespace upvar].
*/
#define INST_UPVAR 122
#define INST_NSUPVAR 123
#define INST_VARIABLE 124
/* Instruction to support compiling syntax error to bytecode */
#define INST_SYNTAX 125
/* Instruction to reverse N items on top of stack */
#define INST_REVERSE 126
/* regexp instruction */
#define INST_REGEXP 127
/* For [info exists] compilation */
#define INST_EXIST_SCALAR 128
#define INST_EXIST_ARRAY 129
#define INST_EXIST_ARRAY_STK 130
#define INST_EXIST_STK 131
/* For [subst] compilation */
#define INST_NOP 132
#define INST_RETURN_CODE_BRANCH 133
/* For [unset] compilation */
#define INST_UNSET_SCALAR 134
#define INST_UNSET_ARRAY 135
#define INST_UNSET_ARRAY_STK 136
#define INST_UNSET_STK 137
/* For [dict with], [dict exists], [dict create] and [dict merge] */
#define INST_DICT_EXPAND 138
#define INST_DICT_RECOMBINE_STK 139
#define INST_DICT_RECOMBINE_IMM 140
#define INST_DICT_EXISTS 141
#define INST_DICT_VERIFY 142
/* For [string map] and [regsub] compilation */
#define INST_STR_MAP 143
#define INST_STR_FIND 144
#define INST_STR_FIND_LAST 145
#define INST_STR_RANGE_IMM 146
#define INST_STR_RANGE 147
/* For operations to do with coroutines and other NRE-manipulators */
#define INST_YIELD 148
#define INST_COROUTINE_NAME 149
#define INST_TAILCALL 150
/* For compilation of basic information operations */
#define INST_NS_CURRENT 151
#define INST_INFO_LEVEL_NUM 152
#define INST_INFO_LEVEL_ARGS 153
#define INST_RESOLVE_COMMAND 154
/* For compilation relating to TclOO */
#define INST_TCLOO_SELF 155
#define INST_TCLOO_CLASS 156
#define INST_TCLOO_NS 157
#define INST_TCLOO_IS_OBJECT 158
/* For compilation of [array] subcommands */
#define INST_ARRAY_EXISTS_STK 159
#define INST_ARRAY_EXISTS_IMM 160
#define INST_ARRAY_MAKE_STK 161
#define INST_ARRAY_MAKE_IMM 162
#define INST_INVOKE_REPLACE 163
#define INST_LIST_CONCAT 164
#define INST_EXPAND_DROP 165
/* New foreach implementation */
#define INST_FOREACH_START 166
#define INST_FOREACH_STEP 167
#define INST_FOREACH_END 168
#define INST_LMAP_COLLECT 169
/* For compilation of [string trim] and related */
#define INST_STR_TRIM 170
#define INST_STR_TRIM_LEFT 171
#define INST_STR_TRIM_RIGHT 172
#define INST_CONCAT_STK 173
#define INST_STR_UPPER 174
#define INST_STR_LOWER 175
#define INST_STR_TITLE 176
#define INST_STR_REPLACE 177
#define INST_ORIGIN_COMMAND 178
#define INST_TCLOO_NEXT 179
#define INST_TCLOO_NEXT_CLASS 180
#define INST_YIELD_TO_INVOKE 181
#define INST_NUM_TYPE 182
#define INST_TRY_CVT_TO_BOOLEAN 183
#define INST_STR_CLASS 184
#define INST_LAPPEND_LIST 185
#define INST_LAPPEND_LIST_ARRAY 186
#define INST_LAPPEND_LIST_ARRAY_STK 187
#define INST_LAPPEND_LIST_STK 188
#define INST_CLOCK_READ 189
#define INST_DICT_GET_DEF 190
/* TIP 461 */
#define INST_STR_LT 191
#define INST_STR_GT 192
#define INST_STR_LE 193
#define INST_STR_GE 194
/* The last opcode */
#define LAST_INST_OPCODE 194
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
* code), total number of code bytes required (including operand bytes), and a
* description of the type of each operand. These operand types include signed
* and unsigned integers of length one and four bytes. The unsigned integers
* are used for indexes or for, e.g., the count of objects to push in a "push"
|
| ︙ | ︙ | |||
861 862 863 864 865 866 867 |
OPERAND_LIT4, /* Four byte unsigned index into table of
* literals. */
OPERAND_SCLS1 /* Index into tclStringClassTable. */
} InstOperandType;
typedef struct InstructionDesc {
const char *name; /* Name of instruction. */
| | | 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 |
OPERAND_LIT4, /* Four byte unsigned index into table of
* literals. */
OPERAND_SCLS1 /* Index into tclStringClassTable. */
} InstOperandType;
typedef struct InstructionDesc {
const char *name; /* Name of instruction. */
int numBytes; /* Total number of bytes for instruction. */
int stackEffect; /* The worst-case balance stack effect of the
* instruction, used for stack requirements
* computations. The value INT_MIN signals
* that the instruction's worst case effect is
* (1-opnd1). */
int numOperands; /* Number of operands. */
InstOperandType opTypes[MAX_INSTRUCTION_OPERANDS];
|
| ︙ | ︙ | |||
901 902 903 904 905 906 907 |
STR_CLASS_WORD, /* Unicode word (alphabetic, digit, connector
* punctuation) characters. */
STR_CLASS_XDIGIT /* Characters that can be used as digits in
* hexadecimal numbers ([0-9A-Fa-f]). */
} InstStringClassType;
typedef struct StringClassDesc {
| | | 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 |
STR_CLASS_WORD, /* Unicode word (alphabetic, digit, connector
* punctuation) characters. */
STR_CLASS_XDIGIT /* Characters that can be used as digits in
* hexadecimal numbers ([0-9A-Fa-f]). */
} InstStringClassType;
typedef struct StringClassDesc {
char name[8]; /* Name of the class. */
int (*comparator)(int); /* Function to test if a single unicode
* character is a member of the class. */
} StringClassDesc;
MODULE_SCOPE StringClassDesc const tclStringClassTable[];
/*
|
| ︙ | ︙ | |||
1019 1020 1021 1022 1023 1024 1025 |
/*
* 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 {
| | | 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 |
/*
* Structure used to hold information about a [dict update] command that is
* needed during program execution. These structures are stored in CompileEnv
* and ByteCode structures as auxiliary data.
*/
typedef struct {
int length; /* Size of array */
int varIndices[1]; /* 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;
|
| ︙ | ︙ | |||
1074 1075 1076 1077 1078 1079 1080 | CompileEnv *envPtr); MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, ExceptionAux *auxPtr); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script, | | | | | | | | | | | | | | | | | | | | | | | 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 |
CompileEnv *envPtr);
MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr,
ExceptionAux *auxPtr);
MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp,
Tcl_Token *tokenPtr, int count,
CompileEnv *envPtr);
MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script,
int numBytes, CompileEnv *envPtr, int optimize);
MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp,
Tcl_Token *tokenPtr, int numWords,
CompileEnv *envPtr);
MODULE_SCOPE void TclCompileInvocation(Tcl_Interp *interp,
Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords,
CompileEnv *envPtr);
MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp,
const char *script, int numBytes,
CompileEnv *envPtr);
MODULE_SCOPE void TclCompileSyntaxError(Tcl_Interp *interp,
CompileEnv *envPtr);
MODULE_SCOPE void TclCompileTokens(Tcl_Interp *interp,
Tcl_Token *tokenPtr, int count,
CompileEnv *envPtr);
MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp,
Tcl_Token *tokenPtr, CompileEnv *envPtr);
MODULE_SCOPE int TclCreateAuxData(ClientData clientData,
const AuxDataType *typePtr, CompileEnv *envPtr);
MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type,
CompileEnv *envPtr);
MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size);
MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes,
int length, unsigned int hash, int *newPtr,
Namespace *nsPtr, int flags,
LiteralEntry **globalPtrPtr);
MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr);
MODULE_SCOPE void TclDeleteLiteralTable(Tcl_Interp *interp,
LiteralTable *tablePtr);
MODULE_SCOPE void TclEmitForwardJump(CompileEnv *envPtr,
TclJumpType jumpType, JumpFixup *jumpFixupPtr);
MODULE_SCOPE void TclEmitInvoke(CompileEnv *envPtr, int opcode, ...);
MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc,
int catchOnly, ByteCode *codePtr);
MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp,
ByteCode *codePtr);
MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, unsigned int index);
MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars,
int create, CompileEnv *envPtr);
MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr,
JumpFixup *jumpFixupPtr, int jumpDist,
int distThreshold);
MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr);
MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr,
int before, int after, int *indexPtr);
MODULE_SCOPE ByteCode * TclInitByteCode(CompileEnv *envPtr);
MODULE_SCOPE ByteCode * TclInitByteCodeObj(Tcl_Obj *objPtr,
const Tcl_ObjType *typePtr, CompileEnv *envPtr);
MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp,
CompileEnv *envPtr, const char *string,
int numBytes, const CmdFrame *invoker, int word);
MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr);
MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr,
int returnCode, ExceptionAux **auxPtrPtr);
MODULE_SCOPE void TclAddLoopBreakFixup(CompileEnv *envPtr,
ExceptionAux *auxPtr);
MODULE_SCOPE void TclAddLoopContinueFixup(CompileEnv *envPtr,
ExceptionAux *auxPtr);
MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr,
int range);
#ifdef TCL_COMPILE_STATS
MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr);
MODULE_SCOPE int TclLog2(int value);
#endif
MODULE_SCOPE int TclLocalScalar(const char *bytes, int numBytes,
CompileEnv *envPtr);
MODULE_SCOPE int TclLocalScalarFromToken(Tcl_Token *tokenPtr,
CompileEnv *envPtr);
MODULE_SCOPE void TclOptimizeBytecode(void *envPtr);
#ifdef TCL_COMPILE_DEBUG
MODULE_SCOPE void TclPrintByteCodeObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
#endif
MODULE_SCOPE int TclPrintInstruction(ByteCode *codePtr,
const unsigned char *pc);
MODULE_SCOPE void TclPrintObject(FILE *outFile,
Tcl_Obj *objPtr, int maxChars);
MODULE_SCOPE void TclPrintSource(FILE *outFile,
const char *string, int maxChars);
MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp,
Tcl_Token *varTokenPtr, CompileEnv *envPtr,
int flags, int *localIndexPtr,
int *isScalarPtr);
MODULE_SCOPE void TclPreserveByteCode(ByteCode *codePtr);
MODULE_SCOPE void TclReleaseByteCode(ByteCode *codePtr);
MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr);
MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp,
const char *name, Namespace *nsPtr);
MODULE_SCOPE int TclSingleOpCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
MODULE_SCOPE int TclSortingOpCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
MODULE_SCOPE int TclVariadicOpCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
MODULE_SCOPE int TclNoIdentOpCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
#ifdef TCL_COMPILE_DEBUG
MODULE_SCOPE void TclVerifyGlobalLiteralTable(Interp *iPtr);
MODULE_SCOPE void TclVerifyLocalLiteralTable(CompileEnv *envPtr);
#endif
MODULE_SCOPE int TclWordKnownAtCompileTime(Tcl_Token *tokenPtr,
Tcl_Obj *valuePtr);
MODULE_SCOPE void TclLogCommandInfo(Tcl_Interp *interp,
const char *script, const char *command,
int length, const unsigned char *pc,
Tcl_Obj **tosPtr);
MODULE_SCOPE Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp,
const unsigned char *pc, Tcl_Obj **tosPtr);
MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst);
MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[], int isLambda);
/*
*----------------------------------------------------------------
* Macros and flag values used by Tcl bytecode compilation and execution
* modules inside the Tcl core but not used outside.
*----------------------------------------------------------------
*/
/*
* Simplified form to access AuxData.
*
* ClientData TclFetchAuxData(CompileEng *envPtr, int index);
*/
#define TclFetchAuxData(envPtr, index) \
(envPtr)->auxDataArrayPtr[(index)].clientData
#define LITERAL_ON_HEAP 0x01
#define LITERAL_CMD_NAME 0x02
|
| ︙ | ︙ | |||
1379 1380 1381 1382 1383 1384 1385 |
* CompileEnv. The ANSI C "prototype" for this macro is:
*
* void TclEmitPush(int objIndex, CompileEnv *envPtr);
*/
#define TclEmitPush(objIndex, envPtr) \
do { \
| | | 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 |
* CompileEnv. The ANSI C "prototype" for this macro is:
*
* void TclEmitPush(int objIndex, CompileEnv *envPtr);
*/
#define TclEmitPush(objIndex, envPtr) \
do { \
int _objIndexCopy = (objIndex); \
if (_objIndexCopy <= 255) { \
TclEmitInstInt1(INST_PUSH1, _objIndexCopy, (envPtr)); \
} else { \
TclEmitInstInt4(INST_PUSH4, _objIndexCopy, (envPtr)); \
} \
} while (0)
|
| ︙ | ︙ | |||
1524 1525 1526 1527 1528 1529 1530 |
TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
(envPtr));
/*
* Convenience macros for use when pushing literals. The ANSI C "prototype" for
* these macros are:
*
* static void PushLiteral(CompileEnv *envPtr,
| | | | | 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 |
TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \
(envPtr));
/*
* Convenience macros for use when pushing literals. The ANSI C "prototype" for
* these macros are:
*
* static void PushLiteral(CompileEnv *envPtr,
* const char *string, int length);
* static void PushStringLiteral(CompileEnv *envPtr,
* const char *string);
*/
#define PushLiteral(envPtr, string, length) \
TclEmitPush(TclRegisterLiteral(envPtr, string, length, 0), (envPtr))
#define PushStringLiteral(envPtr, string) \
PushLiteral(envPtr, string, (int) (sizeof(string "") - 1))
/*
* Macro to advance to the next token; it is more mnemonic than the address
* arithmetic that it replaces. The ANSI C "prototype" for this macro is:
*
* static Tcl_Token * TokenAfter(Tcl_Token *tokenPtr);
*/
#define TokenAfter(tokenPtr) \
((tokenPtr) + ((tokenPtr)->numComponents + 1))
/*
* Macro to get the offset to the next instruction to be issued. The ANSI C
* "prototype" for this macro is:
*
* static int CurrentOffset(CompileEnv *envPtr);
*/
#define CurrentOffset(envPtr) \
((envPtr)->codeNext - (envPtr)->codeStart)
/*
* Note: the exceptDepth is a bit of a misnomer: TEBC only needs the
|
| ︙ | ︙ | |||
1800 1801 1802 1803 1804 1805 1806 |
#define TCL_DTRACE_DEBUG_LOG() \
int tclDTraceDebugEnabled = TCL_DTRACE_DEBUG_LOG_ENABLED; \
int tclDTraceDebugIndent = 0; \
FILE *tclDTraceDebugLog = NULL; \
void TclDTraceOpenDebugLog(void) { \
char n[35]; \
| | | | 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 |
#define TCL_DTRACE_DEBUG_LOG() \
int tclDTraceDebugEnabled = TCL_DTRACE_DEBUG_LOG_ENABLED; \
int tclDTraceDebugIndent = 0; \
FILE *tclDTraceDebugLog = NULL; \
void TclDTraceOpenDebugLog(void) { \
char n[35]; \
sprintf(n, "/tmp/tclDTraceDebug-%lu.log", \
(unsigned long) getpid()); \
tclDTraceDebugLog = fopen(n, "a"); \
}
#define TclDTraceDbgMsg(p, m, ...) \
do { \
if (tclDTraceDebugEnabled) { \
int _l, _t = 0; \
|
| ︙ | ︙ |
Changes to generic/tclConfig.c.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 | /* * A ClientData struct for the QueryConfig command. Store the three bits * of data we need; the package name for which we store a config dict, * the (Tcl_Interp *) in which it is stored, and the encoding. */ | | | < < | > < < | 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 |
/*
* A ClientData struct for the QueryConfig command. Store the three bits
* of data we need; the package name for which we store a config dict,
* the (Tcl_Interp *) in which it is stored, and the encoding.
*/
typedef struct QCCD {
Tcl_Obj *pkg;
Tcl_Interp *interp;
char *encoding;
} QCCD;
/*
* Static functions in this file:
*/
static Tcl_ObjCmdProc QueryConfigObjCmd;
static Tcl_CmdDeleteProc QueryConfigDelete;
static Tcl_InterpDeleteProc ConfigDictDeleteProc;
static Tcl_Obj * GetConfigDict(Tcl_Interp *interp);
/*
*----------------------------------------------------------------------
*
* Tcl_RegisterConfig --
*
* See TIP#59 for details on what this function does.
|
| ︙ | ︙ | |||
75 76 77 78 79 80 81 |
const Tcl_Config *configuration, /* Embedded configuration. */
const char *valEncoding) /* Name of the encoding used to store the
* configuration values, ASCII, thus UTF-8. */
{
Tcl_Obj *pDB, *pkgDict;
Tcl_DString cmdName;
const Tcl_Config *cfg;
| | | | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 |
const Tcl_Config *configuration, /* Embedded configuration. */
const char *valEncoding) /* Name of the encoding used to store the
* configuration values, ASCII, thus UTF-8. */
{
Tcl_Obj *pDB, *pkgDict;
Tcl_DString cmdName;
const Tcl_Config *cfg;
QCCD *cdPtr = (QCCD *)ckalloc(sizeof(QCCD));
cdPtr->interp = interp;
if (valEncoding) {
cdPtr->encoding = (char *)ckalloc(strlen(valEncoding)+1);
strcpy(cdPtr->encoding, valEncoding);
} else {
cdPtr->encoding = NULL;
}
cdPtr->pkg = Tcl_NewStringObj(pkgName, -1);
/*
|
| ︙ | ︙ | |||
195 196 197 198 199 200 201 |
static int
QueryConfigObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
struct Tcl_Obj *const *objv)
{
| | < | | 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 |
static int
QueryConfigObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
struct Tcl_Obj *const *objv)
{
QCCD *cdPtr = (QCCD *)clientData;
Tcl_Obj *pkgName = cdPtr->pkg;
Tcl_Obj *pDB, *pkgDict, *val, *listPtr;
int n, index;
static const char *const subcmdStrings[] = {
"get", "list", NULL
};
enum subcmds {
CFG_GET, CFG_LIST
};
Tcl_DString conv;
|
| ︙ | ︙ | |||
258 259 260 261 262 263 264 | return TCL_ERROR; } } /* * Value is stored as-is in a byte array, see Bug [9b2e636361], * so we have to decode it first. */ | | | | | | 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 |
return TCL_ERROR;
}
}
/*
* Value is stored as-is in a byte array, see Bug [9b2e636361],
* so we have to decode it first.
*/
value = (const char *) Tcl_GetByteArrayFromObj(val, &n);
value = Tcl_ExternalToUtfDString(venc, value, n, &conv);
Tcl_SetObjResult(interp, Tcl_NewStringObj(value,
Tcl_DStringLength(&conv)));
Tcl_DStringFree(&conv);
return TCL_OK;
case CFG_LIST:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_DictObjSize(interp, pkgDict, &n);
listPtr = Tcl_NewListObj(n, NULL);
if (!listPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"insufficient memory to create list", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
}
if (n) {
Tcl_DictSearch s;
Tcl_Obj *key;
int done;
for (Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done);
!done; Tcl_DictObjNext(&s, &key, NULL, &done)) {
Tcl_ListObjAppendElement(NULL, listPtr, key);
|
| ︙ | ︙ | |||
323 324 325 326 327 328 329 |
*-------------------------------------------------------------------------
*/
static void
QueryConfigDelete(
ClientData clientData)
{
| | | | | 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 |
*-------------------------------------------------------------------------
*/
static void
QueryConfigDelete(
ClientData clientData)
{
QCCD *cdPtr = (QCCD *)clientData;
Tcl_Obj *pkgName = cdPtr->pkg;
Tcl_Obj *pDB = GetConfigDict(cdPtr->interp);
Tcl_DictObjRemove(NULL, pDB, pkgName);
Tcl_DecrRefCount(pkgName);
if (cdPtr->encoding) {
ckfree(cdPtr->encoding);
}
ckfree(cdPtr);
}
/*
*-------------------------------------------------------------------------
*
* GetConfigDict --
*
|
| ︙ | ︙ | |||
356 357 358 359 360 361 362 |
*-------------------------------------------------------------------------
*/
static Tcl_Obj *
GetConfigDict(
Tcl_Interp *interp)
{
| | | 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 |
*-------------------------------------------------------------------------
*/
static Tcl_Obj *
GetConfigDict(
Tcl_Interp *interp)
{
Tcl_Obj *pDB = (Tcl_Obj *)Tcl_GetAssocData(interp, ASSOC_KEY, NULL);
if (pDB == NULL) {
pDB = Tcl_NewDictObj();
Tcl_IncrRefCount(pDB);
Tcl_SetAssocData(interp, ASSOC_KEY, ConfigDictDeleteProc, pDB);
}
|
| ︙ | ︙ | |||
389 390 391 392 393 394 395 |
*
*----------------------------------------------------------------------
*/
static void
ConfigDictDeleteProc(
ClientData clientData, /* Pointer to Tcl_Obj. */
| | < < | | 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 |
*
*----------------------------------------------------------------------
*/
static void
ConfigDictDeleteProc(
ClientData clientData, /* Pointer to Tcl_Obj. */
TCL_UNUSED(Tcl_Interp *))
{
Tcl_DecrRefCount((Tcl_Obj *)clientData);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclDTrace.d.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclDTrace.d -- * * Tcl DTrace provider. * * Copyright (c) 2007-2008 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. */ typedef struct Tcl_Obj Tcl_Obj; | < | | | | | | | | | | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 |
/*
* tclDTrace.d --
*
* Tcl DTrace provider.
*
* Copyright (c) 2007-2008 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.
*/
typedef struct Tcl_Obj Tcl_Obj;
/*
* Tcl DTrace probes
*/
provider tcl {
/***************************** proc probes *****************************/
/*
* tcl*:::proc-entry probe
* triggered immediately before proc bytecode execution
* arg0: proc name (string)
* arg1: number of arguments (int)
* arg2: array of proc argument objects (Tcl_Obj**)
*/
probe proc__entry(const char *name, int objc, struct Tcl_Obj **objv);
/*
* tcl*:::proc-return probe
* triggered immediately after proc bytecode execution
* arg0: proc name (string)
* arg1: return code (int)
*/
probe proc__return(const char *name, int code);
/*
* tcl*:::proc-result probe
* triggered after proc-return probe and result processing
* arg0: proc name (string)
* arg1: return code (int)
* arg2: proc result (string)
* arg3: proc result object (Tcl_Obj*)
*/
probe proc__result(const char *name, int code, const char *result,
struct Tcl_Obj *resultobj);
/*
* tcl*:::proc-args probe
* triggered before proc-entry probe, gives access to string
* representation of proc arguments
* arg0: proc name (string)
* arg1-arg9: proc arguments or NULL (strings)
*/
probe proc__args(const char *name, const char *arg1, const char *arg2,
const char *arg3, const char *arg4, const char *arg5,
const char *arg6, const char *arg7, const char *arg8,
const char *arg9);
/*
* tcl*:::proc-info probe
* triggered before proc-entry probe, gives access to TIP 280
* information for the proc invocation (i.e. [info frame 0])
* arg0: TIP 280 cmd (string)
* arg1: TIP 280 type (string)
* arg2: TIP 280 proc (string)
* arg3: TIP 280 file (string)
* arg4: TIP 280 line (int)
* arg5: TIP 280 level (int)
* arg6: TclOO method (string)
* arg7: TclOO class/object (string)
*/
probe proc__info(const char *cmd, const char *type, const char *proc,
const char *file, int line, int level, const char *method,
const char *class);
/***************************** cmd probes ******************************/
/*
* tcl*:::cmd-entry probe
* triggered immediately before commmand execution
* arg0: command name (string)
* arg1: number of arguments (int)
* arg2: array of command argument objects (Tcl_Obj**)
*/
probe cmd__entry(const char *name, int objc, struct Tcl_Obj **objv);
/*
* tcl*:::cmd-return probe
* triggered immediately after commmand execution
* arg0: command name (string)
* arg1: return code (int)
*/
probe cmd__return(const char *name, int code);
/*
* tcl*:::cmd-result probe
* triggered after cmd-return probe and result processing
* arg0: command name (string)
* arg1: return code (int)
* arg2: command result (string)
* arg3: command result object (Tcl_Obj*)
*/
probe cmd__result(const char *name, int code, const char *result,
struct Tcl_Obj *resultobj);
/*
* tcl*:::cmd-args probe
* triggered before cmd-entry probe, gives access to string
* representation of command arguments
* arg0: command name (string)
* arg1-arg9: command arguments or NULL (strings)
*/
probe cmd__args(const char *name, const char *arg1, const char *arg2,
const char *arg3, const char *arg4, const char *arg5,
const char *arg6, const char *arg7, const char *arg8,
const char *arg9);
/*
* tcl*:::cmd-info probe
* triggered before cmd-entry probe, gives access to TIP 280
* information for the command invocation (i.e. [info frame 0])
* arg0: TIP 280 cmd (string)
* arg1: TIP 280 type (string)
* arg2: TIP 280 proc (string)
* arg3: TIP 280 file (string)
* arg4: TIP 280 line (int)
* arg5: TIP 280 level (int)
* arg6: TclOO method (string)
* arg7: TclOO class/object (string)
*/
probe cmd__info(const char *cmd, const char *type, const char *proc,
const char *file, int line, int level, const char *method,
const char *class);
/***************************** inst probes *****************************/
/*
* tcl*:::inst-start probe
* triggered immediately before execution of a bytecode
* arg0: bytecode name (string)
* arg1: depth of stack (int)
* arg2: top of stack (Tcl_Obj**)
*/
probe inst__start(const char *name, int depth, struct Tcl_Obj **stack);
/*
* tcl*:::inst-done probe
* triggered immediately after execution of a bytecode
* arg0: bytecode name (string)
* arg1: depth of stack (int)
* arg2: top of stack (Tcl_Obj**)
*/
probe inst__done(const char *name, int depth, struct Tcl_Obj **stack);
/***************************** obj probes ******************************/
/*
* tcl*:::obj-create probe
* triggered immediately after a new Tcl_Obj has been created
* arg0: object created (Tcl_Obj*)
*/
|
| ︙ | ︙ | |||
159 160 161 162 163 164 165 |
/***************************** tcl probes ******************************/
/*
* tcl*:::tcl-probe probe
* triggered when the ::tcl::dtrace command is called
* arg0-arg9: command arguments (strings)
*/
| | | | | | | | | | 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 |
/***************************** tcl probes ******************************/
/*
* tcl*:::tcl-probe probe
* triggered when the ::tcl::dtrace command is called
* arg0-arg9: command arguments (strings)
*/
probe tcl__probe(const char *arg0, const char *arg1, const char *arg2,
const char *arg3, const char *arg4, const char *arg5,
const char *arg6, const char *arg7, const char *arg8,
const char *arg9);
};
/*
* Tcl types and constants for use in DTrace scripts
*/
typedef struct Tcl_ObjType {
const char *name;
void *freeIntRepProc;
void *dupIntRepProc;
void *updateStringProc;
void *setFromAnyProc;
} Tcl_ObjType;
struct Tcl_Obj {
int refCount;
char *bytes;
int length;
const Tcl_ObjType *typePtr;
union {
long longValue;
double doubleValue;
void *otherValuePtr;
int64_t wideValue;
struct {
void *ptr1;
|
| ︙ | ︙ |
Changes to generic/tclDate.c.
| ︙ | ︙ | |||
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 |
* Bison generates several labels that happen to be unused. MS Visual C++
* doesn't like that, and complains. Tell it to shut up.
*/
#ifdef _MSC_VER
#pragma warning( disable : 4102 )
#endif /* _MSC_VER */
/*
* yyparse will accept a 'struct DateInfo' as its parameter; that's where the
* parsed fields will be returned.
*/
typedef struct DateInfo {
Tcl_Obj* messages; /* Error messages */
const char* separatrix; /* String separating messages */
time_t dateYear;
time_t dateMonth;
time_t dateDay;
int dateHaveDate;
time_t dateHour;
time_t dateMinutes;
time_t dateSeconds;
| > > > > > > > > > > > | | 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 |
* Bison generates several labels that happen to be unused. MS Visual C++
* doesn't like that, and complains. Tell it to shut up.
*/
#ifdef _MSC_VER
#pragma warning( disable : 4102 )
#endif /* _MSC_VER */
/*
* Meridian: am, pm, or 24-hour style.
*/
typedef enum _MERIDIAN {
MERam, MERpm, MER24
} MERIDIAN;
/*
* yyparse will accept a 'struct DateInfo' as its parameter; that's where the
* parsed fields will be returned.
*/
typedef struct DateInfo {
Tcl_Obj* messages; /* Error messages */
const char* separatrix; /* String separating messages */
time_t dateYear;
time_t dateMonth;
time_t dateDay;
int dateHaveDate;
time_t dateHour;
time_t dateMinutes;
time_t dateSeconds;
MERIDIAN dateMeridian;
int dateHaveTime;
time_t dateTimezone;
int dateDSTmode;
int dateHaveZone;
time_t dateRelMonth;
|
| ︙ | ︙ | |||
134 135 136 137 138 139 140 |
const char *dateStart;
const char *dateInput;
time_t *dateRelPointer;
int dateDigitCount;
} DateInfo;
| | | | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 |
const char *dateStart;
const char *dateInput;
time_t *dateRelPointer;
int dateDigitCount;
} DateInfo;
#define YYMALLOC ckalloc
#define YYFREE(x) (ckfree((void*) (x)))
#define yyDSTmode (info->dateDSTmode)
#define yyDayOrdinal (info->dateDayOrdinal)
#define yyDayNumber (info->dateDayNumber)
#define yyMonthOrdinal (info->dateMonthOrdinal)
#define yyHaveDate (info->dateHaveDate)
#define yyHaveDay (info->dateHaveDay)
|
| ︙ | ︙ | |||
194 195 196 197 198 199 200 |
/*
* Daylight-savings mode: on, off, or not yet known.
*/
typedef enum _DSTMODE {
DSTon, DSToff, DSTmaybe
} DSTMODE;
| < < < < < < < < < < < | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 |
/*
* Daylight-savings mode: on, off, or not yet known.
*/
typedef enum _DSTMODE {
DSTon, DSToff, DSTmaybe
} DSTMODE;
# ifndef YY_NULLPTR
# if defined __cplusplus && 201103L <= __cplusplus
# define YY_NULLPTR nullptr
# else
# define YY_NULLPTR 0
# endif
|
| ︙ | ︙ | |||
2545 2546 2547 2548 2549 2550 2551 |
}
static int
LookupWord(
YYSTYPE* yylvalPtr,
char *buff)
{
| | | | | 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 |
}
static int
LookupWord(
YYSTYPE* yylvalPtr,
char *buff)
{
char *p;
char *q;
const TABLE *tp;
int i, abbrev;
/*
* Make it lowercase.
*/
Tcl_UtfToLower(buff);
|
| ︙ | ︙ | |||
2670 2671 2672 2673 2674 2675 2676 |
static int
TclDatelex(
YYSTYPE* yylvalPtr,
YYLTYPE* location,
DateInfo *info)
{
| | | | | 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 |
static int
TclDatelex(
YYSTYPE* yylvalPtr,
YYLTYPE* location,
DateInfo *info)
{
char c;
char *p;
char buff[20];
int Count;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
while (TclIsSpaceProcM(*yyInput)) {
yyInput++;
}
if (isdigit(UCHAR(c = *yyInput))) { /* INTL: digit */
/*
* Convert the string into a number; count the number of digits.
*/
|
| ︙ | ︙ | |||
2740 2741 2742 2743 2744 2745 2746 |
}
} while (Count > 0);
}
}
int
TclClockOldscanObjCmd(
| | | | 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 |
}
} while (Count > 0);
}
}
int
TclClockOldscanObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of paraneters */
Tcl_Obj *const *objv) /* Parameters */
{
Tcl_Obj *result, *resultElement;
int yr, mo, da;
DateInfo dateInfo;
DateInfo* info = &dateInfo;
int status;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 1, objv,
"stringToParse baseYear baseMonth baseDay" );
return TCL_ERROR;
}
yyInput = Tcl_GetString( objv[1] );
dateInfo.dateStart = yyInput;
yyHaveDate = 0;
if (Tcl_GetIntFromObj(interp, objv[2], &yr) != TCL_OK
|| Tcl_GetIntFromObj(interp, objv[3], &mo) != TCL_OK
|| Tcl_GetIntFromObj(interp, objv[4], &da) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
2844 2845 2846 2847 2848 2849 2850 |
return TCL_ERROR;
}
result = Tcl_NewObj();
resultElement = Tcl_NewObj();
if (yyHaveDate) {
Tcl_ListObjAppendElement(interp, resultElement,
| | | | | | | | | | | | | | | 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 |
return TCL_ERROR;
}
result = Tcl_NewObj();
resultElement = Tcl_NewObj();
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());
}
resultElement = Tcl_NewObj();
if (yyHaveZone) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) -yyTimezone));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(1 - yyDSTmode));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
resultElement = Tcl_NewObj();
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);
resultElement = Tcl_NewObj();
if (yyHaveDay && !yyHaveDate) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyDayOrdinal));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyDayNumber));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
resultElement = Tcl_NewObj();
if (yyHaveOrdinalMonth) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyMonthOrdinal));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyMonth));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
|
| ︙ | ︙ |
Changes to generic/tclDecls.h.
| ︙ | ︙ | |||
55 56 57 58 59 60 61 | /* 1 */ EXTERN const char * Tcl_PkgRequireEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 2 */ EXTERN TCL_NORETURN void Tcl_Panic(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 3 */ | | | | | | | | | | 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 | /* 1 */ EXTERN const char * Tcl_PkgRequireEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 2 */ EXTERN TCL_NORETURN void Tcl_Panic(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 3 */ EXTERN char * Tcl_Alloc(unsigned int size); /* 4 */ EXTERN void Tcl_Free(char *ptr); /* 5 */ EXTERN char * Tcl_Realloc(char *ptr, unsigned int size); /* 6 */ EXTERN char * Tcl_DbCkalloc(unsigned int size, const char *file, int line); /* 7 */ EXTERN void Tcl_DbCkfree(char *ptr, const char *file, int line); /* 8 */ EXTERN char * Tcl_DbCkrealloc(char *ptr, unsigned int size, const char *file, int line); #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 9 */ EXTERN void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, ClientData clientData); #endif /* UNIX */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 9 */ EXTERN void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, ClientData clientData); #endif /* MACOSX */ #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ /* 10 */ EXTERN void Tcl_DeleteFileHandler(int fd); #endif /* UNIX */ #ifdef MAC_OSX_TCL /* MACOSX */ /* 10 */ |
| ︙ | ︙ | |||
99 100 101 102 103 104 105 | /* 14 */ EXTERN int Tcl_AppendAllObjTypes(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 15 */ EXTERN void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...); /* 16 */ EXTERN void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes, | | | > > > | | > > > | | > | > > > > | | 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 |
/* 14 */
EXTERN int Tcl_AppendAllObjTypes(Tcl_Interp *interp,
Tcl_Obj *objPtr);
/* 15 */
EXTERN void Tcl_AppendStringsToObj(Tcl_Obj *objPtr, ...);
/* 16 */
EXTERN void Tcl_AppendToObj(Tcl_Obj *objPtr, const char *bytes,
int length);
/* 17 */
EXTERN Tcl_Obj * Tcl_ConcatObj(int objc, Tcl_Obj *const objv[]);
/* 18 */
EXTERN int Tcl_ConvertToType(Tcl_Interp *interp,
Tcl_Obj *objPtr, const Tcl_ObjType *typePtr);
/* 19 */
EXTERN void Tcl_DbDecrRefCount(Tcl_Obj *objPtr, const char *file,
int line);
/* 20 */
EXTERN void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file,
int line);
/* 21 */
EXTERN int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file,
int line);
/* 22 */
TCL_DEPRECATED("No longer in use, changed to macro")
Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, const char *file,
int line);
/* 23 */
EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes,
int length, const char *file, int line);
/* 24 */
EXTERN Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue,
const char *file, int line);
/* 25 */
EXTERN Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv,
const char *file, int line);
/* 26 */
TCL_DEPRECATED("No longer in use, changed to macro")
Tcl_Obj * Tcl_DbNewLongObj(long longValue, const char *file,
int line);
/* 27 */
EXTERN Tcl_Obj * Tcl_DbNewObj(const char *file, int line);
/* 28 */
EXTERN Tcl_Obj * Tcl_DbNewStringObj(const char *bytes, int length,
const char *file, int line);
/* 29 */
EXTERN Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr);
/* 30 */
EXTERN void TclFreeObj(Tcl_Obj *objPtr);
/* 31 */
EXTERN int Tcl_GetBoolean(Tcl_Interp *interp, const char *src,
int *boolPtr);
/* 32 */
EXTERN int Tcl_GetBooleanFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, int *boolPtr);
/* 33 */
EXTERN unsigned char * Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr,
int *lengthPtr);
/* 34 */
EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src,
double *doublePtr);
/* 35 */
EXTERN int Tcl_GetDoubleFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, double *doublePtr);
/* 36 */
TCL_DEPRECATED("No longer in use, changed to macro")
int Tcl_GetIndexFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, const char *const *tablePtr,
const char *msg, int flags, int *indexPtr);
/* 37 */
EXTERN int Tcl_GetInt(Tcl_Interp *interp, const char *src,
int *intPtr);
/* 38 */
EXTERN int Tcl_GetIntFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, int *intPtr);
/* 39 */
EXTERN int Tcl_GetLongFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, long *longPtr);
/* 40 */
EXTERN CONST86 Tcl_ObjType * Tcl_GetObjType(const char *typeName);
/* 41 */
EXTERN char * Tcl_GetStringFromObj(Tcl_Obj *objPtr, int *lengthPtr);
/* 42 */
EXTERN void Tcl_InvalidateStringRep(Tcl_Obj *objPtr);
/* 43 */
EXTERN int Tcl_ListObjAppendList(Tcl_Interp *interp,
Tcl_Obj *listPtr, Tcl_Obj *elemListPtr);
|
| ︙ | ︙ | |||
185 186 187 188 189 190 191 | /* 47 */ EXTERN int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 48 */ EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); | | > > | | > > | > > | | > > | < | | > > | > > | | | > > > | > > > | | > > | > > | > | | | | | | | | | | | | > > > > > | | | > | | | | | | > | > | | < | > | > > | | 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 |
/* 47 */
EXTERN int Tcl_ListObjLength(Tcl_Interp *interp,
Tcl_Obj *listPtr, int *lengthPtr);
/* 48 */
EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp,
Tcl_Obj *listPtr, int first, int count,
int objc, Tcl_Obj *const objv[]);
/* 49 */
TCL_DEPRECATED("No longer in use, changed to macro")
Tcl_Obj * Tcl_NewBooleanObj(int boolValue);
/* 50 */
EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes,
int length);
/* 51 */
EXTERN Tcl_Obj * Tcl_NewDoubleObj(double doubleValue);
/* 52 */
TCL_DEPRECATED("No longer in use, changed to macro")
Tcl_Obj * Tcl_NewIntObj(int intValue);
/* 53 */
EXTERN Tcl_Obj * Tcl_NewListObj(int objc, Tcl_Obj *const objv[]);
/* 54 */
TCL_DEPRECATED("No longer in use, changed to macro")
Tcl_Obj * Tcl_NewLongObj(long longValue);
/* 55 */
EXTERN Tcl_Obj * Tcl_NewObj(void);
/* 56 */
EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, int length);
/* 57 */
TCL_DEPRECATED("No longer in use, changed to macro")
void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue);
/* 58 */
EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length);
/* 59 */
EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr,
const unsigned char *bytes, int length);
/* 60 */
EXTERN void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue);
/* 61 */
TCL_DEPRECATED("No longer in use, changed to macro")
void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue);
/* 62 */
EXTERN void Tcl_SetListObj(Tcl_Obj *objPtr, int objc,
Tcl_Obj *const objv[]);
/* 63 */
TCL_DEPRECATED("No longer in use, changed to macro")
void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue);
/* 64 */
EXTERN void Tcl_SetObjLength(Tcl_Obj *objPtr, int length);
/* 65 */
EXTERN void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes,
int length);
/* 66 */
TCL_DEPRECATED("No longer in use, changed to macro")
void Tcl_AddErrorInfo(Tcl_Interp *interp,
const char *message);
/* 67 */
TCL_DEPRECATED("No longer in use, changed to macro")
void Tcl_AddObjErrorInfo(Tcl_Interp *interp,
const char *message, int length);
/* 68 */
EXTERN void Tcl_AllowExceptions(Tcl_Interp *interp);
/* 69 */
EXTERN void Tcl_AppendElement(Tcl_Interp *interp,
const char *element);
/* 70 */
EXTERN void Tcl_AppendResult(Tcl_Interp *interp, ...);
/* 71 */
EXTERN Tcl_AsyncHandler Tcl_AsyncCreate(Tcl_AsyncProc *proc,
ClientData clientData);
/* 72 */
EXTERN void Tcl_AsyncDelete(Tcl_AsyncHandler async);
/* 73 */
EXTERN int Tcl_AsyncInvoke(Tcl_Interp *interp, int code);
/* 74 */
EXTERN void Tcl_AsyncMark(Tcl_AsyncHandler async);
/* 75 */
EXTERN int Tcl_AsyncReady(void);
/* 76 */
TCL_DEPRECATED("No longer in use, changed to macro")
void Tcl_BackgroundError(Tcl_Interp *interp);
/* 77 */
TCL_DEPRECATED("Use Tcl_UtfBackslash")
char Tcl_Backslash(const char *src, int *readPtr);
/* 78 */
EXTERN int Tcl_BadChannelOption(Tcl_Interp *interp,
const char *optionName,
const char *optionList);
/* 79 */
EXTERN void Tcl_CallWhenDeleted(Tcl_Interp *interp,
Tcl_InterpDeleteProc *proc,
ClientData clientData);
/* 80 */
EXTERN void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc,
ClientData clientData);
/* 81 */
EXTERN int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan);
/* 82 */
EXTERN int Tcl_CommandComplete(const char *cmd);
/* 83 */
EXTERN char * Tcl_Concat(int argc, const char *const *argv);
/* 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 *slave,
const char *slaveCmd, Tcl_Interp *target,
const char *targetCmd, int argc,
const char *const *argv);
/* 87 */
EXTERN int Tcl_CreateAliasObj(Tcl_Interp *slave,
const char *slaveCmd, 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 */
EXTERN void Tcl_CreateChannelHandler(Tcl_Channel chan, int mask,
Tcl_ChannelProc *proc, ClientData clientData);
/* 90 */
EXTERN void Tcl_CreateCloseHandler(Tcl_Channel chan,
Tcl_CloseProc *proc, ClientData clientData);
/* 91 */
EXTERN Tcl_Command Tcl_CreateCommand(Tcl_Interp *interp,
const char *cmdName, Tcl_CmdProc *proc,
ClientData clientData,
Tcl_CmdDeleteProc *deleteProc);
/* 92 */
EXTERN void Tcl_CreateEventSource(Tcl_EventSetupProc *setupProc,
Tcl_EventCheckProc *checkProc,
ClientData clientData);
/* 93 */
EXTERN void Tcl_CreateExitHandler(Tcl_ExitProc *proc,
ClientData clientData);
/* 94 */
EXTERN Tcl_Interp * Tcl_CreateInterp(void);
/* 95 */
TCL_DEPRECATED("")
void Tcl_CreateMathFunc(Tcl_Interp *interp,
const char *name, int numArgs,
Tcl_ValueType *argTypes, Tcl_MathProc *proc,
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_CreateSlave(Tcl_Interp *interp,
const char *slaveName, 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);
/* 100 */
EXTERN void Tcl_DeleteAssocData(Tcl_Interp *interp,
const char *name);
/* 101 */
EXTERN void Tcl_DeleteChannelHandler(Tcl_Channel chan,
Tcl_ChannelProc *proc, ClientData clientData);
/* 102 */
EXTERN void Tcl_DeleteCloseHandler(Tcl_Channel chan,
Tcl_CloseProc *proc, ClientData clientData);
/* 103 */
EXTERN int Tcl_DeleteCommand(Tcl_Interp *interp,
const char *cmdName);
/* 104 */
EXTERN int Tcl_DeleteCommandFromToken(Tcl_Interp *interp,
Tcl_Command command);
/* 105 */
EXTERN void Tcl_DeleteEvents(Tcl_EventDeleteProc *proc,
ClientData clientData);
/* 106 */
EXTERN void Tcl_DeleteEventSource(Tcl_EventSetupProc *setupProc,
Tcl_EventCheckProc *checkProc,
ClientData clientData);
/* 107 */
EXTERN void Tcl_DeleteExitHandler(Tcl_ExitProc *proc,
ClientData clientData);
/* 108 */
EXTERN void Tcl_DeleteHashEntry(Tcl_HashEntry *entryPtr);
/* 109 */
EXTERN void Tcl_DeleteHashTable(Tcl_HashTable *tablePtr);
/* 110 */
EXTERN void Tcl_DeleteInterp(Tcl_Interp *interp);
/* 111 */
EXTERN void Tcl_DetachPids(int numPids, Tcl_Pid *pidPtr);
/* 112 */
EXTERN void Tcl_DeleteTimerHandler(Tcl_TimerToken token);
/* 113 */
EXTERN void Tcl_DeleteTrace(Tcl_Interp *interp, Tcl_Trace trace);
/* 114 */
EXTERN void Tcl_DontCallWhenDeleted(Tcl_Interp *interp,
Tcl_InterpDeleteProc *proc,
ClientData clientData);
/* 115 */
EXTERN int Tcl_DoOneEvent(int flags);
/* 116 */
EXTERN void Tcl_DoWhenIdle(Tcl_IdleProc *proc,
ClientData clientData);
/* 117 */
EXTERN char * Tcl_DStringAppend(Tcl_DString *dsPtr,
const char *bytes, int length);
/* 118 */
EXTERN char * Tcl_DStringAppendElement(Tcl_DString *dsPtr,
const char *element);
/* 119 */
EXTERN void Tcl_DStringEndSublist(Tcl_DString *dsPtr);
/* 120 */
EXTERN void Tcl_DStringFree(Tcl_DString *dsPtr);
/* 121 */
EXTERN void Tcl_DStringGetResult(Tcl_Interp *interp,
Tcl_DString *dsPtr);
/* 122 */
EXTERN void Tcl_DStringInit(Tcl_DString *dsPtr);
/* 123 */
EXTERN void Tcl_DStringResult(Tcl_Interp *interp,
Tcl_DString *dsPtr);
/* 124 */
EXTERN void Tcl_DStringSetLength(Tcl_DString *dsPtr, int length);
/* 125 */
EXTERN void Tcl_DStringStartSublist(Tcl_DString *dsPtr);
/* 126 */
EXTERN int Tcl_Eof(Tcl_Channel chan);
/* 127 */
EXTERN const char * Tcl_ErrnoId(void);
/* 128 */
EXTERN const char * Tcl_ErrnoMsg(int err);
/* 129 */
EXTERN int Tcl_Eval(Tcl_Interp *interp, const char *script);
/* 130 */
EXTERN int Tcl_EvalFile(Tcl_Interp *interp,
const char *fileName);
/* 131 */
TCL_DEPRECATED("No longer in use, changed to macro")
int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
/* 132 */
EXTERN void Tcl_EventuallyFree(ClientData clientData,
Tcl_FreeProc *freeProc);
/* 133 */
EXTERN TCL_NORETURN void Tcl_Exit(int status);
/* 134 */
EXTERN int Tcl_ExposeCommand(Tcl_Interp *interp,
const char *hiddenCmdToken,
const char *cmdName);
|
| ︙ | ︙ | |||
423 424 425 426 427 428 429 | /* 141 */ EXTERN int Tcl_ExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); /* 142 */ EXTERN int Tcl_ExprString(Tcl_Interp *interp, const char *expr); /* 143 */ EXTERN void Tcl_Finalize(void); | | > > | | | | | | 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 |
/* 141 */
EXTERN int Tcl_ExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
Tcl_Obj **resultPtrPtr);
/* 142 */
EXTERN int Tcl_ExprString(Tcl_Interp *interp, const char *expr);
/* 143 */
EXTERN void Tcl_Finalize(void);
/* 144 */
EXTERN void Tcl_FindExecutable(const char *argv0);
/* 145 */
EXTERN Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr,
Tcl_HashSearch *searchPtr);
/* 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 *slaveCmd,
Tcl_Interp **targetInterpPtr,
const char **targetCmdPtr, int *argcPtr,
const char ***argvPtr);
/* 149 */
EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp,
const char *slaveCmd,
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);
/* 151 */
EXTERN Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp,
const char *chanName, int *modePtr);
/* 152 */
EXTERN int Tcl_GetChannelBufferSize(Tcl_Channel chan);
/* 153 */
EXTERN int Tcl_GetChannelHandle(Tcl_Channel chan, int direction,
ClientData *handlePtr);
/* 154 */
EXTERN ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan);
/* 155 */
EXTERN int Tcl_GetChannelMode(Tcl_Channel chan);
/* 156 */
EXTERN const char * Tcl_GetChannelName(Tcl_Channel chan);
/* 157 */
EXTERN int Tcl_GetChannelOption(Tcl_Interp *interp,
Tcl_Channel chan, const char *optionName,
Tcl_DString *dsPtr);
/* 158 */
EXTERN CONST86 Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan);
/* 159 */
EXTERN int Tcl_GetCommandInfo(Tcl_Interp *interp,
const char *cmdName, Tcl_CmdInfo *infoPtr);
/* 160 */
EXTERN const char * Tcl_GetCommandName(Tcl_Interp *interp,
Tcl_Command command);
/* 161 */
|
| ︙ | ︙ | |||
490 491 492 493 494 495 496 | 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, const char *chanID, int forWriting, | | | | | | > | > > > | > > | > > > | 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 |
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,
const char *chanID, int forWriting,
int checkUsage, ClientData *filePtr);
#endif /* UNIX */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 167 */
EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp,
const char *chanID, int forWriting,
int checkUsage, ClientData *filePtr);
#endif /* MACOSX */
/* 168 */
EXTERN Tcl_PathType Tcl_GetPathType(const char *path);
/* 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_GetSlave(Tcl_Interp *interp,
const char *slaveName);
/* 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,
int flags);
/* 176 */
EXTERN const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags);
/* 177 */
EXTERN int Tcl_GlobalEval(Tcl_Interp *interp,
const char *command);
/* 178 */
TCL_DEPRECATED("No longer in use, changed to macro")
int Tcl_GlobalEvalObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
/* 179 */
EXTERN int Tcl_HideCommand(Tcl_Interp *interp,
const char *cmdName,
const char *hiddenCmdToken);
/* 180 */
EXTERN int Tcl_Init(Tcl_Interp *interp);
/* 181 */
|
| ︙ | ︙ | |||
543 544 545 546 547 548 549 | EXTERN char * Tcl_JoinPath(int argc, const char *const *argv, Tcl_DString *resultPtr); /* 187 */ EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, void *addr, int type); /* Slot 188 is reserved */ /* 189 */ | | | | 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 | EXTERN char * Tcl_JoinPath(int argc, const char *const *argv, Tcl_DString *resultPtr); /* 187 */ EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, void *addr, int type); /* Slot 188 is reserved */ /* 189 */ EXTERN Tcl_Channel Tcl_MakeFileChannel(ClientData handle, int mode); /* 190 */ EXTERN int Tcl_MakeSafe(Tcl_Interp *interp); /* 191 */ EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket); /* 192 */ EXTERN char * Tcl_Merge(int argc, const char *const *argv); /* 193 */ EXTERN Tcl_HashEntry * Tcl_NextHashEntry(Tcl_HashSearch *searchPtr); /* 194 */ EXTERN void Tcl_NotifyChannel(Tcl_Channel channel, int mask); /* 195 */ |
| ︙ | ︙ | |||
576 577 578 579 580 581 582 | EXTERN Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port, const char *address, const char *myaddr, int myport, int async); /* 200 */ EXTERN Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, | | | | < | 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 | EXTERN Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port, const char *address, const char *myaddr, int myport, int async); /* 200 */ EXTERN Tcl_Channel Tcl_OpenTcpServer(Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 201 */ EXTERN void Tcl_Preserve(ClientData data); /* 202 */ EXTERN void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst); /* 203 */ EXTERN int Tcl_PutEnv(const char *assignment); /* 204 */ EXTERN const char * Tcl_PosixError(Tcl_Interp *interp); /* 205 */ EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position); /* 206 */ EXTERN int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead); /* 207 */ EXTERN void Tcl_ReapDetachedProcs(void); /* 208 */ EXTERN int Tcl_RecordAndEval(Tcl_Interp *interp, const char *cmd, int flags); /* 209 */ EXTERN int Tcl_RecordAndEvalObj(Tcl_Interp *interp, |
| ︙ | ︙ | |||
615 616 617 618 619 620 621 | /* 213 */ EXTERN int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp, const char *text, const char *start); /* 214 */ EXTERN int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text, const char *pattern); /* 215 */ | | | | | | | > > | | > > | > > | > > > | > > > > | > > | > > | > > > > | > | | | > > > | > > > > > | | > > > > | > > > > > | | | < | > > > | > > > | > > > | > > > | > > > | > > > | > > | > > | | | | > | | | | | | | | | | | | > > | > > | | | | | | | | > | | | | > > | > > | > | > | | > | | | | | > > > | | | | | | | | > | | | | | | | > > | < > | | | > | | > | | | | | > | > | | 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 |
/* 213 */
EXTERN int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp,
const char *text, const char *start);
/* 214 */
EXTERN int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text,
const char *pattern);
/* 215 */
EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, int index,
const char **startPtr, const char **endPtr);
/* 216 */
EXTERN void Tcl_Release(ClientData clientData);
/* 217 */
EXTERN void Tcl_ResetResult(Tcl_Interp *interp);
/* 218 */
EXTERN int Tcl_ScanElement(const char *src, int *flagPtr);
/* 219 */
EXTERN int Tcl_ScanCountedElement(const char *src, int length,
int *flagPtr);
/* 220 */
TCL_DEPRECATED("")
int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode);
/* 221 */
EXTERN int Tcl_ServiceAll(void);
/* 222 */
EXTERN int Tcl_ServiceEvent(int flags);
/* 223 */
EXTERN void Tcl_SetAssocData(Tcl_Interp *interp,
const char *name, Tcl_InterpDeleteProc *proc,
ClientData clientData);
/* 224 */
EXTERN void Tcl_SetChannelBufferSize(Tcl_Channel chan, int sz);
/* 225 */
EXTERN int Tcl_SetChannelOption(Tcl_Interp *interp,
Tcl_Channel chan, const char *optionName,
const char *newValue);
/* 226 */
EXTERN int Tcl_SetCommandInfo(Tcl_Interp *interp,
const char *cmdName,
const Tcl_CmdInfo *infoPtr);
/* 227 */
EXTERN void Tcl_SetErrno(int err);
/* 228 */
EXTERN void Tcl_SetErrorCode(Tcl_Interp *interp, ...);
/* 229 */
EXTERN void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr);
/* 230 */
EXTERN void Tcl_SetPanicProc(
TCL_NORETURN1 Tcl_PanicProc *panicProc);
/* 231 */
EXTERN int Tcl_SetRecursionLimit(Tcl_Interp *interp, int depth);
/* 232 */
EXTERN void Tcl_SetResult(Tcl_Interp *interp, char *result,
Tcl_FreeProc *freeProc);
/* 233 */
EXTERN int Tcl_SetServiceMode(int mode);
/* 234 */
EXTERN void Tcl_SetObjErrorCode(Tcl_Interp *interp,
Tcl_Obj *errorObjPtr);
/* 235 */
EXTERN void Tcl_SetObjResult(Tcl_Interp *interp,
Tcl_Obj *resultObjPtr);
/* 236 */
EXTERN void Tcl_SetStdChannel(Tcl_Channel channel, int type);
/* 237 */
TCL_DEPRECATED("No longer in use, changed to macro")
const char * Tcl_SetVar(Tcl_Interp *interp, const char *varName,
const char *newValue, int flags);
/* 238 */
EXTERN const char * Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, const char *newValue,
int flags);
/* 239 */
EXTERN const char * Tcl_SignalId(int sig);
/* 240 */
EXTERN const char * Tcl_SignalMsg(int sig);
/* 241 */
EXTERN void Tcl_SourceRCFile(Tcl_Interp *interp);
/* 242 */
EXTERN int Tcl_SplitList(Tcl_Interp *interp,
const char *listStr, int *argcPtr,
const char ***argvPtr);
/* 243 */
EXTERN void Tcl_SplitPath(const char *path, int *argcPtr,
const char ***argvPtr);
/* 244 */
EXTERN void Tcl_StaticPackage(Tcl_Interp *interp,
const char *pkgName,
Tcl_PackageInitProc *initProc,
Tcl_PackageInitProc *safeInitProc);
/* 245 */
TCL_DEPRECATED("No longer in use, changed to macro")
int Tcl_StringMatch(const char *str, const char *pattern);
/* 246 */
TCL_DEPRECATED("")
int Tcl_TellOld(Tcl_Channel chan);
/* 247 */
TCL_DEPRECATED("No longer in use, changed to macro")
int Tcl_TraceVar(Tcl_Interp *interp, const char *varName,
int flags, Tcl_VarTraceProc *proc,
ClientData clientData);
/* 248 */
EXTERN int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags,
Tcl_VarTraceProc *proc,
ClientData clientData);
/* 249 */
EXTERN char * Tcl_TranslateFileName(Tcl_Interp *interp,
const char *name, Tcl_DString *bufferPtr);
/* 250 */
EXTERN int Tcl_Ungets(Tcl_Channel chan, const char *str,
int len, int atHead);
/* 251 */
EXTERN void Tcl_UnlinkVar(Tcl_Interp *interp,
const char *varName);
/* 252 */
EXTERN int Tcl_UnregisterChannel(Tcl_Interp *interp,
Tcl_Channel chan);
/* 253 */
TCL_DEPRECATED("No longer in use, changed to macro")
int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName,
int flags);
/* 254 */
EXTERN int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags);
/* 255 */
TCL_DEPRECATED("No longer in use, changed to macro")
void Tcl_UntraceVar(Tcl_Interp *interp,
const char *varName, int flags,
Tcl_VarTraceProc *proc,
ClientData clientData);
/* 256 */
EXTERN void Tcl_UntraceVar2(Tcl_Interp *interp,
const char *part1, const char *part2,
int flags, Tcl_VarTraceProc *proc,
ClientData clientData);
/* 257 */
EXTERN void Tcl_UpdateLinkedVar(Tcl_Interp *interp,
const char *varName);
/* 258 */
TCL_DEPRECATED("No longer in use, changed to macro")
int Tcl_UpVar(Tcl_Interp *interp, const char *frameName,
const char *varName, const char *localName,
int flags);
/* 259 */
EXTERN int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName,
const char *part1, const char *part2,
const char *localName, int flags);
/* 260 */
EXTERN int Tcl_VarEval(Tcl_Interp *interp, ...);
/* 261 */
TCL_DEPRECATED("No longer in use, changed to macro")
ClientData Tcl_VarTraceInfo(Tcl_Interp *interp,
const char *varName, int flags,
Tcl_VarTraceProc *procPtr,
ClientData prevClientData);
/* 262 */
EXTERN ClientData Tcl_VarTraceInfo2(Tcl_Interp *interp,
const char *part1, const char *part2,
int flags, Tcl_VarTraceProc *procPtr,
ClientData prevClientData);
/* 263 */
EXTERN int Tcl_Write(Tcl_Channel chan, const char *s, int slen);
/* 264 */
EXTERN void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[], const char *message);
/* 265 */
EXTERN int Tcl_DumpActiveMemory(const char *fileName);
/* 266 */
EXTERN void Tcl_ValidateAllMemory(const char *file, int line);
/* 267 */
TCL_DEPRECATED("see TIP #422")
void Tcl_AppendResultVA(Tcl_Interp *interp,
va_list argList);
/* 268 */
TCL_DEPRECATED("see TIP #422")
void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr,
va_list argList);
/* 269 */
EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr);
/* 270 */
EXTERN const char * Tcl_ParseVar(Tcl_Interp *interp, const char *start,
const char **termPtr);
/* 271 */
TCL_DEPRECATED("No longer in use, changed to macro")
const char * Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
const char *version, int exact);
/* 272 */
EXTERN const char * Tcl_PkgPresentEx(Tcl_Interp *interp,
const char *name, const char *version,
int exact, void *clientDataPtr);
/* 273 */
TCL_DEPRECATED("No longer in use, changed to macro")
int Tcl_PkgProvide(Tcl_Interp *interp, const char *name,
const char *version);
/* 274 */
TCL_DEPRECATED("No longer in use, changed to macro")
const char * Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
const char *version, int exact);
/* 275 */
TCL_DEPRECATED("see TIP #422")
void Tcl_SetErrorCodeVA(Tcl_Interp *interp,
va_list argList);
/* 276 */
TCL_DEPRECATED("see TIP #422")
int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList);
/* 277 */
EXTERN Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options);
/* 278 */
TCL_DEPRECATED("see TIP #422")
TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList);
/* 279 */
EXTERN void Tcl_GetVersion(int *major, int *minor,
int *patchLevel, int *type);
/* 280 */
EXTERN void Tcl_InitMemory(Tcl_Interp *interp);
/* 281 */
EXTERN Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp,
const Tcl_ChannelType *typePtr,
ClientData instanceData, int mask,
Tcl_Channel prevChan);
/* 282 */
EXTERN int Tcl_UnstackChannel(Tcl_Interp *interp,
Tcl_Channel chan);
/* 283 */
EXTERN Tcl_Channel Tcl_GetStackedChannel(Tcl_Channel chan);
/* 284 */
EXTERN void Tcl_SetMainLoop(Tcl_MainLoopProc *proc);
/* Slot 285 is reserved */
/* 286 */
EXTERN void Tcl_AppendObjToObj(Tcl_Obj *objPtr,
Tcl_Obj *appendObjPtr);
/* 287 */
EXTERN Tcl_Encoding Tcl_CreateEncoding(const Tcl_EncodingType *typePtr);
/* 288 */
EXTERN void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc,
ClientData clientData);
/* 289 */
EXTERN void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc,
ClientData clientData);
/* 290 */
EXTERN void Tcl_DiscardResult(Tcl_SavedResult *statePtr);
/* 291 */
EXTERN int Tcl_EvalEx(Tcl_Interp *interp, const char *script,
int numBytes, int flags);
/* 292 */
EXTERN int Tcl_EvalObjv(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[], int flags);
/* 293 */
EXTERN int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr,
int flags);
/* 294 */
EXTERN TCL_NORETURN void Tcl_ExitThread(int status);
/* 295 */
EXTERN int Tcl_ExternalToUtf(Tcl_Interp *interp,
Tcl_Encoding encoding, const char *src,
int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst,
int dstLen, int *srcReadPtr,
int *dstWrotePtr, int *dstCharsPtr);
/* 296 */
EXTERN char * Tcl_ExternalToUtfDString(Tcl_Encoding encoding,
const char *src, int srcLen,
Tcl_DString *dsPtr);
/* 297 */
EXTERN void Tcl_FinalizeThread(void);
/* 298 */
EXTERN void Tcl_FinalizeNotifier(ClientData clientData);
/* 299 */
EXTERN void Tcl_FreeEncoding(Tcl_Encoding encoding);
/* 300 */
EXTERN Tcl_ThreadId Tcl_GetCurrentThread(void);
/* 301 */
EXTERN Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name);
/* 302 */
EXTERN const char * Tcl_GetEncodingName(Tcl_Encoding encoding);
/* 303 */
EXTERN void Tcl_GetEncodingNames(Tcl_Interp *interp);
/* 304 */
EXTERN int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp,
Tcl_Obj *objPtr, const void *tablePtr,
int offset, const char *msg, int flags,
int *indexPtr);
/* 305 */
EXTERN void * Tcl_GetThreadData(Tcl_ThreadDataKey *keyPtr,
int size);
/* 306 */
EXTERN Tcl_Obj * Tcl_GetVar2Ex(Tcl_Interp *interp, const char *part1,
const char *part2, int flags);
/* 307 */
EXTERN ClientData Tcl_InitNotifier(void);
/* 308 */
EXTERN void Tcl_MutexLock(Tcl_Mutex *mutexPtr);
/* 309 */
EXTERN void Tcl_MutexUnlock(Tcl_Mutex *mutexPtr);
/* 310 */
EXTERN void Tcl_ConditionNotify(Tcl_Condition *condPtr);
/* 311 */
EXTERN void Tcl_ConditionWait(Tcl_Condition *condPtr,
Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr);
/* 312 */
EXTERN int Tcl_NumUtfChars(const char *src, int length);
/* 313 */
EXTERN int Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr,
int charsToRead, int appendFlag);
/* 314 */
EXTERN void Tcl_RestoreResult(Tcl_Interp *interp,
Tcl_SavedResult *statePtr);
/* 315 */
EXTERN void Tcl_SaveResult(Tcl_Interp *interp,
Tcl_SavedResult *statePtr);
/* 316 */
EXTERN int Tcl_SetSystemEncoding(Tcl_Interp *interp,
const char *name);
/* 317 */
EXTERN Tcl_Obj * Tcl_SetVar2Ex(Tcl_Interp *interp, const char *part1,
const char *part2, Tcl_Obj *newValuePtr,
int flags);
/* 318 */
EXTERN void Tcl_ThreadAlert(Tcl_ThreadId threadId);
/* 319 */
EXTERN void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId,
Tcl_Event *evPtr, Tcl_QueuePosition position);
/* 320 */
EXTERN int Tcl_UniCharAtIndex(const char *src, int index);
/* 321 */
EXTERN int Tcl_UniCharToLower(int ch);
/* 322 */
EXTERN int Tcl_UniCharToTitle(int ch);
/* 323 */
EXTERN int Tcl_UniCharToUpper(int ch);
/* 324 */
EXTERN int Tcl_UniCharToUtf(int ch, char *buf);
/* 325 */
EXTERN const char * Tcl_UtfAtIndex(const char *src, int index);
/* 326 */
EXTERN int Tcl_UtfCharComplete(const char *src, int length);
/* 327 */
EXTERN int Tcl_UtfBackslash(const char *src, int *readPtr,
char *dst);
/* 328 */
EXTERN const char * Tcl_UtfFindFirst(const char *src, int ch);
/* 329 */
EXTERN const char * Tcl_UtfFindLast(const char *src, int ch);
/* 330 */
EXTERN const char * Tcl_UtfNext(const char *src);
/* 331 */
EXTERN const char * Tcl_UtfPrev(const char *src, const char *start);
/* 332 */
EXTERN int Tcl_UtfToExternal(Tcl_Interp *interp,
Tcl_Encoding encoding, const char *src,
int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst,
int dstLen, int *srcReadPtr,
int *dstWrotePtr, int *dstCharsPtr);
/* 333 */
EXTERN char * Tcl_UtfToExternalDString(Tcl_Encoding encoding,
const char *src, int srcLen,
Tcl_DString *dsPtr);
/* 334 */
EXTERN int Tcl_UtfToLower(char *src);
/* 335 */
EXTERN int Tcl_UtfToTitle(char *src);
/* 336 */
EXTERN int Tcl_UtfToChar16(const char *src,
unsigned short *chPtr);
/* 337 */
EXTERN int Tcl_UtfToUpper(char *src);
/* 338 */
EXTERN int Tcl_WriteChars(Tcl_Channel chan, const char *src,
int srcLen);
/* 339 */
EXTERN int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr);
/* 340 */
EXTERN char * Tcl_GetString(Tcl_Obj *objPtr);
/* 341 */
TCL_DEPRECATED("Use Tcl_GetEncodingSearchPath")
const char * Tcl_GetDefaultEncodingDir(void);
/* 342 */
TCL_DEPRECATED("Use Tcl_SetEncodingSearchPath")
void Tcl_SetDefaultEncodingDir(const char *path);
/* 343 */
EXTERN void Tcl_AlertNotifier(ClientData clientData);
/* 344 */
EXTERN void Tcl_ServiceModeHook(int mode);
/* 345 */
EXTERN int Tcl_UniCharIsAlnum(int ch);
/* 346 */
EXTERN int Tcl_UniCharIsAlpha(int ch);
/* 347 */
EXTERN int Tcl_UniCharIsDigit(int ch);
/* 348 */
EXTERN int Tcl_UniCharIsLower(int ch);
/* 349 */
EXTERN int Tcl_UniCharIsSpace(int ch);
/* 350 */
EXTERN int Tcl_UniCharIsUpper(int ch);
/* 351 */
EXTERN int Tcl_UniCharIsWordChar(int ch);
/* 352 */
TCL_DEPRECATED("Use Tcl_GetCharLength")
int Tcl_UniCharLen(const Tcl_UniChar *uniStr);
/* 353 */
TCL_DEPRECATED("Use Tcl_UtfNcmp")
int Tcl_UniCharNcmp(const Tcl_UniChar *ucs,
const Tcl_UniChar *uct,
unsigned long numChars);
/* 354 */
EXTERN char * Tcl_Char16ToUtfDString(const unsigned short *uniStr,
int uniLength, Tcl_DString *dsPtr);
/* 355 */
EXTERN unsigned short * Tcl_UtfToChar16DString(const char *src, int length,
Tcl_DString *dsPtr);
/* 356 */
EXTERN Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp,
Tcl_Obj *patObj, int flags);
/* 357 */
TCL_DEPRECATED("Use Tcl_EvalTokensStandard")
Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp,
Tcl_Token *tokenPtr, int count);
/* 358 */
EXTERN void Tcl_FreeParse(Tcl_Parse *parsePtr);
/* 359 */
EXTERN void Tcl_LogCommandInfo(Tcl_Interp *interp,
const char *script, const char *command,
int length);
/* 360 */
EXTERN int Tcl_ParseBraces(Tcl_Interp *interp,
const char *start, int numBytes,
Tcl_Parse *parsePtr, int append,
const char **termPtr);
/* 361 */
EXTERN int Tcl_ParseCommand(Tcl_Interp *interp,
const char *start, int numBytes, int nested,
Tcl_Parse *parsePtr);
/* 362 */
EXTERN int Tcl_ParseExpr(Tcl_Interp *interp, const char *start,
int numBytes, Tcl_Parse *parsePtr);
/* 363 */
EXTERN int Tcl_ParseQuotedString(Tcl_Interp *interp,
const char *start, int numBytes,
Tcl_Parse *parsePtr, int append,
const char **termPtr);
/* 364 */
EXTERN int Tcl_ParseVarName(Tcl_Interp *interp,
const char *start, int numBytes,
Tcl_Parse *parsePtr, int append);
/* 365 */
EXTERN char * Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr);
/* 366 */
EXTERN int Tcl_Chdir(const char *dirName);
/* 367 */
EXTERN int Tcl_Access(const char *path, int mode);
/* 368 */
EXTERN int Tcl_Stat(const char *path, struct stat *bufPtr);
/* 369 */
EXTERN int Tcl_UtfNcmp(const char *s1, const char *s2,
unsigned long n);
/* 370 */
EXTERN int Tcl_UtfNcasecmp(const char *s1, const char *s2,
unsigned long n);
/* 371 */
EXTERN int Tcl_StringCaseMatch(const char *str,
const char *pattern, int nocase);
/* 372 */
EXTERN int Tcl_UniCharIsControl(int ch);
/* 373 */
EXTERN int Tcl_UniCharIsGraph(int ch);
/* 374 */
EXTERN int Tcl_UniCharIsPrint(int ch);
/* 375 */
EXTERN int Tcl_UniCharIsPunct(int ch);
/* 376 */
EXTERN int Tcl_RegExpExecObj(Tcl_Interp *interp,
Tcl_RegExp regexp, Tcl_Obj *textObj,
int offset, int nmatches, int flags);
/* 377 */
EXTERN void Tcl_RegExpGetInfo(Tcl_RegExp regexp,
Tcl_RegExpInfo *infoPtr);
/* 378 */
EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const Tcl_UniChar *unicode,
int numChars);
/* 379 */
EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr,
const Tcl_UniChar *unicode, int numChars);
/* 380 */
EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr);
/* 381 */
EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, int index);
/* 382 */
TCL_DEPRECATED("No longer in use, changed to macro")
Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr);
/* 383 */
EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last);
/* 384 */
TCL_DEPRECATED("Use Tcl_AppendStringsToObj")
void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr,
const Tcl_UniChar *unicode, int length);
/* 385 */
EXTERN int Tcl_RegExpMatchObj(Tcl_Interp *interp,
Tcl_Obj *textObj, Tcl_Obj *patternObj);
/* 386 */
EXTERN void Tcl_SetNotifier(Tcl_NotifierProcs *notifierProcPtr);
/* 387 */
EXTERN Tcl_Mutex * Tcl_GetAllocMutex(void);
/* 388 */
EXTERN int Tcl_GetChannelNames(Tcl_Interp *interp);
/* 389 */
EXTERN int Tcl_GetChannelNamesEx(Tcl_Interp *interp,
const char *pattern);
/* 390 */
EXTERN int Tcl_ProcObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
/* 391 */
EXTERN void Tcl_ConditionFinalize(Tcl_Condition *condPtr);
/* 392 */
EXTERN void Tcl_MutexFinalize(Tcl_Mutex *mutex);
/* 393 */
EXTERN int Tcl_CreateThread(Tcl_ThreadId *idPtr,
Tcl_ThreadCreateProc *proc,
ClientData clientData, int stackSize,
int flags);
/* 394 */
EXTERN int Tcl_ReadRaw(Tcl_Channel chan, char *dst,
int bytesToRead);
/* 395 */
EXTERN int Tcl_WriteRaw(Tcl_Channel chan, const char *src,
int srcLen);
/* 396 */
EXTERN Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan);
/* 397 */
EXTERN int Tcl_ChannelBuffered(Tcl_Channel chan);
/* 398 */
EXTERN const char * Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr);
/* 399 */
EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion(
const Tcl_ChannelType *chanTypePtr);
/* 400 */
EXTERN Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc(
const Tcl_ChannelType *chanTypePtr);
/* 401 */
TCL_DEPRECATED("Use Tcl_ChannelClose2Proc")
Tcl_DriverCloseProc * Tcl_ChannelCloseProc(
const Tcl_ChannelType *chanTypePtr);
/* 402 */
EXTERN Tcl_DriverClose2Proc * Tcl_ChannelClose2Proc(
const Tcl_ChannelType *chanTypePtr);
/* 403 */
EXTERN Tcl_DriverInputProc * Tcl_ChannelInputProc(
const Tcl_ChannelType *chanTypePtr);
/* 404 */
EXTERN Tcl_DriverOutputProc * Tcl_ChannelOutputProc(
const Tcl_ChannelType *chanTypePtr);
/* 405 */
TCL_DEPRECATED("Use Tcl_ChannelWideSeekProc")
Tcl_DriverSeekProc * Tcl_ChannelSeekProc(
const Tcl_ChannelType *chanTypePtr);
/* 406 */
EXTERN Tcl_DriverSetOptionProc * Tcl_ChannelSetOptionProc(
const Tcl_ChannelType *chanTypePtr);
/* 407 */
EXTERN Tcl_DriverGetOptionProc * Tcl_ChannelGetOptionProc(
const Tcl_ChannelType *chanTypePtr);
|
| ︙ | ︙ | |||
1116 1117 1118 1119 1120 1121 1122 | /* 416 */ EXTERN void Tcl_SpliceChannel(Tcl_Channel channel); /* 417 */ EXTERN void Tcl_ClearChannelHandlers(Tcl_Channel channel); /* 418 */ EXTERN int Tcl_IsChannelExisting(const char *channelName); /* 419 */ | > | | > > | | > > | > > | | | > | > | | | | | | < | > > > > > > | > > > | 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 |
/* 416 */
EXTERN void Tcl_SpliceChannel(Tcl_Channel channel);
/* 417 */
EXTERN void Tcl_ClearChannelHandlers(Tcl_Channel channel);
/* 418 */
EXTERN int Tcl_IsChannelExisting(const char *channelName);
/* 419 */
TCL_DEPRECATED("Use Tcl_UtfNcasecmp")
int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs,
const Tcl_UniChar *uct,
unsigned long numChars);
/* 420 */
TCL_DEPRECATED("Use Tcl_StringCaseMatch")
int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr,
const Tcl_UniChar *uniPattern, int nocase);
/* 421 */
EXTERN Tcl_HashEntry * Tcl_FindHashEntry(Tcl_HashTable *tablePtr,
const void *key);
/* 422 */
EXTERN Tcl_HashEntry * Tcl_CreateHashEntry(Tcl_HashTable *tablePtr,
const void *key, int *newPtr);
/* 423 */
EXTERN void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr,
int keyType, const Tcl_HashKeyType *typePtr);
/* 424 */
EXTERN void Tcl_InitObjHashTable(Tcl_HashTable *tablePtr);
/* 425 */
EXTERN ClientData Tcl_CommandTraceInfo(Tcl_Interp *interp,
const char *varName, int flags,
Tcl_CommandTraceProc *procPtr,
ClientData prevClientData);
/* 426 */
EXTERN int Tcl_TraceCommand(Tcl_Interp *interp,
const char *varName, int flags,
Tcl_CommandTraceProc *proc,
ClientData clientData);
/* 427 */
EXTERN void Tcl_UntraceCommand(Tcl_Interp *interp,
const char *varName, int flags,
Tcl_CommandTraceProc *proc,
ClientData clientData);
/* 428 */
EXTERN char * Tcl_AttemptAlloc(unsigned int size);
/* 429 */
EXTERN char * Tcl_AttemptDbCkalloc(unsigned int size,
const char *file, int line);
/* 430 */
EXTERN char * Tcl_AttemptRealloc(char *ptr, unsigned int size);
/* 431 */
EXTERN char * Tcl_AttemptDbCkrealloc(char *ptr, unsigned int size,
const char *file, int line);
/* 432 */
EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length);
/* 433 */
EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel);
/* 434 */
EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr,
int *lengthPtr);
/* 435 */
TCL_DEPRECATED("")
int Tcl_GetMathFuncInfo(Tcl_Interp *interp,
const char *name, int *numArgsPtr,
Tcl_ValueType **argTypesPtr,
Tcl_MathProc **procPtr,
ClientData *clientDataPtr);
/* 436 */
TCL_DEPRECATED("")
Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp,
const char *pattern);
/* 437 */
EXTERN Tcl_Obj * Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
int flags);
/* 438 */
EXTERN int Tcl_DetachChannel(Tcl_Interp *interp,
Tcl_Channel channel);
/* 439 */
|
| ︙ | ︙ | |||
1210 1211 1212 1213 1214 1215 1216 | /* 451 */ EXTERN int Tcl_FSFileAttrsGet(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 452 */ EXTERN int Tcl_FSFileAttrsSet(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr); /* 453 */ | | | 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 | /* 451 */ EXTERN int Tcl_FSFileAttrsGet(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 452 */ EXTERN int Tcl_FSFileAttrsSet(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr); /* 453 */ EXTERN const char *CONST86 * Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 454 */ EXTERN int Tcl_FSStat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); /* 455 */ EXTERN int Tcl_FSAccess(Tcl_Obj *pathPtr, int mode); /* 456 */ EXTERN Tcl_Channel Tcl_FSOpenFileChannel(Tcl_Interp *interp, |
| ︙ | ︙ | |||
1241 1242 1243 1244 1245 1246 1247 | /* 463 */ EXTERN Tcl_Obj * Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 464 */ EXTERN Tcl_Obj * Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc, Tcl_Obj *const objv[]); /* 465 */ | | | | | | | | | 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 | /* 463 */ EXTERN Tcl_Obj * Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 464 */ EXTERN Tcl_Obj * Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc, Tcl_Obj *const objv[]); /* 465 */ EXTERN ClientData Tcl_FSGetInternalRep(Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr); /* 466 */ EXTERN Tcl_Obj * Tcl_FSGetTranslatedPath(Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 467 */ EXTERN int Tcl_FSEvalFile(Tcl_Interp *interp, Tcl_Obj *fileName); /* 468 */ EXTERN Tcl_Obj * Tcl_FSNewNativePath( const Tcl_Filesystem *fromFilesystem, ClientData clientData); /* 469 */ EXTERN const void * Tcl_FSGetNativePath(Tcl_Obj *pathPtr); /* 470 */ EXTERN Tcl_Obj * Tcl_FSFileSystemInfo(Tcl_Obj *pathPtr); /* 471 */ EXTERN Tcl_Obj * Tcl_FSPathSeparator(Tcl_Obj *pathPtr); /* 472 */ EXTERN Tcl_Obj * Tcl_FSListVolumes(void); /* 473 */ EXTERN int Tcl_FSRegister(ClientData clientData, const Tcl_Filesystem *fsPtr); /* 474 */ EXTERN int Tcl_FSUnregister(const Tcl_Filesystem *fsPtr); /* 475 */ EXTERN ClientData Tcl_FSData(const Tcl_Filesystem *fsPtr); /* 476 */ EXTERN const char * Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 477 */ EXTERN CONST86 Tcl_Filesystem * Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr); /* 478 */ EXTERN Tcl_PathType Tcl_FSGetPathType(Tcl_Obj *pathPtr); /* 479 */ EXTERN int Tcl_OutputBuffered(Tcl_Channel chan); /* 480 */ EXTERN void Tcl_FSMountsChanged(const Tcl_Filesystem *fsPtr); /* 481 */ EXTERN int Tcl_EvalTokensStandard(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 482 */ EXTERN void Tcl_GetTime(Tcl_Time *timeBuf); /* 483 */ EXTERN Tcl_Trace Tcl_CreateObjTrace(Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc *objProc, ClientData clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 484 */ EXTERN int Tcl_GetCommandInfoFromToken(Tcl_Command token, Tcl_CmdInfo *infoPtr); /* 485 */ EXTERN int Tcl_SetCommandInfoFromToken(Tcl_Command token, const Tcl_CmdInfo *infoPtr); |
| ︙ | ︙ | |||
1357 1358 1359 1360 1361 1362 1363 | /* 505 */ EXTERN void Tcl_RegisterConfig(Tcl_Interp *interp, const char *pkgName, const Tcl_Config *configuration, const char *valEncoding); /* 506 */ EXTERN Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, | | | 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 | /* 505 */ EXTERN void Tcl_RegisterConfig(Tcl_Interp *interp, const char *pkgName, const Tcl_Config *configuration, const char *valEncoding); /* 506 */ EXTERN Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 507 */ EXTERN void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr); /* 508 */ EXTERN int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 509 */ |
| ︙ | ︙ | |||
1393 1394 1395 1396 1397 1398 1399 | Tcl_Obj *objPtr); /* 517 */ EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 518 */ EXTERN int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); | | > | | | 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 | Tcl_Obj *objPtr); /* 517 */ EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 518 */ EXTERN int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); /* 519 */ EXTERN Tcl_ExitProc * Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc); /* 520 */ EXTERN void Tcl_LimitAddHandler(Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 521 */ EXTERN void Tcl_LimitRemoveHandler(Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData); /* 522 */ EXTERN int Tcl_LimitReady(Tcl_Interp *interp); /* 523 */ EXTERN int Tcl_LimitCheck(Tcl_Interp *interp); /* 524 */ EXTERN int Tcl_LimitExceeded(Tcl_Interp *interp); /* 525 */ |
| ︙ | ︙ | |||
1485 1486 1487 1488 1489 1490 1491 | /* 551 */ EXTERN int Tcl_GetEnsembleNamespace(Tcl_Interp *interp, Tcl_Command token, Tcl_Namespace **namespacePtrPtr); /* 552 */ EXTERN void Tcl_SetTimeProc(Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, | | | | | | | | | | 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 | /* 551 */ EXTERN int Tcl_GetEnsembleNamespace(Tcl_Interp *interp, Tcl_Command token, Tcl_Namespace **namespacePtrPtr); /* 552 */ EXTERN void Tcl_SetTimeProc(Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, ClientData clientData); /* 553 */ EXTERN void Tcl_QueryTimeProc(Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, ClientData *clientData); /* 554 */ EXTERN Tcl_DriverThreadActionProc * Tcl_ChannelThreadActionProc( const Tcl_ChannelType *chanTypePtr); /* 555 */ EXTERN Tcl_Obj * Tcl_NewBignumObj(void *value); /* 556 */ EXTERN Tcl_Obj * Tcl_DbNewBignumObj(void *value, const char *file, int line); /* 557 */ EXTERN void Tcl_SetBignumObj(Tcl_Obj *obj, void *value); /* 558 */ EXTERN int Tcl_GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, void *value); /* 559 */ EXTERN int Tcl_TakeBignumFromObj(Tcl_Interp *interp, Tcl_Obj *obj, void *value); /* 560 */ EXTERN int Tcl_TruncateChannel(Tcl_Channel chan, Tcl_WideInt length); /* 561 */ EXTERN Tcl_DriverTruncateProc * Tcl_ChannelTruncateProc( const Tcl_ChannelType *chanTypePtr); /* 562 */ EXTERN void Tcl_SetChannelErrorInterp(Tcl_Interp *interp, Tcl_Obj *msg); /* 563 */ EXTERN void Tcl_GetChannelErrorInterp(Tcl_Interp *interp, Tcl_Obj **msg); /* 564 */ EXTERN void Tcl_SetChannelError(Tcl_Channel chan, Tcl_Obj *msg); /* 565 */ EXTERN void Tcl_GetChannelError(Tcl_Channel chan, Tcl_Obj **msg); /* 566 */ EXTERN int Tcl_InitBignumFromDouble(Tcl_Interp *interp, double initval, void *toInit); /* 567 */ EXTERN Tcl_Obj * Tcl_GetNamespaceUnknownHandler(Tcl_Interp *interp, Tcl_Namespace *nsPtr); /* 568 */ EXTERN int Tcl_SetNamespaceUnknownHandler(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *handlerPtr); /* 569 */ |
| ︙ | ︙ | |||
1550 1551 1552 1553 1554 1555 1556 | const char *name, int objc, Tcl_Obj *const objv[], void *clientDataPtr); /* 574 */ EXTERN void Tcl_AppendObjToErrorInfo(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 575 */ EXTERN void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, | | | | | > | > | | > | | 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 | const char *name, int objc, Tcl_Obj *const objv[], void *clientDataPtr); /* 574 */ EXTERN void Tcl_AppendObjToErrorInfo(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 575 */ EXTERN void Tcl_AppendLimitedToObj(Tcl_Obj *objPtr, const char *bytes, int length, int limit, const char *ellipsis); /* 576 */ EXTERN Tcl_Obj * Tcl_Format(Tcl_Interp *interp, const char *format, int objc, Tcl_Obj *const objv[]); /* 577 */ EXTERN int Tcl_AppendFormatToObj(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, int objc, Tcl_Obj *const objv[]); /* 578 */ EXTERN Tcl_Obj * Tcl_ObjPrintf(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 579 */ EXTERN void Tcl_AppendPrintfToObj(Tcl_Obj *objPtr, const char *format, ...) TCL_FORMAT_PRINTF(2, 3); /* 580 */ EXTERN int Tcl_CancelEval(Tcl_Interp *interp, Tcl_Obj *resultObjPtr, ClientData clientData, int flags); /* 581 */ EXTERN int Tcl_Canceled(Tcl_Interp *interp, int flags); /* 582 */ EXTERN int Tcl_CreatePipe(Tcl_Interp *interp, Tcl_Channel *rchan, Tcl_Channel *wchan, int flags); /* 583 */ EXTERN Tcl_Command Tcl_NRCreateCommand(Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 584 */ EXTERN int Tcl_NREvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 585 */ EXTERN int Tcl_NREvalObjv(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 586 */ EXTERN int Tcl_NRCmdSwap(Tcl_Interp *interp, Tcl_Command cmd, int objc, Tcl_Obj *const objv[], int flags); /* 587 */ EXTERN void Tcl_NRAddCallback(Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr, ClientData data0, ClientData data1, ClientData data2, ClientData data3); /* 588 */ EXTERN int Tcl_NRCallObjProc(Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, ClientData clientData, int objc, Tcl_Obj *const objv[]); /* 589 */ EXTERN unsigned Tcl_GetFSDeviceFromStat(const Tcl_StatBuf *statPtr); /* 590 */ EXTERN unsigned Tcl_GetFSInodeFromStat(const Tcl_StatBuf *statPtr); /* 591 */ EXTERN unsigned Tcl_GetModeFromStat(const Tcl_StatBuf *statPtr); /* 592 */ |
| ︙ | ︙ | |||
1639 1640 1641 1642 1643 1644 1645 | Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 605 */ EXTERN int Tcl_GetErrorLine(Tcl_Interp *interp); /* 606 */ EXTERN void Tcl_SetErrorLine(Tcl_Interp *interp, int lineNum); /* 607 */ EXTERN void Tcl_TransferResult(Tcl_Interp *sourceInterp, | | | | | | | 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 | Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 605 */ EXTERN int Tcl_GetErrorLine(Tcl_Interp *interp); /* 606 */ EXTERN void Tcl_SetErrorLine(Tcl_Interp *interp, int lineNum); /* 607 */ EXTERN void Tcl_TransferResult(Tcl_Interp *sourceInterp, int code, Tcl_Interp *targetInterp); /* 608 */ EXTERN int Tcl_InterpActive(Tcl_Interp *interp); /* 609 */ EXTERN void Tcl_BackgroundException(Tcl_Interp *interp, int code); /* 610 */ EXTERN int Tcl_ZlibDeflate(Tcl_Interp *interp, int format, Tcl_Obj *data, int level, Tcl_Obj *gzipHeaderDictObj); /* 611 */ EXTERN int Tcl_ZlibInflate(Tcl_Interp *interp, int format, Tcl_Obj *data, int buffersize, Tcl_Obj *gzipHeaderDictObj); /* 612 */ EXTERN unsigned int Tcl_ZlibCRC32(unsigned int crc, const unsigned char *buf, int len); /* 613 */ EXTERN unsigned int Tcl_ZlibAdler32(unsigned int adler, const unsigned char *buf, int len); /* 614 */ EXTERN int Tcl_ZlibStreamInit(Tcl_Interp *interp, int mode, int format, int level, Tcl_Obj *dictObj, Tcl_ZlibStream *zshandle); /* 615 */ EXTERN Tcl_Obj * Tcl_ZlibStreamGetCommandName(Tcl_ZlibStream zshandle); /* 616 */ EXTERN int Tcl_ZlibStreamEof(Tcl_ZlibStream zshandle); /* 617 */ EXTERN int Tcl_ZlibStreamChecksum(Tcl_ZlibStream zshandle); /* 618 */ EXTERN int Tcl_ZlibStreamPut(Tcl_ZlibStream zshandle, Tcl_Obj *data, int flush); /* 619 */ EXTERN int Tcl_ZlibStreamGet(Tcl_ZlibStream zshandle, Tcl_Obj *data, int count); /* 620 */ EXTERN int Tcl_ZlibStreamClose(Tcl_ZlibStream zshandle); /* 621 */ EXTERN int Tcl_ZlibStreamReset(Tcl_ZlibStream zshandle); /* 622 */ EXTERN void Tcl_SetStartupScript(Tcl_Obj *path, const char *encoding); |
| ︙ | ︙ | |||
1711 1712 1713 1714 1715 1716 1717 | Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 631 */ EXTERN Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, | | | | | > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 |
Tcl_ZlibStream zhandle,
Tcl_Obj *compressionDictionaryObj);
/* 631 */
EXTERN Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp,
const char *service, const char *host,
unsigned int flags,
Tcl_TcpAcceptProc *acceptProc,
ClientData callbackData);
/* 632 */
EXTERN int TclZipfs_Mount(Tcl_Interp *interp,
const char *mountPoint, const char *zipname,
const char *passwd);
/* 633 */
EXTERN int TclZipfs_Unmount(Tcl_Interp *interp,
const char *mountPoint);
/* 634 */
EXTERN Tcl_Obj * TclZipfs_TclLibrary(void);
/* 635 */
EXTERN int TclZipfs_MountBuffer(Tcl_Interp *interp,
const char *mountPoint, unsigned char *data,
size_t datalen, int copy);
/* 636 */
EXTERN void Tcl_FreeIntRep(Tcl_Obj *objPtr);
/* 637 */
EXTERN char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes,
unsigned int numBytes);
/* 638 */
EXTERN Tcl_ObjIntRep * Tcl_FetchIntRep(Tcl_Obj *objPtr,
const Tcl_ObjType *typePtr);
/* 639 */
EXTERN void Tcl_StoreIntRep(Tcl_Obj *objPtr,
const Tcl_ObjType *typePtr,
const Tcl_ObjIntRep *irPtr);
/* 640 */
EXTERN int Tcl_HasStringRep(Tcl_Obj *objPtr);
/* 641 */
EXTERN void Tcl_IncrRefCount(Tcl_Obj *objPtr);
/* 642 */
EXTERN void Tcl_DecrRefCount(Tcl_Obj *objPtr);
/* 643 */
EXTERN int Tcl_IsShared(Tcl_Obj *objPtr);
/* 644 */
EXTERN int Tcl_LinkArray(Tcl_Interp *interp,
const char *varName, void *addr, int type,
int size);
/* 645 */
EXTERN int Tcl_GetIntForIndex(Tcl_Interp *interp,
Tcl_Obj *objPtr, int endValue, int *indexPtr);
/* 646 */
EXTERN int Tcl_UtfToUniChar(const char *src, int *chPtr);
/* 647 */
EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr,
int uniLength, Tcl_DString *dsPtr);
/* 648 */
EXTERN int * Tcl_UtfToUniCharDString(const char *src, int length,
Tcl_DString *dsPtr);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
const struct TclIntStubs *tclIntStubs;
const struct TclIntPlatStubs *tclIntPlatStubs;
} TclStubHooks;
typedef struct TclStubs {
int magic;
const TclStubHooks *hooks;
int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */
const char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */
TCL_NORETURN1 void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */
char * (*tcl_Alloc) (unsigned int size); /* 3 */
void (*tcl_Free) (char *ptr); /* 4 */
char * (*tcl_Realloc) (char *ptr, unsigned int size); /* 5 */
char * (*tcl_DbCkalloc) (unsigned int size, const char *file, int line); /* 6 */
void (*tcl_DbCkfree) (char *ptr, const char *file, int line); /* 7 */
char * (*tcl_DbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 8 */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */
#endif /* UNIX */
#if defined(_WIN32) /* WIN */
void (*reserved9)(void);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, ClientData clientData); /* 9 */
#endif /* MACOSX */
#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tcl_DeleteFileHandler) (int fd); /* 10 */
#endif /* UNIX */
#if defined(_WIN32) /* WIN */
void (*reserved10)(void);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
void (*tcl_DeleteFileHandler) (int fd); /* 10 */
#endif /* MACOSX */
void (*tcl_SetTimer) (const Tcl_Time *timePtr); /* 11 */
void (*tcl_Sleep) (int ms); /* 12 */
int (*tcl_WaitForEvent) (const Tcl_Time *timePtr); /* 13 */
int (*tcl_AppendAllObjTypes) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 14 */
void (*tcl_AppendStringsToObj) (Tcl_Obj *objPtr, ...); /* 15 */
void (*tcl_AppendToObj) (Tcl_Obj *objPtr, const char *bytes, int length); /* 16 */
Tcl_Obj * (*tcl_ConcatObj) (int objc, Tcl_Obj *const objv[]); /* 17 */
int (*tcl_ConvertToType) (Tcl_Interp *interp, Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 18 */
void (*tcl_DbDecrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 19 */
void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 20 */
int (*tcl_DbIsShared) (Tcl_Obj *objPtr, const char *file, int line); /* 21 */
TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewBooleanObj) (int boolValue, const char *file, int line); /* 22 */
Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, int length, const char *file, int line); /* 23 */
Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */
Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */
TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewLongObj) (long longValue, const char *file, int line); /* 26 */
Tcl_Obj * (*tcl_DbNewObj) (const char *file, int line); /* 27 */
Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, int length, const char *file, int line); /* 28 */
Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */
void (*tclFreeObj) (Tcl_Obj *objPtr); /* 30 */
int (*tcl_GetBoolean) (Tcl_Interp *interp, const char *src, int *boolPtr); /* 31 */
int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *boolPtr); /* 32 */
unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 33 */
int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */
int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */
TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */
int (*tcl_GetInt) (Tcl_Interp *interp, const char *src, int *intPtr); /* 37 */
int (*tcl_GetIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 38 */
int (*tcl_GetLongFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 39 */
CONST86 Tcl_ObjType * (*tcl_GetObjType) (const char *typeName); /* 40 */
char * (*tcl_GetStringFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 41 */
void (*tcl_InvalidateStringRep) (Tcl_Obj *objPtr); /* 42 */
int (*tcl_ListObjAppendList) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *elemListPtr); /* 43 */
int (*tcl_ListObjAppendElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *objPtr); /* 44 */
int (*tcl_ListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 45 */
int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj **objPtrPtr); /* 46 */
int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */
int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 48 */
TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewBooleanObj) (int boolValue); /* 49 */
Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, int length); /* 50 */
Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */
TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */
Tcl_Obj * (*tcl_NewListObj) (int objc, Tcl_Obj *const objv[]); /* 53 */
TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */
Tcl_Obj * (*tcl_NewObj) (void); /* 55 */
Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, int length); /* 56 */
TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int boolValue); /* 57 */
unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, int length); /* 58 */
void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, int length); /* 59 */
void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */
TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */
void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 62 */
TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */
void (*tcl_SetObjLength) (Tcl_Obj *objPtr, int length); /* 64 */
void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, int length); /* 65 */
TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_AddErrorInfo) (Tcl_Interp *interp, const char *message); /* 66 */
TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_AddObjErrorInfo) (Tcl_Interp *interp, const char *message, int length); /* 67 */
void (*tcl_AllowExceptions) (Tcl_Interp *interp); /* 68 */
void (*tcl_AppendElement) (Tcl_Interp *interp, const char *element); /* 69 */
void (*tcl_AppendResult) (Tcl_Interp *interp, ...); /* 70 */
Tcl_AsyncHandler (*tcl_AsyncCreate) (Tcl_AsyncProc *proc, ClientData clientData); /* 71 */
void (*tcl_AsyncDelete) (Tcl_AsyncHandler async); /* 72 */
int (*tcl_AsyncInvoke) (Tcl_Interp *interp, int code); /* 73 */
void (*tcl_AsyncMark) (Tcl_AsyncHandler async); /* 74 */
int (*tcl_AsyncReady) (void); /* 75 */
TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_BackgroundError) (Tcl_Interp *interp); /* 76 */
TCL_DEPRECATED_API("Use Tcl_UtfBackslash") char (*tcl_Backslash) (const char *src, int *readPtr); /* 77 */
int (*tcl_BadChannelOption) (Tcl_Interp *interp, const char *optionName, const char *optionList); /* 78 */
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 *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 86 */
int (*tcl_CreateAliasObj) (Tcl_Interp *slave, const char *slaveCmd, 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_CreateSlave) (Tcl_Interp *interp, const char *slaveName, 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 */
void (*tcl_DeleteEvents) (Tcl_EventDeleteProc *proc, ClientData clientData); /* 105 */
void (*tcl_DeleteEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData); /* 106 */
void (*tcl_DeleteExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 107 */
void (*tcl_DeleteHashEntry) (Tcl_HashEntry *entryPtr); /* 108 */
void (*tcl_DeleteHashTable) (Tcl_HashTable *tablePtr); /* 109 */
void (*tcl_DeleteInterp) (Tcl_Interp *interp); /* 110 */
void (*tcl_DetachPids) (int numPids, Tcl_Pid *pidPtr); /* 111 */
void (*tcl_DeleteTimerHandler) (Tcl_TimerToken token); /* 112 */
void (*tcl_DeleteTrace) (Tcl_Interp *interp, Tcl_Trace trace); /* 113 */
void (*tcl_DontCallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 114 */
int (*tcl_DoOneEvent) (int flags); /* 115 */
void (*tcl_DoWhenIdle) (Tcl_IdleProc *proc, ClientData clientData); /* 116 */
char * (*tcl_DStringAppend) (Tcl_DString *dsPtr, const char *bytes, int length); /* 117 */
char * (*tcl_DStringAppendElement) (Tcl_DString *dsPtr, const char *element); /* 118 */
void (*tcl_DStringEndSublist) (Tcl_DString *dsPtr); /* 119 */
void (*tcl_DStringFree) (Tcl_DString *dsPtr); /* 120 */
void (*tcl_DStringGetResult) (Tcl_Interp *interp, Tcl_DString *dsPtr); /* 121 */
void (*tcl_DStringInit) (Tcl_DString *dsPtr); /* 122 */
void (*tcl_DStringResult) (Tcl_Interp *interp, Tcl_DString *dsPtr); /* 123 */
void (*tcl_DStringSetLength) (Tcl_DString *dsPtr, int length); /* 124 */
void (*tcl_DStringStartSublist) (Tcl_DString *dsPtr); /* 125 */
int (*tcl_Eof) (Tcl_Channel chan); /* 126 */
const char * (*tcl_ErrnoId) (void); /* 127 */
const char * (*tcl_ErrnoMsg) (int err); /* 128 */
int (*tcl_Eval) (Tcl_Interp *interp, const char *script); /* 129 */
int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */
TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */
void (*tcl_EventuallyFree) (ClientData clientData, Tcl_FreeProc *freeProc); /* 132 */
TCL_NORETURN1 void (*tcl_Exit) (int status); /* 133 */
int (*tcl_ExposeCommand) (Tcl_Interp *interp, const char *hiddenCmdToken, const char *cmdName); /* 134 */
int (*tcl_ExprBoolean) (Tcl_Interp *interp, const char *expr, int *ptr); /* 135 */
int (*tcl_ExprBooleanObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *ptr); /* 136 */
int (*tcl_ExprDouble) (Tcl_Interp *interp, const char *expr, double *ptr); /* 137 */
int (*tcl_ExprDoubleObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *ptr); /* 138 */
int (*tcl_ExprLong) (Tcl_Interp *interp, const char *expr, long *ptr); /* 139 */
int (*tcl_ExprLongObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *ptr); /* 140 */
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 *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */
int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, 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 *askInterp, Tcl_Interp *slaveInterp); /* 163 */
Tcl_Interp * (*tcl_GetMaster) (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_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 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 */
int (*tcl_Init) (Tcl_Interp *interp); /* 180 */
void (*tcl_InitHashTable) (Tcl_HashTable *tablePtr, int keyType); /* 181 */
int (*tcl_InputBlocked) (Tcl_Channel chan); /* 182 */
int (*tcl_InputBuffered) (Tcl_Channel chan); /* 183 */
int (*tcl_InterpDeleted) (Tcl_Interp *interp); /* 184 */
int (*tcl_IsSafe) (Tcl_Interp *interp); /* 185 */
char * (*tcl_JoinPath) (int argc, const char *const *argv, Tcl_DString *resultPtr); /* 186 */
int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, void *addr, int type); /* 187 */
void (*reserved188)(void);
Tcl_Channel (*tcl_MakeFileChannel) (ClientData handle, int mode); /* 189 */
int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */
Tcl_Channel (*tcl_MakeTcpClientChannel) (ClientData tcpSocket); /* 191 */
char * (*tcl_Merge) (int argc, const char *const *argv); /* 192 */
Tcl_HashEntry * (*tcl_NextHashEntry) (Tcl_HashSearch *searchPtr); /* 193 */
void (*tcl_NotifyChannel) (Tcl_Channel channel, int mask); /* 194 */
Tcl_Obj * (*tcl_ObjGetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 195 */
Tcl_Obj * (*tcl_ObjSetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 196 */
Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, int argc, const char **argv, int flags); /* 197 */
Tcl_Channel (*tcl_OpenFileChannel) (Tcl_Interp *interp, const char *fileName, const char *modeString, int permissions); /* 198 */
Tcl_Channel (*tcl_OpenTcpClient) (Tcl_Interp *interp, int port, const char *address, const char *myaddr, int myport, int async); /* 199 */
Tcl_Channel (*tcl_OpenTcpServer) (Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 200 */
void (*tcl_Preserve) (ClientData data); /* 201 */
void (*tcl_PrintDouble) (Tcl_Interp *interp, double value, char *dst); /* 202 */
int (*tcl_PutEnv) (const char *assignment); /* 203 */
const char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */
void (*tcl_QueueEvent) (Tcl_Event *evPtr, Tcl_QueuePosition position); /* 205 */
int (*tcl_Read) (Tcl_Channel chan, char *bufPtr, int toRead); /* 206 */
void (*tcl_ReapDetachedProcs) (void); /* 207 */
int (*tcl_RecordAndEval) (Tcl_Interp *interp, const char *cmd, int flags); /* 208 */
int (*tcl_RecordAndEvalObj) (Tcl_Interp *interp, Tcl_Obj *cmdPtr, int flags); /* 209 */
void (*tcl_RegisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 210 */
void (*tcl_RegisterObjType) (const Tcl_ObjType *typePtr); /* 211 */
Tcl_RegExp (*tcl_RegExpCompile) (Tcl_Interp *interp, const char *pattern); /* 212 */
int (*tcl_RegExpExec) (Tcl_Interp *interp, Tcl_RegExp regexp, const char *text, const char *start); /* 213 */
int (*tcl_RegExpMatch) (Tcl_Interp *interp, const char *text, const char *pattern); /* 214 */
void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, const char **startPtr, const char **endPtr); /* 215 */
void (*tcl_Release) (ClientData clientData); /* 216 */
void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */
int (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */
int (*tcl_ScanCountedElement) (const char *src, int length, int *flagPtr); /* 219 */
TCL_DEPRECATED_API("") int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */
int (*tcl_ServiceAll) (void); /* 221 */
int (*tcl_ServiceEvent) (int flags); /* 222 */
void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 223 */
void (*tcl_SetChannelBufferSize) (Tcl_Channel chan, int sz); /* 224 */
int (*tcl_SetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, const char *newValue); /* 225 */
int (*tcl_SetCommandInfo) (Tcl_Interp *interp, const char *cmdName, const Tcl_CmdInfo *infoPtr); /* 226 */
void (*tcl_SetErrno) (int err); /* 227 */
void (*tcl_SetErrorCode) (Tcl_Interp *interp, ...); /* 228 */
void (*tcl_SetMaxBlockTime) (const Tcl_Time *timePtr); /* 229 */
TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_SetPanicProc) (TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 230 */
int (*tcl_SetRecursionLimit) (Tcl_Interp *interp, int depth); /* 231 */
void (*tcl_SetResult) (Tcl_Interp *interp, char *result, Tcl_FreeProc *freeProc); /* 232 */
int (*tcl_SetServiceMode) (int mode); /* 233 */
void (*tcl_SetObjErrorCode) (Tcl_Interp *interp, Tcl_Obj *errorObjPtr); /* 234 */
void (*tcl_SetObjResult) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 235 */
void (*tcl_SetStdChannel) (Tcl_Channel channel, int type); /* 236 */
TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */
const char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */
const char * (*tcl_SignalId) (int sig); /* 239 */
const char * (*tcl_SignalMsg) (int sig); /* 240 */
void (*tcl_SourceRCFile) (Tcl_Interp *interp); /* 241 */
int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, const char ***argvPtr); /* 242 */
void (*tcl_SplitPath) (const char *path, int *argcPtr, const char ***argvPtr); /* 243 */
TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */
TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */
TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */
TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */
int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */
char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */
int (*tcl_Ungets) (Tcl_Channel chan, const char *str, int len, int atHead); /* 250 */
void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */
int (*tcl_UnregisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 252 */
TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */
int (*tcl_UnsetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 254 */
TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 255 */
void (*tcl_UntraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 256 */
void (*tcl_UpdateLinkedVar) (Tcl_Interp *interp, const char *varName); /* 257 */
TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_UpVar) (Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 258 */
int (*tcl_UpVar2) (Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags); /* 259 */
int (*tcl_VarEval) (Tcl_Interp *interp, ...); /* 260 */
TCL_DEPRECATED_API("No longer in use, changed to macro") ClientData (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 261 */
ClientData (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 262 */
int (*tcl_Write) (Tcl_Channel chan, const char *s, int slen); /* 263 */
void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */
int (*tcl_DumpActiveMemory) (const char *fileName); /* 265 */
void (*tcl_ValidateAllMemory) (const char *file, int line); /* 266 */
TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */
TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */
char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */
const char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, const char **termPtr); /* 270 */
TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */
const char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */
TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */
TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */
TCL_DEPRECATED_API("see TIP #422") void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */
TCL_DEPRECATED_API("see TIP #422") int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */
Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */
TCL_DEPRECATED_API("see TIP #422") TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */
void (*tcl_GetVersion) (int *major, int *minor, int *patchLevel, int *type); /* 279 */
void (*tcl_InitMemory) (Tcl_Interp *interp); /* 280 */
Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan); /* 281 */
int (*tcl_UnstackChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 282 */
Tcl_Channel (*tcl_GetStackedChannel) (Tcl_Channel chan); /* 283 */
void (*tcl_SetMainLoop) (Tcl_MainLoopProc *proc); /* 284 */
void (*reserved285)(void);
void (*tcl_AppendObjToObj) (Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr); /* 286 */
Tcl_Encoding (*tcl_CreateEncoding) (const Tcl_EncodingType *typePtr); /* 287 */
void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 288 */
void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 289 */
void (*tcl_DiscardResult) (Tcl_SavedResult *statePtr); /* 290 */
int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, int numBytes, int flags); /* 291 */
int (*tcl_EvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 292 */
int (*tcl_EvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 293 */
TCL_NORETURN1 void (*tcl_ExitThread) (int status); /* 294 */
int (*tcl_ExternalToUtf) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */
char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 296 */
void (*tcl_FinalizeThread) (void); /* 297 */
void (*tcl_FinalizeNotifier) (ClientData clientData); /* 298 */
void (*tcl_FreeEncoding) (Tcl_Encoding encoding); /* 299 */
Tcl_ThreadId (*tcl_GetCurrentThread) (void); /* 300 */
Tcl_Encoding (*tcl_GetEncoding) (Tcl_Interp *interp, const char *name); /* 301 */
const char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */
void (*tcl_GetEncodingNames) (Tcl_Interp *interp); /* 303 */
int (*tcl_GetIndexFromObjStruct) (Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, int offset, const char *msg, int flags, int *indexPtr); /* 304 */
void * (*tcl_GetThreadData) (Tcl_ThreadDataKey *keyPtr, int size); /* 305 */
Tcl_Obj * (*tcl_GetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 306 */
ClientData (*tcl_InitNotifier) (void); /* 307 */
void (*tcl_MutexLock) (Tcl_Mutex *mutexPtr); /* 308 */
void (*tcl_MutexUnlock) (Tcl_Mutex *mutexPtr); /* 309 */
void (*tcl_ConditionNotify) (Tcl_Condition *condPtr); /* 310 */
void (*tcl_ConditionWait) (Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 311 */
int (*tcl_NumUtfChars) (const char *src, int length); /* 312 */
int (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, int charsToRead, int appendFlag); /* 313 */
void (*tcl_RestoreResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 314 */
void (*tcl_SaveResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 315 */
int (*tcl_SetSystemEncoding) (Tcl_Interp *interp, const char *name); /* 316 */
Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */
void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */
void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 319 */
int (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */
int (*tcl_UniCharToLower) (int ch); /* 321 */
int (*tcl_UniCharToTitle) (int ch); /* 322 */
int (*tcl_UniCharToUpper) (int ch); /* 323 */
int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */
const char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */
int (*tcl_UtfCharComplete) (const char *src, int length); /* 326 */
int (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */
const char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */
const char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */
const char * (*tcl_UtfNext) (const char *src); /* 330 */
const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 331 */
int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */
char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 333 */
int (*tcl_UtfToLower) (char *src); /* 334 */
int (*tcl_UtfToTitle) (char *src); /* 335 */
int (*tcl_UtfToChar16) (const char *src, unsigned short *chPtr); /* 336 */
int (*tcl_UtfToUpper) (char *src); /* 337 */
int (*tcl_WriteChars) (Tcl_Channel chan, const char *src, int srcLen); /* 338 */
int (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */
char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */
TCL_DEPRECATED_API("Use Tcl_GetEncodingSearchPath") const char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */
TCL_DEPRECATED_API("Use Tcl_SetEncodingSearchPath") void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */
void (*tcl_AlertNotifier) (ClientData clientData); /* 343 */
void (*tcl_ServiceModeHook) (int mode); /* 344 */
int (*tcl_UniCharIsAlnum) (int ch); /* 345 */
int (*tcl_UniCharIsAlpha) (int ch); /* 346 */
int (*tcl_UniCharIsDigit) (int ch); /* 347 */
int (*tcl_UniCharIsLower) (int ch); /* 348 */
int (*tcl_UniCharIsSpace) (int ch); /* 349 */
int (*tcl_UniCharIsUpper) (int ch); /* 350 */
int (*tcl_UniCharIsWordChar) (int ch); /* 351 */
TCL_DEPRECATED_API("Use Tcl_GetCharLength") int (*tcl_UniCharLen) (const Tcl_UniChar *uniStr); /* 352 */
TCL_DEPRECATED_API("Use Tcl_UtfNcmp") int (*tcl_UniCharNcmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 353 */
char * (*tcl_Char16ToUtfDString) (const unsigned short *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */
unsigned short * (*tcl_UtfToChar16DString) (const char *src, int length, Tcl_DString *dsPtr); /* 355 */
Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */
TCL_DEPRECATED_API("Use Tcl_EvalTokensStandard") Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 357 */
void (*tcl_FreeParse) (Tcl_Parse *parsePtr); /* 358 */
void (*tcl_LogCommandInfo) (Tcl_Interp *interp, const char *script, const char *command, int length); /* 359 */
int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 360 */
int (*tcl_ParseCommand) (Tcl_Interp *interp, const char *start, int numBytes, int nested, Tcl_Parse *parsePtr); /* 361 */
int (*tcl_ParseExpr) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr); /* 362 */
int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 363 */
int (*tcl_ParseVarName) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append); /* 364 */
char * (*tcl_GetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 365 */
int (*tcl_Chdir) (const char *dirName); /* 366 */
int (*tcl_Access) (const char *path, int mode); /* 367 */
int (*tcl_Stat) (const char *path, struct stat *bufPtr); /* 368 */
int (*tcl_UtfNcmp) (const char *s1, const char *s2, unsigned long n); /* 369 */
int (*tcl_UtfNcasecmp) (const char *s1, const char *s2, unsigned long n); /* 370 */
int (*tcl_StringCaseMatch) (const char *str, const char *pattern, int nocase); /* 371 */
int (*tcl_UniCharIsControl) (int ch); /* 372 */
int (*tcl_UniCharIsGraph) (int ch); /* 373 */
int (*tcl_UniCharIsPrint) (int ch); /* 374 */
int (*tcl_UniCharIsPunct) (int ch); /* 375 */
int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, int offset, int nmatches, int flags); /* 376 */
void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */
Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, int numChars); /* 378 */
void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */
int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */
int (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */
TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */
Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */
TCL_DEPRECATED_API("Use Tcl_AppendStringsToObj") void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int length); /* 384 */
int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */
void (*tcl_SetNotifier) (Tcl_NotifierProcs *notifierProcPtr); /* 386 */
Tcl_Mutex * (*tcl_GetAllocMutex) (void); /* 387 */
int (*tcl_GetChannelNames) (Tcl_Interp *interp); /* 388 */
int (*tcl_GetChannelNamesEx) (Tcl_Interp *interp, const char *pattern); /* 389 */
int (*tcl_ProcObjCmd) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 390 */
void (*tcl_ConditionFinalize) (Tcl_Condition *condPtr); /* 391 */
void (*tcl_MutexFinalize) (Tcl_Mutex *mutex); /* 392 */
int (*tcl_CreateThread) (Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, ClientData clientData, int stackSize, int flags); /* 393 */
int (*tcl_ReadRaw) (Tcl_Channel chan, char *dst, int bytesToRead); /* 394 */
int (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, int srcLen); /* 395 */
Tcl_Channel (*tcl_GetTopChannel) (Tcl_Channel chan); /* 396 */
int (*tcl_ChannelBuffered) (Tcl_Channel chan); /* 397 */
const char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */
Tcl_ChannelTypeVersion (*tcl_ChannelVersion) (const Tcl_ChannelType *chanTypePtr); /* 399 */
Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) (const Tcl_ChannelType *chanTypePtr); /* 400 */
TCL_DEPRECATED_API("Use Tcl_ChannelClose2Proc") Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) (const Tcl_ChannelType *chanTypePtr); /* 401 */
Tcl_DriverClose2Proc * (*tcl_ChannelClose2Proc) (const Tcl_ChannelType *chanTypePtr); /* 402 */
Tcl_DriverInputProc * (*tcl_ChannelInputProc) (const Tcl_ChannelType *chanTypePtr); /* 403 */
Tcl_DriverOutputProc * (*tcl_ChannelOutputProc) (const Tcl_ChannelType *chanTypePtr); /* 404 */
TCL_DEPRECATED_API("Use Tcl_ChannelWideSeekProc") Tcl_DriverSeekProc * (*tcl_ChannelSeekProc) (const Tcl_ChannelType *chanTypePtr); /* 405 */
Tcl_DriverSetOptionProc * (*tcl_ChannelSetOptionProc) (const Tcl_ChannelType *chanTypePtr); /* 406 */
Tcl_DriverGetOptionProc * (*tcl_ChannelGetOptionProc) (const Tcl_ChannelType *chanTypePtr); /* 407 */
Tcl_DriverWatchProc * (*tcl_ChannelWatchProc) (const Tcl_ChannelType *chanTypePtr); /* 408 */
Tcl_DriverGetHandleProc * (*tcl_ChannelGetHandleProc) (const Tcl_ChannelType *chanTypePtr); /* 409 */
Tcl_DriverFlushProc * (*tcl_ChannelFlushProc) (const Tcl_ChannelType *chanTypePtr); /* 410 */
Tcl_DriverHandlerProc * (*tcl_ChannelHandlerProc) (const Tcl_ChannelType *chanTypePtr); /* 411 */
int (*tcl_JoinThread) (Tcl_ThreadId threadId, int *result); /* 412 */
int (*tcl_IsChannelShared) (Tcl_Channel channel); /* 413 */
int (*tcl_IsChannelRegistered) (Tcl_Interp *interp, Tcl_Channel channel); /* 414 */
void (*tcl_CutChannel) (Tcl_Channel channel); /* 415 */
void (*tcl_SpliceChannel) (Tcl_Channel channel); /* 416 */
void (*tcl_ClearChannelHandlers) (Tcl_Channel channel); /* 417 */
int (*tcl_IsChannelExisting) (const char *channelName); /* 418 */
TCL_DEPRECATED_API("Use Tcl_UtfNcasecmp") int (*tcl_UniCharNcasecmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 419 */
TCL_DEPRECATED_API("Use Tcl_StringCaseMatch") int (*tcl_UniCharCaseMatch) (const Tcl_UniChar *uniStr, const Tcl_UniChar *uniPattern, int nocase); /* 420 */
Tcl_HashEntry * (*tcl_FindHashEntry) (Tcl_HashTable *tablePtr, const void *key); /* 421 */
Tcl_HashEntry * (*tcl_CreateHashEntry) (Tcl_HashTable *tablePtr, const void *key, int *newPtr); /* 422 */
void (*tcl_InitCustomHashTable) (Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr); /* 423 */
void (*tcl_InitObjHashTable) (Tcl_HashTable *tablePtr); /* 424 */
ClientData (*tcl_CommandTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, ClientData prevClientData); /* 425 */
int (*tcl_TraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, ClientData clientData); /* 426 */
void (*tcl_UntraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, ClientData clientData); /* 427 */
char * (*tcl_AttemptAlloc) (unsigned int size); /* 428 */
char * (*tcl_AttemptDbCkalloc) (unsigned int size, const char *file, int line); /* 429 */
char * (*tcl_AttemptRealloc) (char *ptr, unsigned int size); /* 430 */
char * (*tcl_AttemptDbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 431 */
int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, int length); /* 432 */
Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */
Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */
TCL_DEPRECATED_API("") int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */
TCL_DEPRECATED_API("") Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */
Tcl_Obj * (*tcl_SubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 437 */
int (*tcl_DetachChannel) (Tcl_Interp *interp, Tcl_Channel channel); /* 438 */
int (*tcl_IsStandardChannel) (Tcl_Channel channel); /* 439 */
int (*tcl_FSCopyFile) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr); /* 440 */
int (*tcl_FSCopyDirectory) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, Tcl_Obj **errorPtr); /* 441 */
int (*tcl_FSCreateDirectory) (Tcl_Obj *pathPtr); /* 442 */
int (*tcl_FSDeleteFile) (Tcl_Obj *pathPtr); /* 443 */
int (*tcl_FSLoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *sym1, const char *sym2, Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr); /* 444 */
int (*tcl_FSMatchInDirectory) (Tcl_Interp *interp, Tcl_Obj *result, Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types); /* 445 */
Tcl_Obj * (*tcl_FSLink) (Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkAction); /* 446 */
int (*tcl_FSRemoveDirectory) (Tcl_Obj *pathPtr, int recursive, Tcl_Obj **errorPtr); /* 447 */
int (*tcl_FSRenameFile) (Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr); /* 448 */
int (*tcl_FSLstat) (Tcl_Obj *pathPtr, Tcl_StatBuf *buf); /* 449 */
int (*tcl_FSUtime) (Tcl_Obj *pathPtr, struct utimbuf *tval); /* 450 */
int (*tcl_FSFileAttrsGet) (Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 451 */
int (*tcl_FSFileAttrsSet) (Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr); /* 452 */
const char *CONST86 * (*tcl_FSFileAttrStrings) (Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 453 */
int (*tcl_FSStat) (Tcl_Obj *pathPtr, Tcl_StatBuf *buf); /* 454 */
int (*tcl_FSAccess) (Tcl_Obj *pathPtr, int mode); /* 455 */
Tcl_Channel (*tcl_FSOpenFileChannel) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *modeString, int permissions); /* 456 */
Tcl_Obj * (*tcl_FSGetCwd) (Tcl_Interp *interp); /* 457 */
int (*tcl_FSChdir) (Tcl_Obj *pathPtr); /* 458 */
int (*tcl_FSConvertToPathType) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 459 */
Tcl_Obj * (*tcl_FSJoinPath) (Tcl_Obj *listObj, int elements); /* 460 */
Tcl_Obj * (*tcl_FSSplitPath) (Tcl_Obj *pathPtr, int *lenPtr); /* 461 */
int (*tcl_FSEqualPaths) (Tcl_Obj *firstPtr, Tcl_Obj *secondPtr); /* 462 */
Tcl_Obj * (*tcl_FSGetNormalizedPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 463 */
Tcl_Obj * (*tcl_FSJoinToPath) (Tcl_Obj *pathPtr, int objc, Tcl_Obj *const objv[]); /* 464 */
ClientData (*tcl_FSGetInternalRep) (Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr); /* 465 */
Tcl_Obj * (*tcl_FSGetTranslatedPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 466 */
int (*tcl_FSEvalFile) (Tcl_Interp *interp, Tcl_Obj *fileName); /* 467 */
Tcl_Obj * (*tcl_FSNewNativePath) (const Tcl_Filesystem *fromFilesystem, ClientData clientData); /* 468 */
const void * (*tcl_FSGetNativePath) (Tcl_Obj *pathPtr); /* 469 */
Tcl_Obj * (*tcl_FSFileSystemInfo) (Tcl_Obj *pathPtr); /* 470 */
Tcl_Obj * (*tcl_FSPathSeparator) (Tcl_Obj *pathPtr); /* 471 */
Tcl_Obj * (*tcl_FSListVolumes) (void); /* 472 */
int (*tcl_FSRegister) (ClientData clientData, const Tcl_Filesystem *fsPtr); /* 473 */
int (*tcl_FSUnregister) (const Tcl_Filesystem *fsPtr); /* 474 */
ClientData (*tcl_FSData) (const Tcl_Filesystem *fsPtr); /* 475 */
const char * (*tcl_FSGetTranslatedStringPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 476 */
CONST86 Tcl_Filesystem * (*tcl_FSGetFileSystemForPath) (Tcl_Obj *pathPtr); /* 477 */
Tcl_PathType (*tcl_FSGetPathType) (Tcl_Obj *pathPtr); /* 478 */
int (*tcl_OutputBuffered) (Tcl_Channel chan); /* 479 */
void (*tcl_FSMountsChanged) (const Tcl_Filesystem *fsPtr); /* 480 */
int (*tcl_EvalTokensStandard) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 481 */
void (*tcl_GetTime) (Tcl_Time *timeBuf); /* 482 */
Tcl_Trace (*tcl_CreateObjTrace) (Tcl_Interp *interp, int level, int flags, Tcl_CmdObjTraceProc *objProc, ClientData clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 483 */
int (*tcl_GetCommandInfoFromToken) (Tcl_Command token, Tcl_CmdInfo *infoPtr); /* 484 */
int (*tcl_SetCommandInfoFromToken) (Tcl_Command token, const Tcl_CmdInfo *infoPtr); /* 485 */
Tcl_Obj * (*tcl_DbNewWideIntObj) (Tcl_WideInt wideValue, const char *file, int line); /* 486 */
int (*tcl_GetWideIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideInt *widePtr); /* 487 */
Tcl_Obj * (*tcl_NewWideIntObj) (Tcl_WideInt wideValue); /* 488 */
void (*tcl_SetWideIntObj) (Tcl_Obj *objPtr, Tcl_WideInt wideValue); /* 489 */
Tcl_StatBuf * (*tcl_AllocStatBuf) (void); /* 490 */
|
| ︙ | ︙ | |||
2294 2295 2296 2297 2298 2299 2300 |
void (*tcl_DictObjNext) (Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); /* 499 */
void (*tcl_DictObjDone) (Tcl_DictSearch *searchPtr); /* 500 */
int (*tcl_DictObjPutKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr); /* 501 */
int (*tcl_DictObjRemoveKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, Tcl_Obj *const *keyv); /* 502 */
Tcl_Obj * (*tcl_NewDictObj) (void); /* 503 */
Tcl_Obj * (*tcl_DbNewDictObj) (const char *file, int line); /* 504 */
void (*tcl_RegisterConfig) (Tcl_Interp *interp, const char *pkgName, const Tcl_Config *configuration, const char *valEncoding); /* 505 */
| | | | | | 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 |
void (*tcl_DictObjNext) (Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); /* 499 */
void (*tcl_DictObjDone) (Tcl_DictSearch *searchPtr); /* 500 */
int (*tcl_DictObjPutKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, Tcl_Obj *const *keyv, Tcl_Obj *valuePtr); /* 501 */
int (*tcl_DictObjRemoveKeyList) (Tcl_Interp *interp, Tcl_Obj *dictPtr, int keyc, Tcl_Obj *const *keyv); /* 502 */
Tcl_Obj * (*tcl_NewDictObj) (void); /* 503 */
Tcl_Obj * (*tcl_DbNewDictObj) (const char *file, int line); /* 504 */
void (*tcl_RegisterConfig) (Tcl_Interp *interp, const char *pkgName, const Tcl_Config *configuration, const char *valEncoding); /* 505 */
Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 506 */
void (*tcl_DeleteNamespace) (Tcl_Namespace *nsPtr); /* 507 */
int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 508 */
int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 509 */
int (*tcl_Import) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 510 */
int (*tcl_ForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 511 */
Tcl_Namespace * (*tcl_GetCurrentNamespace) (Tcl_Interp *interp); /* 512 */
Tcl_Namespace * (*tcl_GetGlobalNamespace) (Tcl_Interp *interp); /* 513 */
Tcl_Namespace * (*tcl_FindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 514 */
Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 515 */
Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 516 */
void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 517 */
int (*tcl_FSEvalFileEx) (Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); /* 518 */
TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") Tcl_ExitProc * (*tcl_SetExitProc) (TCL_NORETURN1 Tcl_ExitProc *proc); /* 519 */
void (*tcl_LimitAddHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 520 */
void (*tcl_LimitRemoveHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData); /* 521 */
int (*tcl_LimitReady) (Tcl_Interp *interp); /* 522 */
int (*tcl_LimitCheck) (Tcl_Interp *interp); /* 523 */
int (*tcl_LimitExceeded) (Tcl_Interp *interp); /* 524 */
void (*tcl_LimitSetCommands) (Tcl_Interp *interp, int commandLimit); /* 525 */
void (*tcl_LimitSetTime) (Tcl_Interp *interp, Tcl_Time *timeLimitPtr); /* 526 */
void (*tcl_LimitSetGranularity) (Tcl_Interp *interp, int type, int granularity); /* 527 */
int (*tcl_LimitTypeEnabled) (Tcl_Interp *interp, int type); /* 528 */
|
| ︙ | ︙ | |||
2340 2341 2342 2343 2344 2345 2346 |
int (*tcl_SetEnsembleUnknownHandler) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *unknownList); /* 545 */
int (*tcl_SetEnsembleFlags) (Tcl_Interp *interp, Tcl_Command token, int flags); /* 546 */
int (*tcl_GetEnsembleSubcommandList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **subcmdListPtr); /* 547 */
int (*tcl_GetEnsembleMappingDict) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **mapDictPtr); /* 548 */
int (*tcl_GetEnsembleUnknownHandler) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **unknownListPtr); /* 549 */
int (*tcl_GetEnsembleFlags) (Tcl_Interp *interp, Tcl_Command token, int *flagsPtr); /* 550 */
int (*tcl_GetEnsembleNamespace) (Tcl_Interp *interp, Tcl_Command token, Tcl_Namespace **namespacePtrPtr); /* 551 */
| | | | | | | | | | | | | | | | | | | | | | | > > > | 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 |
int (*tcl_SetEnsembleUnknownHandler) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *unknownList); /* 545 */
int (*tcl_SetEnsembleFlags) (Tcl_Interp *interp, Tcl_Command token, int flags); /* 546 */
int (*tcl_GetEnsembleSubcommandList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **subcmdListPtr); /* 547 */
int (*tcl_GetEnsembleMappingDict) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **mapDictPtr); /* 548 */
int (*tcl_GetEnsembleUnknownHandler) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **unknownListPtr); /* 549 */
int (*tcl_GetEnsembleFlags) (Tcl_Interp *interp, Tcl_Command token, int *flagsPtr); /* 550 */
int (*tcl_GetEnsembleNamespace) (Tcl_Interp *interp, Tcl_Command token, Tcl_Namespace **namespacePtrPtr); /* 551 */
void (*tcl_SetTimeProc) (Tcl_GetTimeProc *getProc, Tcl_ScaleTimeProc *scaleProc, ClientData clientData); /* 552 */
void (*tcl_QueryTimeProc) (Tcl_GetTimeProc **getProc, Tcl_ScaleTimeProc **scaleProc, ClientData *clientData); /* 553 */
Tcl_DriverThreadActionProc * (*tcl_ChannelThreadActionProc) (const Tcl_ChannelType *chanTypePtr); /* 554 */
Tcl_Obj * (*tcl_NewBignumObj) (void *value); /* 555 */
Tcl_Obj * (*tcl_DbNewBignumObj) (void *value, const char *file, int line); /* 556 */
void (*tcl_SetBignumObj) (Tcl_Obj *obj, void *value); /* 557 */
int (*tcl_GetBignumFromObj) (Tcl_Interp *interp, Tcl_Obj *obj, void *value); /* 558 */
int (*tcl_TakeBignumFromObj) (Tcl_Interp *interp, Tcl_Obj *obj, void *value); /* 559 */
int (*tcl_TruncateChannel) (Tcl_Channel chan, Tcl_WideInt length); /* 560 */
Tcl_DriverTruncateProc * (*tcl_ChannelTruncateProc) (const Tcl_ChannelType *chanTypePtr); /* 561 */
void (*tcl_SetChannelErrorInterp) (Tcl_Interp *interp, Tcl_Obj *msg); /* 562 */
void (*tcl_GetChannelErrorInterp) (Tcl_Interp *interp, Tcl_Obj **msg); /* 563 */
void (*tcl_SetChannelError) (Tcl_Channel chan, Tcl_Obj *msg); /* 564 */
void (*tcl_GetChannelError) (Tcl_Channel chan, Tcl_Obj **msg); /* 565 */
int (*tcl_InitBignumFromDouble) (Tcl_Interp *interp, double initval, void *toInit); /* 566 */
Tcl_Obj * (*tcl_GetNamespaceUnknownHandler) (Tcl_Interp *interp, Tcl_Namespace *nsPtr); /* 567 */
int (*tcl_SetNamespaceUnknownHandler) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *handlerPtr); /* 568 */
int (*tcl_GetEncodingFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr); /* 569 */
Tcl_Obj * (*tcl_GetEncodingSearchPath) (void); /* 570 */
int (*tcl_SetEncodingSearchPath) (Tcl_Obj *searchPath); /* 571 */
const char * (*tcl_GetEncodingNameFromEnvironment) (Tcl_DString *bufPtr); /* 572 */
int (*tcl_PkgRequireProc) (Tcl_Interp *interp, const char *name, int objc, Tcl_Obj *const objv[], void *clientDataPtr); /* 573 */
void (*tcl_AppendObjToErrorInfo) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 574 */
void (*tcl_AppendLimitedToObj) (Tcl_Obj *objPtr, const char *bytes, int length, int limit, const char *ellipsis); /* 575 */
Tcl_Obj * (*tcl_Format) (Tcl_Interp *interp, const char *format, int objc, Tcl_Obj *const objv[]); /* 576 */
int (*tcl_AppendFormatToObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *format, int objc, Tcl_Obj *const objv[]); /* 577 */
Tcl_Obj * (*tcl_ObjPrintf) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 578 */
void (*tcl_AppendPrintfToObj) (Tcl_Obj *objPtr, const char *format, ...) TCL_FORMAT_PRINTF(2, 3); /* 579 */
int (*tcl_CancelEval) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr, ClientData clientData, int flags); /* 580 */
int (*tcl_Canceled) (Tcl_Interp *interp, int flags); /* 581 */
int (*tcl_CreatePipe) (Tcl_Interp *interp, Tcl_Channel *rchan, Tcl_Channel *wchan, int flags); /* 582 */
Tcl_Command (*tcl_NRCreateCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 583 */
int (*tcl_NREvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 584 */
int (*tcl_NREvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 585 */
int (*tcl_NRCmdSwap) (Tcl_Interp *interp, Tcl_Command cmd, int objc, Tcl_Obj *const objv[], int flags); /* 586 */
void (*tcl_NRAddCallback) (Tcl_Interp *interp, Tcl_NRPostProc *postProcPtr, ClientData data0, ClientData data1, ClientData data2, ClientData data3); /* 587 */
int (*tcl_NRCallObjProc) (Tcl_Interp *interp, Tcl_ObjCmdProc *objProc, ClientData clientData, int objc, Tcl_Obj *const objv[]); /* 588 */
unsigned (*tcl_GetFSDeviceFromStat) (const Tcl_StatBuf *statPtr); /* 589 */
unsigned (*tcl_GetFSInodeFromStat) (const Tcl_StatBuf *statPtr); /* 590 */
unsigned (*tcl_GetModeFromStat) (const Tcl_StatBuf *statPtr); /* 591 */
int (*tcl_GetLinkCountFromStat) (const Tcl_StatBuf *statPtr); /* 592 */
int (*tcl_GetUserIdFromStat) (const Tcl_StatBuf *statPtr); /* 593 */
int (*tcl_GetGroupIdFromStat) (const Tcl_StatBuf *statPtr); /* 594 */
int (*tcl_GetDeviceTypeFromStat) (const Tcl_StatBuf *statPtr); /* 595 */
Tcl_WideInt (*tcl_GetAccessTimeFromStat) (const Tcl_StatBuf *statPtr); /* 596 */
Tcl_WideInt (*tcl_GetModificationTimeFromStat) (const Tcl_StatBuf *statPtr); /* 597 */
Tcl_WideInt (*tcl_GetChangeTimeFromStat) (const Tcl_StatBuf *statPtr); /* 598 */
Tcl_WideUInt (*tcl_GetSizeFromStat) (const Tcl_StatBuf *statPtr); /* 599 */
Tcl_WideUInt (*tcl_GetBlocksFromStat) (const Tcl_StatBuf *statPtr); /* 600 */
unsigned (*tcl_GetBlockSizeFromStat) (const Tcl_StatBuf *statPtr); /* 601 */
int (*tcl_SetEnsembleParameterList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *paramList); /* 602 */
int (*tcl_GetEnsembleParameterList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **paramListPtr); /* 603 */
int (*tcl_ParseArgsObjv) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, int *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 604 */
int (*tcl_GetErrorLine) (Tcl_Interp *interp); /* 605 */
void (*tcl_SetErrorLine) (Tcl_Interp *interp, int lineNum); /* 606 */
void (*tcl_TransferResult) (Tcl_Interp *sourceInterp, int code, Tcl_Interp *targetInterp); /* 607 */
int (*tcl_InterpActive) (Tcl_Interp *interp); /* 608 */
void (*tcl_BackgroundException) (Tcl_Interp *interp, int code); /* 609 */
int (*tcl_ZlibDeflate) (Tcl_Interp *interp, int format, Tcl_Obj *data, int level, Tcl_Obj *gzipHeaderDictObj); /* 610 */
int (*tcl_ZlibInflate) (Tcl_Interp *interp, int format, Tcl_Obj *data, int buffersize, Tcl_Obj *gzipHeaderDictObj); /* 611 */
unsigned int (*tcl_ZlibCRC32) (unsigned int crc, const unsigned char *buf, int len); /* 612 */
unsigned int (*tcl_ZlibAdler32) (unsigned int adler, const unsigned char *buf, int len); /* 613 */
int (*tcl_ZlibStreamInit) (Tcl_Interp *interp, int mode, int format, int level, Tcl_Obj *dictObj, Tcl_ZlibStream *zshandle); /* 614 */
Tcl_Obj * (*tcl_ZlibStreamGetCommandName) (Tcl_ZlibStream zshandle); /* 615 */
int (*tcl_ZlibStreamEof) (Tcl_ZlibStream zshandle); /* 616 */
int (*tcl_ZlibStreamChecksum) (Tcl_ZlibStream zshandle); /* 617 */
int (*tcl_ZlibStreamPut) (Tcl_ZlibStream zshandle, Tcl_Obj *data, int flush); /* 618 */
int (*tcl_ZlibStreamGet) (Tcl_ZlibStream zshandle, Tcl_Obj *data, int count); /* 619 */
int (*tcl_ZlibStreamClose) (Tcl_ZlibStream zshandle); /* 620 */
int (*tcl_ZlibStreamReset) (Tcl_ZlibStream zshandle); /* 621 */
void (*tcl_SetStartupScript) (Tcl_Obj *path, const char *encoding); /* 622 */
Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingPtr); /* 623 */
int (*tcl_CloseEx) (Tcl_Interp *interp, Tcl_Channel chan, int flags); /* 624 */
int (*tcl_NRExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *resultPtr); /* 625 */
int (*tcl_NRSubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 626 */
int (*tcl_LoadFile) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *const symv[], int flags, void *procPtrs, Tcl_LoadHandle *handlePtr); /* 627 */
void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */
int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */
void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */
Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 631 */
int (*tclZipfs_Mount) (Tcl_Interp *interp, const char *mountPoint, const char *zipname, const char *passwd); /* 632 */
int (*tclZipfs_Unmount) (Tcl_Interp *interp, const char *mountPoint); /* 633 */
Tcl_Obj * (*tclZipfs_TclLibrary) (void); /* 634 */
int (*tclZipfs_MountBuffer) (Tcl_Interp *interp, const char *mountPoint, unsigned char *data, size_t datalen, int copy); /* 635 */
void (*tcl_FreeIntRep) (Tcl_Obj *objPtr); /* 636 */
char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes); /* 637 */
Tcl_ObjIntRep * (*tcl_FetchIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 638 */
void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 639 */
int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */
void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */
void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */
int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */
int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, int size); /* 644 */
int (*tcl_GetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr); /* 645 */
int (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */
char * (*tcl_UniCharToUtfDString) (const int *uniStr, int uniLength, Tcl_DString *dsPtr); /* 647 */
int * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 648 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
#ifdef __cplusplus
}
#endif
|
| ︙ | ︙ | |||
2504 2505 2506 2507 2508 2509 2510 | (tclStubsPtr->tcl_ConvertToType) /* 18 */ #define Tcl_DbDecrRefCount \ (tclStubsPtr->tcl_DbDecrRefCount) /* 19 */ #define Tcl_DbIncrRefCount \ (tclStubsPtr->tcl_DbIncrRefCount) /* 20 */ #define Tcl_DbIsShared \ (tclStubsPtr->tcl_DbIsShared) /* 21 */ | | > | > > | | > | 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 | (tclStubsPtr->tcl_ConvertToType) /* 18 */ #define Tcl_DbDecrRefCount \ (tclStubsPtr->tcl_DbDecrRefCount) /* 19 */ #define Tcl_DbIncrRefCount \ (tclStubsPtr->tcl_DbIncrRefCount) /* 20 */ #define Tcl_DbIsShared \ (tclStubsPtr->tcl_DbIsShared) /* 21 */ #define Tcl_DbNewBooleanObj \ (tclStubsPtr->tcl_DbNewBooleanObj) /* 22 */ #define Tcl_DbNewByteArrayObj \ (tclStubsPtr->tcl_DbNewByteArrayObj) /* 23 */ #define Tcl_DbNewDoubleObj \ (tclStubsPtr->tcl_DbNewDoubleObj) /* 24 */ #define Tcl_DbNewListObj \ (tclStubsPtr->tcl_DbNewListObj) /* 25 */ #define Tcl_DbNewLongObj \ (tclStubsPtr->tcl_DbNewLongObj) /* 26 */ #define Tcl_DbNewObj \ (tclStubsPtr->tcl_DbNewObj) /* 27 */ #define Tcl_DbNewStringObj \ (tclStubsPtr->tcl_DbNewStringObj) /* 28 */ #define Tcl_DuplicateObj \ (tclStubsPtr->tcl_DuplicateObj) /* 29 */ #define TclFreeObj \ (tclStubsPtr->tclFreeObj) /* 30 */ #define Tcl_GetBoolean \ (tclStubsPtr->tcl_GetBoolean) /* 31 */ #define Tcl_GetBooleanFromObj \ (tclStubsPtr->tcl_GetBooleanFromObj) /* 32 */ #define Tcl_GetByteArrayFromObj \ (tclStubsPtr->tcl_GetByteArrayFromObj) /* 33 */ #define Tcl_GetDouble \ (tclStubsPtr->tcl_GetDouble) /* 34 */ #define Tcl_GetDoubleFromObj \ (tclStubsPtr->tcl_GetDoubleFromObj) /* 35 */ #define Tcl_GetIndexFromObj \ (tclStubsPtr->tcl_GetIndexFromObj) /* 36 */ #define Tcl_GetInt \ (tclStubsPtr->tcl_GetInt) /* 37 */ #define Tcl_GetIntFromObj \ (tclStubsPtr->tcl_GetIntFromObj) /* 38 */ #define Tcl_GetLongFromObj \ (tclStubsPtr->tcl_GetLongFromObj) /* 39 */ #define Tcl_GetObjType \ |
| ︙ | ︙ | |||
2554 2555 2556 2557 2558 2559 2560 | (tclStubsPtr->tcl_ListObjGetElements) /* 45 */ #define Tcl_ListObjIndex \ (tclStubsPtr->tcl_ListObjIndex) /* 46 */ #define Tcl_ListObjLength \ (tclStubsPtr->tcl_ListObjLength) /* 47 */ #define Tcl_ListObjReplace \ (tclStubsPtr->tcl_ListObjReplace) /* 48 */ | | > > | > | | > > | > | | | > > | > > | | 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 | (tclStubsPtr->tcl_ListObjGetElements) /* 45 */ #define Tcl_ListObjIndex \ (tclStubsPtr->tcl_ListObjIndex) /* 46 */ #define Tcl_ListObjLength \ (tclStubsPtr->tcl_ListObjLength) /* 47 */ #define Tcl_ListObjReplace \ (tclStubsPtr->tcl_ListObjReplace) /* 48 */ #define Tcl_NewBooleanObj \ (tclStubsPtr->tcl_NewBooleanObj) /* 49 */ #define Tcl_NewByteArrayObj \ (tclStubsPtr->tcl_NewByteArrayObj) /* 50 */ #define Tcl_NewDoubleObj \ (tclStubsPtr->tcl_NewDoubleObj) /* 51 */ #define Tcl_NewIntObj \ (tclStubsPtr->tcl_NewIntObj) /* 52 */ #define Tcl_NewListObj \ (tclStubsPtr->tcl_NewListObj) /* 53 */ #define Tcl_NewLongObj \ (tclStubsPtr->tcl_NewLongObj) /* 54 */ #define Tcl_NewObj \ (tclStubsPtr->tcl_NewObj) /* 55 */ #define Tcl_NewStringObj \ (tclStubsPtr->tcl_NewStringObj) /* 56 */ #define Tcl_SetBooleanObj \ (tclStubsPtr->tcl_SetBooleanObj) /* 57 */ #define Tcl_SetByteArrayLength \ (tclStubsPtr->tcl_SetByteArrayLength) /* 58 */ #define Tcl_SetByteArrayObj \ (tclStubsPtr->tcl_SetByteArrayObj) /* 59 */ #define Tcl_SetDoubleObj \ (tclStubsPtr->tcl_SetDoubleObj) /* 60 */ #define Tcl_SetIntObj \ (tclStubsPtr->tcl_SetIntObj) /* 61 */ #define Tcl_SetListObj \ (tclStubsPtr->tcl_SetListObj) /* 62 */ #define Tcl_SetLongObj \ (tclStubsPtr->tcl_SetLongObj) /* 63 */ #define Tcl_SetObjLength \ (tclStubsPtr->tcl_SetObjLength) /* 64 */ #define Tcl_SetStringObj \ (tclStubsPtr->tcl_SetStringObj) /* 65 */ #define Tcl_AddErrorInfo \ (tclStubsPtr->tcl_AddErrorInfo) /* 66 */ #define Tcl_AddObjErrorInfo \ (tclStubsPtr->tcl_AddObjErrorInfo) /* 67 */ #define Tcl_AllowExceptions \ (tclStubsPtr->tcl_AllowExceptions) /* 68 */ #define Tcl_AppendElement \ (tclStubsPtr->tcl_AppendElement) /* 69 */ #define Tcl_AppendResult \ (tclStubsPtr->tcl_AppendResult) /* 70 */ #define Tcl_AsyncCreate \ (tclStubsPtr->tcl_AsyncCreate) /* 71 */ #define Tcl_AsyncDelete \ (tclStubsPtr->tcl_AsyncDelete) /* 72 */ #define Tcl_AsyncInvoke \ (tclStubsPtr->tcl_AsyncInvoke) /* 73 */ #define Tcl_AsyncMark \ (tclStubsPtr->tcl_AsyncMark) /* 74 */ #define Tcl_AsyncReady \ (tclStubsPtr->tcl_AsyncReady) /* 75 */ #define Tcl_BackgroundError \ (tclStubsPtr->tcl_BackgroundError) /* 76 */ #define Tcl_Backslash \ (tclStubsPtr->tcl_Backslash) /* 77 */ #define Tcl_BadChannelOption \ (tclStubsPtr->tcl_BadChannelOption) /* 78 */ #define Tcl_CallWhenDeleted \ (tclStubsPtr->tcl_CallWhenDeleted) /* 79 */ #define Tcl_CancelIdleCall \ (tclStubsPtr->tcl_CancelIdleCall) /* 80 */ #define Tcl_Close \ |
| ︙ | ︙ | |||
2636 2637 2638 2639 2640 2641 2642 | (tclStubsPtr->tcl_CreateCommand) /* 91 */ #define Tcl_CreateEventSource \ (tclStubsPtr->tcl_CreateEventSource) /* 92 */ #define Tcl_CreateExitHandler \ (tclStubsPtr->tcl_CreateExitHandler) /* 93 */ #define Tcl_CreateInterp \ (tclStubsPtr->tcl_CreateInterp) /* 94 */ | | > | 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 | (tclStubsPtr->tcl_CreateCommand) /* 91 */ #define Tcl_CreateEventSource \ (tclStubsPtr->tcl_CreateEventSource) /* 92 */ #define Tcl_CreateExitHandler \ (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_CreateSlave \ (tclStubsPtr->tcl_CreateSlave) /* 97 */ #define Tcl_CreateTimerHandler \ (tclStubsPtr->tcl_CreateTimerHandler) /* 98 */ #define Tcl_CreateTrace \ |
| ︙ | ︙ | |||
2703 2704 2705 2706 2707 2708 2709 | (tclStubsPtr->tcl_DStringStartSublist) /* 125 */ #define Tcl_Eof \ (tclStubsPtr->tcl_Eof) /* 126 */ #define Tcl_ErrnoId \ (tclStubsPtr->tcl_ErrnoId) /* 127 */ #define Tcl_ErrnoMsg \ (tclStubsPtr->tcl_ErrnoMsg) /* 128 */ | > | > | | 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 | (tclStubsPtr->tcl_DStringStartSublist) /* 125 */ #define Tcl_Eof \ (tclStubsPtr->tcl_Eof) /* 126 */ #define Tcl_ErrnoId \ (tclStubsPtr->tcl_ErrnoId) /* 127 */ #define Tcl_ErrnoMsg \ (tclStubsPtr->tcl_ErrnoMsg) /* 128 */ #define Tcl_Eval \ (tclStubsPtr->tcl_Eval) /* 129 */ #define Tcl_EvalFile \ (tclStubsPtr->tcl_EvalFile) /* 130 */ #define Tcl_EvalObj \ (tclStubsPtr->tcl_EvalObj) /* 131 */ #define Tcl_EventuallyFree \ (tclStubsPtr->tcl_EventuallyFree) /* 132 */ #define Tcl_Exit \ (tclStubsPtr->tcl_Exit) /* 133 */ #define Tcl_ExposeCommand \ (tclStubsPtr->tcl_ExposeCommand) /* 134 */ #define Tcl_ExprBoolean \ |
| ︙ | ︙ | |||
2731 2732 2733 2734 2735 2736 2737 | (tclStubsPtr->tcl_ExprLongObj) /* 140 */ #define Tcl_ExprObj \ (tclStubsPtr->tcl_ExprObj) /* 141 */ #define Tcl_ExprString \ (tclStubsPtr->tcl_ExprString) /* 142 */ #define Tcl_Finalize \ (tclStubsPtr->tcl_Finalize) /* 143 */ | > | | 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 | (tclStubsPtr->tcl_ExprLongObj) /* 140 */ #define Tcl_ExprObj \ (tclStubsPtr->tcl_ExprObj) /* 141 */ #define Tcl_ExprString \ (tclStubsPtr->tcl_ExprString) /* 142 */ #define Tcl_Finalize \ (tclStubsPtr->tcl_Finalize) /* 143 */ #define Tcl_FindExecutable \ (tclStubsPtr->tcl_FindExecutable) /* 144 */ #define Tcl_FirstHashEntry \ (tclStubsPtr->tcl_FirstHashEntry) /* 145 */ #define Tcl_Flush \ (tclStubsPtr->tcl_Flush) /* 146 */ #define Tcl_FreeResult \ (tclStubsPtr->tcl_FreeResult) /* 147 */ #define Tcl_GetAlias \ |
| ︙ | ︙ | |||
2796 2797 2798 2799 2800 2801 2802 | (tclStubsPtr->tcl_GetsObj) /* 170 */ #define Tcl_GetServiceMode \ (tclStubsPtr->tcl_GetServiceMode) /* 171 */ #define Tcl_GetSlave \ (tclStubsPtr->tcl_GetSlave) /* 172 */ #define Tcl_GetStdChannel \ (tclStubsPtr->tcl_GetStdChannel) /* 173 */ | > | > | > | > | | 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 | (tclStubsPtr->tcl_GetsObj) /* 170 */ #define Tcl_GetServiceMode \ (tclStubsPtr->tcl_GetServiceMode) /* 171 */ #define Tcl_GetSlave \ (tclStubsPtr->tcl_GetSlave) /* 172 */ #define Tcl_GetStdChannel \ (tclStubsPtr->tcl_GetStdChannel) /* 173 */ #define Tcl_GetStringResult \ (tclStubsPtr->tcl_GetStringResult) /* 174 */ #define Tcl_GetVar \ (tclStubsPtr->tcl_GetVar) /* 175 */ #define Tcl_GetVar2 \ (tclStubsPtr->tcl_GetVar2) /* 176 */ #define Tcl_GlobalEval \ (tclStubsPtr->tcl_GlobalEval) /* 177 */ #define Tcl_GlobalEvalObj \ (tclStubsPtr->tcl_GlobalEvalObj) /* 178 */ #define Tcl_HideCommand \ (tclStubsPtr->tcl_HideCommand) /* 179 */ #define Tcl_Init \ (tclStubsPtr->tcl_Init) /* 180 */ #define Tcl_InitHashTable \ (tclStubsPtr->tcl_InitHashTable) /* 181 */ #define Tcl_InputBlocked \ |
| ︙ | ︙ | |||
2883 2884 2885 2886 2887 2888 2889 | (tclStubsPtr->tcl_Release) /* 216 */ #define Tcl_ResetResult \ (tclStubsPtr->tcl_ResetResult) /* 217 */ #define Tcl_ScanElement \ (tclStubsPtr->tcl_ScanElement) /* 218 */ #define Tcl_ScanCountedElement \ (tclStubsPtr->tcl_ScanCountedElement) /* 219 */ | > | > | > | > | > | > | > | > | > | > | > | > | > | > | | > > | > | > | > | > | | 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 | (tclStubsPtr->tcl_Release) /* 216 */ #define Tcl_ResetResult \ (tclStubsPtr->tcl_ResetResult) /* 217 */ #define Tcl_ScanElement \ (tclStubsPtr->tcl_ScanElement) /* 218 */ #define Tcl_ScanCountedElement \ (tclStubsPtr->tcl_ScanCountedElement) /* 219 */ #define Tcl_SeekOld \ (tclStubsPtr->tcl_SeekOld) /* 220 */ #define Tcl_ServiceAll \ (tclStubsPtr->tcl_ServiceAll) /* 221 */ #define Tcl_ServiceEvent \ (tclStubsPtr->tcl_ServiceEvent) /* 222 */ #define Tcl_SetAssocData \ (tclStubsPtr->tcl_SetAssocData) /* 223 */ #define Tcl_SetChannelBufferSize \ (tclStubsPtr->tcl_SetChannelBufferSize) /* 224 */ #define Tcl_SetChannelOption \ (tclStubsPtr->tcl_SetChannelOption) /* 225 */ #define Tcl_SetCommandInfo \ (tclStubsPtr->tcl_SetCommandInfo) /* 226 */ #define Tcl_SetErrno \ (tclStubsPtr->tcl_SetErrno) /* 227 */ #define Tcl_SetErrorCode \ (tclStubsPtr->tcl_SetErrorCode) /* 228 */ #define Tcl_SetMaxBlockTime \ (tclStubsPtr->tcl_SetMaxBlockTime) /* 229 */ #define Tcl_SetPanicProc \ (tclStubsPtr->tcl_SetPanicProc) /* 230 */ #define Tcl_SetRecursionLimit \ (tclStubsPtr->tcl_SetRecursionLimit) /* 231 */ #define Tcl_SetResult \ (tclStubsPtr->tcl_SetResult) /* 232 */ #define Tcl_SetServiceMode \ (tclStubsPtr->tcl_SetServiceMode) /* 233 */ #define Tcl_SetObjErrorCode \ (tclStubsPtr->tcl_SetObjErrorCode) /* 234 */ #define Tcl_SetObjResult \ (tclStubsPtr->tcl_SetObjResult) /* 235 */ #define Tcl_SetStdChannel \ (tclStubsPtr->tcl_SetStdChannel) /* 236 */ #define Tcl_SetVar \ (tclStubsPtr->tcl_SetVar) /* 237 */ #define Tcl_SetVar2 \ (tclStubsPtr->tcl_SetVar2) /* 238 */ #define Tcl_SignalId \ (tclStubsPtr->tcl_SignalId) /* 239 */ #define Tcl_SignalMsg \ (tclStubsPtr->tcl_SignalMsg) /* 240 */ #define Tcl_SourceRCFile \ (tclStubsPtr->tcl_SourceRCFile) /* 241 */ #define Tcl_SplitList \ (tclStubsPtr->tcl_SplitList) /* 242 */ #define Tcl_SplitPath \ (tclStubsPtr->tcl_SplitPath) /* 243 */ #define Tcl_StaticPackage \ (tclStubsPtr->tcl_StaticPackage) /* 244 */ #define Tcl_StringMatch \ (tclStubsPtr->tcl_StringMatch) /* 245 */ #define Tcl_TellOld \ (tclStubsPtr->tcl_TellOld) /* 246 */ #define Tcl_TraceVar \ (tclStubsPtr->tcl_TraceVar) /* 247 */ #define Tcl_TraceVar2 \ (tclStubsPtr->tcl_TraceVar2) /* 248 */ #define Tcl_TranslateFileName \ (tclStubsPtr->tcl_TranslateFileName) /* 249 */ #define Tcl_Ungets \ (tclStubsPtr->tcl_Ungets) /* 250 */ #define Tcl_UnlinkVar \ (tclStubsPtr->tcl_UnlinkVar) /* 251 */ #define Tcl_UnregisterChannel \ (tclStubsPtr->tcl_UnregisterChannel) /* 252 */ #define Tcl_UnsetVar \ (tclStubsPtr->tcl_UnsetVar) /* 253 */ #define Tcl_UnsetVar2 \ (tclStubsPtr->tcl_UnsetVar2) /* 254 */ #define Tcl_UntraceVar \ (tclStubsPtr->tcl_UntraceVar) /* 255 */ #define Tcl_UntraceVar2 \ (tclStubsPtr->tcl_UntraceVar2) /* 256 */ #define Tcl_UpdateLinkedVar \ (tclStubsPtr->tcl_UpdateLinkedVar) /* 257 */ #define Tcl_UpVar \ (tclStubsPtr->tcl_UpVar) /* 258 */ #define Tcl_UpVar2 \ (tclStubsPtr->tcl_UpVar2) /* 259 */ #define Tcl_VarEval \ (tclStubsPtr->tcl_VarEval) /* 260 */ #define Tcl_VarTraceInfo \ (tclStubsPtr->tcl_VarTraceInfo) /* 261 */ #define Tcl_VarTraceInfo2 \ (tclStubsPtr->tcl_VarTraceInfo2) /* 262 */ #define Tcl_Write \ (tclStubsPtr->tcl_Write) /* 263 */ #define Tcl_WrongNumArgs \ (tclStubsPtr->tcl_WrongNumArgs) /* 264 */ #define Tcl_DumpActiveMemory \ (tclStubsPtr->tcl_DumpActiveMemory) /* 265 */ #define Tcl_ValidateAllMemory \ (tclStubsPtr->tcl_ValidateAllMemory) /* 266 */ #define Tcl_AppendResultVA \ (tclStubsPtr->tcl_AppendResultVA) /* 267 */ #define Tcl_AppendStringsToObjVA \ (tclStubsPtr->tcl_AppendStringsToObjVA) /* 268 */ #define Tcl_HashStats \ (tclStubsPtr->tcl_HashStats) /* 269 */ #define Tcl_ParseVar \ (tclStubsPtr->tcl_ParseVar) /* 270 */ #define Tcl_PkgPresent \ (tclStubsPtr->tcl_PkgPresent) /* 271 */ #define Tcl_PkgPresentEx \ (tclStubsPtr->tcl_PkgPresentEx) /* 272 */ #define Tcl_PkgProvide \ (tclStubsPtr->tcl_PkgProvide) /* 273 */ #define Tcl_PkgRequire \ (tclStubsPtr->tcl_PkgRequire) /* 274 */ #define Tcl_SetErrorCodeVA \ (tclStubsPtr->tcl_SetErrorCodeVA) /* 275 */ #define Tcl_VarEvalVA \ (tclStubsPtr->tcl_VarEvalVA) /* 276 */ #define Tcl_WaitPid \ (tclStubsPtr->tcl_WaitPid) /* 277 */ #define Tcl_PanicVA \ (tclStubsPtr->tcl_PanicVA) /* 278 */ #define Tcl_GetVersion \ (tclStubsPtr->tcl_GetVersion) /* 279 */ #define Tcl_InitMemory \ (tclStubsPtr->tcl_InitMemory) /* 280 */ #define Tcl_StackChannel \ (tclStubsPtr->tcl_StackChannel) /* 281 */ #define Tcl_UnstackChannel \ |
| ︙ | ︙ | |||
3002 3003 3004 3005 3006 3007 3008 | (tclStubsPtr->tcl_AppendObjToObj) /* 286 */ #define Tcl_CreateEncoding \ (tclStubsPtr->tcl_CreateEncoding) /* 287 */ #define Tcl_CreateThreadExitHandler \ (tclStubsPtr->tcl_CreateThreadExitHandler) /* 288 */ #define Tcl_DeleteThreadExitHandler \ (tclStubsPtr->tcl_DeleteThreadExitHandler) /* 289 */ | > | | 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 | (tclStubsPtr->tcl_AppendObjToObj) /* 286 */ #define Tcl_CreateEncoding \ (tclStubsPtr->tcl_CreateEncoding) /* 287 */ #define Tcl_CreateThreadExitHandler \ (tclStubsPtr->tcl_CreateThreadExitHandler) /* 288 */ #define Tcl_DeleteThreadExitHandler \ (tclStubsPtr->tcl_DeleteThreadExitHandler) /* 289 */ #define Tcl_DiscardResult \ (tclStubsPtr->tcl_DiscardResult) /* 290 */ #define Tcl_EvalEx \ (tclStubsPtr->tcl_EvalEx) /* 291 */ #define Tcl_EvalObjv \ (tclStubsPtr->tcl_EvalObjv) /* 292 */ #define Tcl_EvalObjEx \ (tclStubsPtr->tcl_EvalObjEx) /* 293 */ #define Tcl_ExitThread \ |
| ︙ | ︙ | |||
3049 3050 3051 3052 3053 3054 3055 | (tclStubsPtr->tcl_ConditionNotify) /* 310 */ #define Tcl_ConditionWait \ (tclStubsPtr->tcl_ConditionWait) /* 311 */ #define Tcl_NumUtfChars \ (tclStubsPtr->tcl_NumUtfChars) /* 312 */ #define Tcl_ReadChars \ (tclStubsPtr->tcl_ReadChars) /* 313 */ | > | > | | 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 | (tclStubsPtr->tcl_ConditionNotify) /* 310 */ #define Tcl_ConditionWait \ (tclStubsPtr->tcl_ConditionWait) /* 311 */ #define Tcl_NumUtfChars \ (tclStubsPtr->tcl_NumUtfChars) /* 312 */ #define Tcl_ReadChars \ (tclStubsPtr->tcl_ReadChars) /* 313 */ #define Tcl_RestoreResult \ (tclStubsPtr->tcl_RestoreResult) /* 314 */ #define Tcl_SaveResult \ (tclStubsPtr->tcl_SaveResult) /* 315 */ #define Tcl_SetSystemEncoding \ (tclStubsPtr->tcl_SetSystemEncoding) /* 316 */ #define Tcl_SetVar2Ex \ (tclStubsPtr->tcl_SetVar2Ex) /* 317 */ #define Tcl_ThreadAlert \ (tclStubsPtr->tcl_ThreadAlert) /* 318 */ #define Tcl_ThreadQueueEvent \ |
| ︙ | ︙ | |||
3091 3092 3093 3094 3095 3096 3097 | (tclStubsPtr->tcl_UtfToExternal) /* 332 */ #define Tcl_UtfToExternalDString \ (tclStubsPtr->tcl_UtfToExternalDString) /* 333 */ #define Tcl_UtfToLower \ (tclStubsPtr->tcl_UtfToLower) /* 334 */ #define Tcl_UtfToTitle \ (tclStubsPtr->tcl_UtfToTitle) /* 335 */ | | | > | > | | 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 | (tclStubsPtr->tcl_UtfToExternal) /* 332 */ #define Tcl_UtfToExternalDString \ (tclStubsPtr->tcl_UtfToExternalDString) /* 333 */ #define Tcl_UtfToLower \ (tclStubsPtr->tcl_UtfToLower) /* 334 */ #define Tcl_UtfToTitle \ (tclStubsPtr->tcl_UtfToTitle) /* 335 */ #define Tcl_UtfToChar16 \ (tclStubsPtr->tcl_UtfToChar16) /* 336 */ #define Tcl_UtfToUpper \ (tclStubsPtr->tcl_UtfToUpper) /* 337 */ #define Tcl_WriteChars \ (tclStubsPtr->tcl_WriteChars) /* 338 */ #define Tcl_WriteObj \ (tclStubsPtr->tcl_WriteObj) /* 339 */ #define Tcl_GetString \ (tclStubsPtr->tcl_GetString) /* 340 */ #define Tcl_GetDefaultEncodingDir \ (tclStubsPtr->tcl_GetDefaultEncodingDir) /* 341 */ #define Tcl_SetDefaultEncodingDir \ (tclStubsPtr->tcl_SetDefaultEncodingDir) /* 342 */ #define Tcl_AlertNotifier \ (tclStubsPtr->tcl_AlertNotifier) /* 343 */ #define Tcl_ServiceModeHook \ (tclStubsPtr->tcl_ServiceModeHook) /* 344 */ #define Tcl_UniCharIsAlnum \ (tclStubsPtr->tcl_UniCharIsAlnum) /* 345 */ #define Tcl_UniCharIsAlpha \ |
| ︙ | ︙ | |||
3125 3126 3127 3128 3129 3130 3131 | (tclStubsPtr->tcl_UniCharIsUpper) /* 350 */ #define Tcl_UniCharIsWordChar \ (tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */ #define Tcl_UniCharLen \ (tclStubsPtr->tcl_UniCharLen) /* 352 */ #define Tcl_UniCharNcmp \ (tclStubsPtr->tcl_UniCharNcmp) /* 353 */ | | | | | > | | 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 | (tclStubsPtr->tcl_UniCharIsUpper) /* 350 */ #define Tcl_UniCharIsWordChar \ (tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */ #define Tcl_UniCharLen \ (tclStubsPtr->tcl_UniCharLen) /* 352 */ #define Tcl_UniCharNcmp \ (tclStubsPtr->tcl_UniCharNcmp) /* 353 */ #define Tcl_Char16ToUtfDString \ (tclStubsPtr->tcl_Char16ToUtfDString) /* 354 */ #define Tcl_UtfToChar16DString \ (tclStubsPtr->tcl_UtfToChar16DString) /* 355 */ #define Tcl_GetRegExpFromObj \ (tclStubsPtr->tcl_GetRegExpFromObj) /* 356 */ #define Tcl_EvalTokens \ (tclStubsPtr->tcl_EvalTokens) /* 357 */ #define Tcl_FreeParse \ (tclStubsPtr->tcl_FreeParse) /* 358 */ #define Tcl_LogCommandInfo \ (tclStubsPtr->tcl_LogCommandInfo) /* 359 */ #define Tcl_ParseBraces \ (tclStubsPtr->tcl_ParseBraces) /* 360 */ #define Tcl_ParseCommand \ |
| ︙ | ︙ | |||
3180 3181 3182 3183 3184 3185 3186 | (tclStubsPtr->tcl_NewUnicodeObj) /* 378 */ #define Tcl_SetUnicodeObj \ (tclStubsPtr->tcl_SetUnicodeObj) /* 379 */ #define Tcl_GetCharLength \ (tclStubsPtr->tcl_GetCharLength) /* 380 */ #define Tcl_GetUniChar \ (tclStubsPtr->tcl_GetUniChar) /* 381 */ | > | | 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 | (tclStubsPtr->tcl_NewUnicodeObj) /* 378 */ #define Tcl_SetUnicodeObj \ (tclStubsPtr->tcl_SetUnicodeObj) /* 379 */ #define Tcl_GetCharLength \ (tclStubsPtr->tcl_GetCharLength) /* 380 */ #define Tcl_GetUniChar \ (tclStubsPtr->tcl_GetUniChar) /* 381 */ #define Tcl_GetUnicode \ (tclStubsPtr->tcl_GetUnicode) /* 382 */ #define Tcl_GetRange \ (tclStubsPtr->tcl_GetRange) /* 383 */ #define Tcl_AppendUnicodeToObj \ (tclStubsPtr->tcl_AppendUnicodeToObj) /* 384 */ #define Tcl_RegExpMatchObj \ (tclStubsPtr->tcl_RegExpMatchObj) /* 385 */ #define Tcl_SetNotifier \ |
| ︙ | ︙ | |||
3257 3258 3259 3260 3261 3262 3263 | (tclStubsPtr->tcl_ClearChannelHandlers) /* 417 */ #define Tcl_IsChannelExisting \ (tclStubsPtr->tcl_IsChannelExisting) /* 418 */ #define Tcl_UniCharNcasecmp \ (tclStubsPtr->tcl_UniCharNcasecmp) /* 419 */ #define Tcl_UniCharCaseMatch \ (tclStubsPtr->tcl_UniCharCaseMatch) /* 420 */ | > | > | | 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 | (tclStubsPtr->tcl_ClearChannelHandlers) /* 417 */ #define Tcl_IsChannelExisting \ (tclStubsPtr->tcl_IsChannelExisting) /* 418 */ #define Tcl_UniCharNcasecmp \ (tclStubsPtr->tcl_UniCharNcasecmp) /* 419 */ #define Tcl_UniCharCaseMatch \ (tclStubsPtr->tcl_UniCharCaseMatch) /* 420 */ #define Tcl_FindHashEntry \ (tclStubsPtr->tcl_FindHashEntry) /* 421 */ #define Tcl_CreateHashEntry \ (tclStubsPtr->tcl_CreateHashEntry) /* 422 */ #define Tcl_InitCustomHashTable \ (tclStubsPtr->tcl_InitCustomHashTable) /* 423 */ #define Tcl_InitObjHashTable \ (tclStubsPtr->tcl_InitObjHashTable) /* 424 */ #define Tcl_CommandTraceInfo \ (tclStubsPtr->tcl_CommandTraceInfo) /* 425 */ #define Tcl_TraceCommand \ |
| ︙ | ︙ | |||
3283 3284 3285 3286 3287 3288 3289 | (tclStubsPtr->tcl_AttemptDbCkrealloc) /* 431 */ #define Tcl_AttemptSetObjLength \ (tclStubsPtr->tcl_AttemptSetObjLength) /* 432 */ #define Tcl_GetChannelThread \ (tclStubsPtr->tcl_GetChannelThread) /* 433 */ #define Tcl_GetUnicodeFromObj \ (tclStubsPtr->tcl_GetUnicodeFromObj) /* 434 */ | > | > | | 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 | (tclStubsPtr->tcl_AttemptDbCkrealloc) /* 431 */ #define Tcl_AttemptSetObjLength \ (tclStubsPtr->tcl_AttemptSetObjLength) /* 432 */ #define Tcl_GetChannelThread \ (tclStubsPtr->tcl_GetChannelThread) /* 433 */ #define Tcl_GetUnicodeFromObj \ (tclStubsPtr->tcl_GetUnicodeFromObj) /* 434 */ #define Tcl_GetMathFuncInfo \ (tclStubsPtr->tcl_GetMathFuncInfo) /* 435 */ #define Tcl_ListMathFuncs \ (tclStubsPtr->tcl_ListMathFuncs) /* 436 */ #define Tcl_SubstObj \ (tclStubsPtr->tcl_SubstObj) /* 437 */ #define Tcl_DetachChannel \ (tclStubsPtr->tcl_DetachChannel) /* 438 */ #define Tcl_IsStandardChannel \ (tclStubsPtr->tcl_IsStandardChannel) /* 439 */ #define Tcl_FSCopyFile \ |
| ︙ | ︙ | |||
3449 3450 3451 3452 3453 3454 3455 | (tclStubsPtr->tcl_FindCommand) /* 515 */ #define Tcl_GetCommandFromObj \ (tclStubsPtr->tcl_GetCommandFromObj) /* 516 */ #define Tcl_GetCommandFullName \ (tclStubsPtr->tcl_GetCommandFullName) /* 517 */ #define Tcl_FSEvalFileEx \ (tclStubsPtr->tcl_FSEvalFileEx) /* 518 */ | > | | 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 | (tclStubsPtr->tcl_FindCommand) /* 515 */ #define Tcl_GetCommandFromObj \ (tclStubsPtr->tcl_GetCommandFromObj) /* 516 */ #define Tcl_GetCommandFullName \ (tclStubsPtr->tcl_GetCommandFullName) /* 517 */ #define Tcl_FSEvalFileEx \ (tclStubsPtr->tcl_FSEvalFileEx) /* 518 */ #define Tcl_SetExitProc \ (tclStubsPtr->tcl_SetExitProc) /* 519 */ #define Tcl_LimitAddHandler \ (tclStubsPtr->tcl_LimitAddHandler) /* 520 */ #define Tcl_LimitRemoveHandler \ (tclStubsPtr->tcl_LimitRemoveHandler) /* 521 */ #define Tcl_LimitReady \ (tclStubsPtr->tcl_LimitReady) /* 522 */ #define Tcl_LimitCheck \ |
| ︙ | ︙ | |||
3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 | (tclStubsPtr->tcl_DecrRefCount) /* 642 */ #define Tcl_IsShared \ (tclStubsPtr->tcl_IsShared) /* 643 */ #define Tcl_LinkArray \ (tclStubsPtr->tcl_LinkArray) /* 644 */ #define Tcl_GetIntForIndex \ (tclStubsPtr->tcl_GetIntForIndex) /* 645 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #if defined(USE_TCL_STUBS) # undef Tcl_CreateInterp # undef Tcl_Init # undef Tcl_ObjSetVar2 # define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp()) # define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp)) # define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \ (tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags)) #endif #if defined(_WIN32) && defined(UNICODE) # define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg))) # define Tcl_MainEx Tcl_MainExW | > > > > > > > > > > > > | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > | | > | > | | | > > > > > > > > > > > > > < < < < | < < < < < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | | | | | < | < | < < | | < < < < < < < < < < < < < < < < < < < < | 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 |
(tclStubsPtr->tcl_DecrRefCount) /* 642 */
#define Tcl_IsShared \
(tclStubsPtr->tcl_IsShared) /* 643 */
#define Tcl_LinkArray \
(tclStubsPtr->tcl_LinkArray) /* 644 */
#define Tcl_GetIntForIndex \
(tclStubsPtr->tcl_GetIntForIndex) /* 645 */
#define Tcl_UtfToUniChar \
(tclStubsPtr->tcl_UtfToUniChar) /* 646 */
#define Tcl_UniCharToUtfDString \
(tclStubsPtr->tcl_UniCharToUtfDString) /* 647 */
#define Tcl_UtfToUniCharDString \
(tclStubsPtr->tcl_UtfToUniCharDString) /* 648 */
#endif /* defined(USE_TCL_STUBS) */
/* !END!: Do not edit above this line. */
#if defined(USE_TCL_STUBS)
# undef Tcl_CreateInterp
# undef Tcl_FindExecutable
# undef Tcl_GetStringResult
# undef Tcl_Init
# undef Tcl_SetPanicProc
# undef Tcl_SetExitProc
# undef Tcl_ObjSetVar2
# undef Tcl_StaticPackage
# define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp())
# define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp))
# define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp))
# define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \
(tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags))
#endif
#if defined(_WIN32) && defined(UNICODE)
# define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg)))
# define Tcl_MainEx Tcl_MainExW
EXTERN void Tcl_MainExW(int argc, wchar_t **argv,
Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
#endif
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
#undef Tcl_SeekOld
#undef Tcl_TellOld
#undef Tcl_PkgPresent
#define Tcl_PkgPresent(interp, name, version, exact) \
Tcl_PkgPresentEx(interp, name, version, exact, NULL)
#undef Tcl_PkgProvide
#define Tcl_PkgProvide(interp, name, version) \
Tcl_PkgProvideEx(interp, name, version, NULL)
#undef Tcl_PkgRequire
#define Tcl_PkgRequire(interp, name, version, exact) \
Tcl_PkgRequireEx(interp, name, version, exact, NULL)
#undef Tcl_GetIndexFromObj
#define Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) \
Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, \
sizeof(char *), msg, flags, indexPtr)
#undef Tcl_NewBooleanObj
#define Tcl_NewBooleanObj(boolValue) \
Tcl_NewWideIntObj((boolValue)!=0)
#undef Tcl_DbNewBooleanObj
#define Tcl_DbNewBooleanObj(boolValue, file, line) \
Tcl_DbNewWideIntObj((boolValue)!=0, file, line)
#undef Tcl_SetBooleanObj
#define Tcl_SetBooleanObj(objPtr, boolValue) \
Tcl_SetWideIntObj(objPtr, (boolValue)!=0)
#undef Tcl_SetVar
#define Tcl_SetVar(interp, varName, newValue, flags) \
Tcl_SetVar2(interp, varName, NULL, newValue, flags)
#undef Tcl_UnsetVar
#define Tcl_UnsetVar(interp, varName, flags) \
Tcl_UnsetVar2(interp, varName, NULL, flags)
#undef Tcl_GetVar
#define Tcl_GetVar(interp, varName, flags) \
Tcl_GetVar2(interp, varName, NULL, flags)
#undef Tcl_TraceVar
#define Tcl_TraceVar(interp, varName, flags, proc, clientData) \
Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData)
#undef Tcl_UntraceVar
#define Tcl_UntraceVar(interp, varName, flags, proc, clientData) \
Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData)
#undef Tcl_VarTraceInfo
#define Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) \
Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, prevClientData)
#undef Tcl_UpVar
#define Tcl_UpVar(interp, frameName, varName, localName, flags) \
Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags)
#undef Tcl_AddErrorInfo
#define Tcl_AddErrorInfo(interp, message) \
Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, -1))
#undef Tcl_AddObjErrorInfo
#define Tcl_AddObjErrorInfo(interp, message, length) \
Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length))
#ifdef TCL_NO_DEPRECATED
#undef Tcl_FreeResult
#undef Tcl_AppendResultVA
#undef Tcl_AppendStringsToObjVA
#undef Tcl_SetErrorCodeVA
#undef Tcl_VarEvalVA
#undef Tcl_PanicVA
#undef Tcl_GetStringResult
#undef Tcl_GetDefaultEncodingDir
#undef Tcl_SetDefaultEncodingDir
#undef Tcl_UniCharLen
#undef Tcl_UniCharNcmp
#undef Tcl_EvalTokens
#undef Tcl_UniCharNcasecmp
#undef Tcl_UniCharCaseMatch
#undef Tcl_GetMathFuncInfo
#undef Tcl_ListMathFuncs
#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp))
#undef Tcl_Eval
#define Tcl_Eval(interp, objPtr) \
Tcl_EvalEx(interp, objPtr, -1, 0)
#undef Tcl_GlobalEval
#define Tcl_GlobalEval(interp, objPtr) \
Tcl_EvalEx(interp, objPtr, -1, TCL_EVAL_GLOBAL)
#undef Tcl_SaveResult
#define Tcl_SaveResult(interp, statePtr) \
do { \
(statePtr)->objResultPtr = Tcl_GetObjResult(interp); \
Tcl_IncrRefCount((statePtr)->objResultPtr); \
Tcl_SetObjResult(interp, Tcl_NewObj()); \
} while(0)
#undef Tcl_RestoreResult
#define Tcl_RestoreResult(interp, statePtr) \
do { \
Tcl_ResetResult(interp); \
Tcl_SetObjResult(interp, (statePtr)->objResultPtr); \
Tcl_DecrRefCount((statePtr)->objResultPtr); \
} while(0)
#undef Tcl_DiscardResult
#define Tcl_DiscardResult(statePtr) \
Tcl_DecrRefCount((statePtr)->objResultPtr)
#undef Tcl_SetResult
#define Tcl_SetResult(interp, result, freeProc) \
do { \
const char *__result = result; \
Tcl_FreeProc *__freeProc = freeProc; \
Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, -1)); \
if (__result != NULL && __freeProc != NULL && __freeProc != TCL_VOLATILE) { \
if (__freeProc == TCL_DYNAMIC) { \
ckfree((char *)__result); \
} else { \
(*__freeProc)((char *)__result); \
} \
} \
} while(0)
#endif /* TCL_NO_DEPRECATED */
#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
# if defined(__CYGWIN__) && defined(TCL_WIDE_INT_IS_LONG)
/* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore
* we have to make sure that all stub entries on Cygwin64 follow the
* Win64 signature. Cygwin64 stubbed extensions cannot use those stub
* entries any more, they should use the 64-bit alternatives where
* possible. Tcl 9 must find a better solution, but that cannot be done
* without introducing a binary incompatibility.
*/
# undef Tcl_GetLongFromObj
# undef Tcl_ExprLong
# undef Tcl_ExprLongObj
# undef Tcl_UniCharNcmp
# undef Tcl_UtfNcmp
# undef Tcl_UtfNcasecmp
# undef Tcl_UniCharNcasecmp
# define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj)
# define Tcl_ExprLong TclExprLong
static inline int TclExprLong(Tcl_Interp *interp, const char *string, long *ptr){
int intValue;
int result = tclStubsPtr->tcl_ExprLong(interp, string, (long *)&intValue);
if (result == TCL_OK) *ptr = (long)intValue;
return result;
}
# define Tcl_ExprLongObj TclExprLongObj
static inline int TclExprLongObj(Tcl_Interp *interp, Tcl_Obj *obj, long *ptr){
int intValue;
int result = tclStubsPtr->tcl_ExprLongObj(interp, obj, (long *)&intValue);
if (result == TCL_OK) *ptr = (long)intValue;
return result;
}
# define Tcl_UniCharNcmp(ucs,uct,n) \
((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcmp)(ucs,uct,(unsigned int)(n))
# define Tcl_UtfNcmp(s1,s2,n) \
((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcmp)(s1,s2,(unsigned int)(n))
# define Tcl_UtfNcasecmp(s1,s2,n) \
((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcasecmp)(s1,s2,(unsigned int)(n))
# define Tcl_UniCharNcasecmp(ucs,uct,n) \
((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcasecmp)(ucs,uct,(unsigned int)(n))
# endif
#endif
#undef Tcl_NewLongObj
#define Tcl_NewLongObj(value) Tcl_NewWideIntObj((long)(value))
#undef Tcl_NewIntObj
#define Tcl_NewIntObj(value) Tcl_NewWideIntObj((int)(value))
#undef Tcl_DbNewLongObj
#define Tcl_DbNewLongObj(value, file, line) Tcl_DbNewWideIntObj((long)(value), file, line)
#undef Tcl_SetIntObj
#define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (int)(value))
#undef Tcl_SetLongObj
#define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (long)(value))
#undef Tcl_GetUnicode
#define Tcl_GetUnicode(objPtr) Tcl_GetUnicodeFromObj((objPtr), NULL)
#undef Tcl_BackgroundError
#define Tcl_BackgroundError(interp) Tcl_BackgroundException((interp), TCL_ERROR)
#undef Tcl_StringMatch
#define Tcl_StringMatch(str, pattern) Tcl_StringCaseMatch((str), (pattern), 0)
#if TCL_UTF_MAX <= 3
# undef Tcl_UniCharToUtfDString
# define Tcl_UniCharToUtfDString Tcl_Char16ToUtfDString
# undef Tcl_UtfToUniCharDString
# define Tcl_UtfToUniCharDString Tcl_UtfToChar16DString
# undef Tcl_UtfToUniChar
# define Tcl_UtfToUniChar Tcl_UtfToChar16
#endif
#if defined(USE_TCL_STUBS)
# define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \
? (char *(*)(const wchar_t *, int, Tcl_DString *))tclStubsPtr->tcl_UniCharToUtfDString \
: (char *(*)(const wchar_t *, int, Tcl_DString *))Tcl_Char16ToUtfDString)
# define Tcl_UtfToWCharDString (sizeof(wchar_t) != sizeof(short) \
? (wchar_t *(*)(const char *, int, Tcl_DString *))tclStubsPtr->tcl_UtfToUniCharDString \
: (wchar_t *(*)(const char *, int, Tcl_DString *))Tcl_UtfToChar16DString)
# define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \
? (int (*)(const char *, wchar_t *))tclStubsPtr->tcl_UtfToChar16 \
: (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar)
#else
# define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \
? (char *(*)(const wchar_t *, int, Tcl_DString *))Tcl_UniCharToUtfDString \
: (char *(*)(const wchar_t *, int, Tcl_DString *))Tcl_Char16ToUtfDString)
# define Tcl_UtfToWCharDString (sizeof(wchar_t) != sizeof(short) \
? (wchar_t *(*)(const char *, int, Tcl_DString *))Tcl_UtfToUniCharDString \
: (wchar_t *(*)(const char *, int, Tcl_DString *))Tcl_UtfToChar16DString)
# define Tcl_UtfToWChar (sizeof(wchar_t) != sizeof(short) \
? (int (*)(const char *, wchar_t *))Tcl_UtfToChar16 \
: (int (*)(const char *, wchar_t *))Tcl_UtfToUniChar)
#endif
/*
* Deprecated Tcl procedures:
*/
#undef Tcl_EvalObj
#define Tcl_EvalObj(interp, objPtr) \
Tcl_EvalObjEx(interp, objPtr, 0)
#undef Tcl_GlobalEvalObj
#define Tcl_GlobalEvalObj(interp, objPtr) \
Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL)
#if defined(TCL_NO_DEPRECATED) && defined(USE_TCL_STUBS)
#undef Tcl_Close
#define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0)
#endif
#if defined(USE_TCL_STUBS) && (TCL_UTF_MAX > 3)
# undef Tcl_UtfCharComplete
# define Tcl_UtfCharComplete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \
? ((length) >= 4) : tclStubsPtr->tcl_UtfCharComplete((src), (length)))
#endif
#endif /* _TCLDECLS */
|
Changes to generic/tclDictObj.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclDictObj.c -- * * This file contains functions that implement the Tcl dict object type * and its accessor command. * * Copyright (c) 2002-2010 by Donal K. Fellows. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" | | | | < | < | < | < | < | < | < | < | < | | | | | | | | | < < < < < < < < < | < | | | | | | | | | | | > | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 |
/*
* tclDictObj.c --
*
* This file contains functions that implement the Tcl dict object type
* and its accessor command.
*
* Copyright (c) 2002-2010 by Donal K. Fellows.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclTomMath.h"
#include <assert.h>
/*
* Forward declaration.
*/
struct Dict;
/*
* Prototypes for functions defined later in this file:
*/
static void DeleteDict(struct Dict *dict);
static Tcl_ObjCmdProc DictAppendCmd;
static Tcl_ObjCmdProc DictCreateCmd;
static Tcl_ObjCmdProc DictExistsCmd;
static Tcl_ObjCmdProc DictFilterCmd;
static Tcl_ObjCmdProc DictGetCmd;
static Tcl_ObjCmdProc DictGetDefCmd;
static Tcl_ObjCmdProc DictIncrCmd;
static Tcl_ObjCmdProc DictInfoCmd;
static Tcl_ObjCmdProc DictKeysCmd;
static Tcl_ObjCmdProc DictLappendCmd;
static Tcl_ObjCmdProc DictMergeCmd;
static Tcl_ObjCmdProc DictRemoveCmd;
static Tcl_ObjCmdProc DictReplaceCmd;
static Tcl_ObjCmdProc DictSetCmd;
static Tcl_ObjCmdProc DictSizeCmd;
static Tcl_ObjCmdProc DictUnsetCmd;
static Tcl_ObjCmdProc DictUpdateCmd;
static Tcl_ObjCmdProc DictValuesCmd;
static Tcl_ObjCmdProc DictWithCmd;
static Tcl_DupInternalRepProc DupDictInternalRep;
static Tcl_FreeInternalRepProc FreeDictInternalRep;
static void InvalidateDictChain(Tcl_Obj *dictObj);
static Tcl_SetFromAnyProc SetDictFromAny;
static Tcl_UpdateStringProc UpdateStringOfDict;
static Tcl_AllocHashEntryProc AllocChainEntry;
static inline void InitChainTable(struct Dict *dict);
static inline void DeleteChainTable(struct Dict *dict);
static inline Tcl_HashEntry * CreateChainEntry(struct Dict *dict,
Tcl_Obj *keyPtr, int *newPtr);
static inline int DeleteChainEntry(struct Dict *dict,
Tcl_Obj *keyPtr);
static Tcl_NRPostProc FinalizeDictUpdate;
static Tcl_NRPostProc FinalizeDictWith;
static Tcl_ObjCmdProc DictForNRCmd;
static Tcl_ObjCmdProc DictMapNRCmd;
static Tcl_NRPostProc DictForLoopCallback;
static Tcl_NRPostProc DictMapLoopCallback;
/*
* Table of dict subcommand names and implementations.
*/
static const EnsembleImplMap implementationMap[] = {
{"append", DictAppendCmd, TclCompileDictAppendCmd, NULL, NULL, 0 },
|
| ︙ | ︙ | |||
143 144 145 146 147 148 149 |
* dictionary. Used for doing traversal of the
* entries in the order that they are
* created. */
ChainEntry *entryChainTail; /* Other end of linked list of all entries in
* the dictionary. Used for doing traversal of
* the entries in the order that they are
* created. */
| | | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 |
* dictionary. Used for doing traversal of the
* entries in the order that they are
* created. */
ChainEntry *entryChainTail; /* Other end of linked list of all entries in
* the dictionary. Used for doing traversal of
* the entries in the order that they are
* created. */
unsigned int epoch; /* Epoch counter */
size_t refCount; /* Reference counter (see above) */
Tcl_Obj *chain; /* Linked list used for invalidating the
* string representations of updated nested
* dictionaries. */
} Dict;
/*
|
| ︙ | ︙ | |||
175 176 177 178 179 180 181 |
Tcl_StoreIntRep((objPtr), &tclDictType, &ir); \
} while (0)
#define DictGetIntRep(objPtr, dictRepPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &tclDictType); \
| | | 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 |
Tcl_StoreIntRep((objPtr), &tclDictType, &ir); \
} while (0)
#define DictGetIntRep(objPtr, dictRepPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &tclDictType); \
(dictRepPtr) = irPtr ? (Dict *)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
* The type of the specially adapted version of the Tcl_Obj*-containing hash
* table defined in the tclObj.c code. This version differs in that it
* allocates a bit more space in each hash entry in order to hold the pointers
* used to keep the hash entries in a linked list.
|
| ︙ | ︙ | |||
236 237 238 239 240 241 242 | * Increments the reference count on the object. * *---------------------------------------------------------------------- */ static Tcl_HashEntry * AllocChainEntry( | | | | | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 |
* Increments the reference count on the object.
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
AllocChainEntry(
TCL_UNUSED(Tcl_HashTable *),
void *keyPtr)
{
Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
ChainEntry *cPtr;
cPtr = (ChainEntry *)ckalloc(sizeof(ChainEntry));
cPtr->entry.key.objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
cPtr->entry.clientData = NULL;
cPtr->prevPtr = cPtr->nextPtr = NULL;
return &cPtr->entry;
}
/*
* Helper functions that disguise most of the details relating to how the
|
| ︙ | ︙ | |||
275 276 277 278 279 280 281 |
static inline void
DeleteChainTable(
Dict *dict)
{
ChainEntry *cPtr;
for (cPtr=dict->entryChainHead ; cPtr!=NULL ; cPtr=cPtr->nextPtr) {
| | | 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 |
static inline void
DeleteChainTable(
Dict *dict)
{
ChainEntry *cPtr;
for (cPtr=dict->entryChainHead ; cPtr!=NULL ; cPtr=cPtr->nextPtr) {
Tcl_Obj *valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
TclDecrRefCount(valuePtr);
}
Tcl_DeleteHashTable(&dict->table);
}
static inline Tcl_HashEntry *
|
| ︙ | ︙ | |||
322 323 324 325 326 327 328 |
{
ChainEntry *cPtr = (ChainEntry *)
Tcl_FindHashEntry(&dict->table, keyPtr);
if (cPtr == NULL) {
return 0;
} else {
| | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 |
{
ChainEntry *cPtr = (ChainEntry *)
Tcl_FindHashEntry(&dict->table, keyPtr);
if (cPtr == NULL) {
return 0;
} else {
Tcl_Obj *valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
TclDecrRefCount(valuePtr);
}
/*
* Unstitch from the chain.
*/
|
| ︙ | ︙ | |||
373 374 375 376 377 378 379 |
*/
static void
DupDictInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
| | | | | 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 |
*/
static void
DupDictInternalRep(
Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr)
{
Dict *oldDict, *newDict = (Dict *)ckalloc(sizeof(Dict));
ChainEntry *cPtr;
DictGetIntRep(srcPtr, oldDict);
/*
* Copy values across from the old hash table.
*/
InitChainTable(newDict);
for (cPtr=oldDict->entryChainHead ; cPtr!=NULL ; cPtr=cPtr->nextPtr) {
Tcl_Obj *key = (Tcl_Obj *)Tcl_GetHashKey(&oldDict->table, &cPtr->entry);
Tcl_Obj *valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
int n;
Tcl_HashEntry *hPtr = CreateChainEntry(newDict, key, &n);
/*
* Fill in the contents.
*/
|
| ︙ | ︙ | |||
468 469 470 471 472 473 474 |
*/
static void
DeleteDict(
Dict *dict)
{
DeleteChainTable(dict);
| | | 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 |
*/
static void
DeleteDict(
Dict *dict)
{
DeleteChainTable(dict);
ckfree(dict);
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfDict --
*
|
| ︙ | ︙ | |||
502 503 504 505 506 507 508 |
Tcl_Obj *dictPtr)
{
#define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
Dict *dict;
ChainEntry *cPtr;
Tcl_Obj *keyPtr, *valuePtr;
| | | | | > > > > | > > > > > > | | | | 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 |
Tcl_Obj *dictPtr)
{
#define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
Dict *dict;
ChainEntry *cPtr;
Tcl_Obj *keyPtr, *valuePtr;
int i, length, bytesNeeded = 0;
const char *elem;
char *dst;
/*
* This field is the most useful one in the whole hash structure, and it
* is not exposed by any API function...
*/
int numElems;
DictGetIntRep(dictPtr, dict);
assert (dict != NULL);
numElems = dict->table.numEntries * 2;
/* Handle empty list case first, simplifies what follows */
if (numElems == 0) {
Tcl_InitStringRep(dictPtr, NULL, 0);
return;
}
/*
* Pass 1: estimate space, gather flags.
*/
if (numElems <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
flagPtr = (char *)ckalloc(numElems);
}
for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) {
/*
* Assume that cPtr is never NULL since we know the number of array
* elements already.
*/
flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry);
elem = TclGetStringFromObj(keyPtr, &length);
bytesNeeded += TclScanElement(elem, length, flagPtr+i);
if (bytesNeeded < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
flagPtr[i+1] = TCL_DONT_QUOTE_HASH;
valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
elem = TclGetStringFromObj(valuePtr, &length);
bytesNeeded += TclScanElement(elem, length, flagPtr+i+1);
if (bytesNeeded < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
}
if (bytesNeeded > INT_MAX - numElems + 1) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
bytesNeeded += numElems;
/*
* Pass 2: copy into string rep buffer.
*/
dst = Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1);
TclOOM(dst, bytesNeeded);
for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) {
flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 );
keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry);
elem = TclGetStringFromObj(keyPtr, &length);
dst += TclConvertElement(elem, length, dst, flagPtr[i]);
*dst++ = ' ';
flagPtr[i+1] |= TCL_DONT_QUOTE_HASH;
valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
elem = TclGetStringFromObj(valuePtr, &length);
dst += TclConvertElement(elem, length, dst, flagPtr[i+1]);
*dst++ = ' ';
}
(void)Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1);
if (flagPtr != localFlags) {
ckfree(flagPtr);
}
}
/*
*----------------------------------------------------------------------
*
* SetDictFromAny --
|
| ︙ | ︙ | |||
604 605 606 607 608 609 610 |
static int
SetDictFromAny(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
Tcl_HashEntry *hPtr;
int isNew;
| | | 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 |
static int
SetDictFromAny(
Tcl_Interp *interp,
Tcl_Obj *objPtr)
{
Tcl_HashEntry *hPtr;
int isNew;
Dict *dict = (Dict *)ckalloc(sizeof(Dict));
InitChainTable(dict);
/*
* Since lists and dictionaries have very closely-related string
* representations (i.e. the same parsing code) we can safely special-case
* the conversion from lists to dictionaries.
|
| ︙ | ︙ | |||
629 630 631 632 633 634 635 |
}
for (i=0 ; i<objc ; i+=2) {
/* Store key and value in the hash table we're building. */
hPtr = CreateChainEntry(dict, objv[i], &isNew);
if (!isNew) {
| | | | | < | 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 |
}
for (i=0 ; i<objc ; i+=2) {
/* Store key and value in the hash table we're building. */
hPtr = CreateChainEntry(dict, objv[i], &isNew);
if (!isNew) {
Tcl_Obj *discardedValue = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
/*
* Not really a well-formed dictionary as there are duplicate
* keys, so better get the string rep here so that we can
* convert back.
*/
(void) Tcl_GetString(objPtr);
TclDecrRefCount(discardedValue);
}
Tcl_SetHashValue(hPtr, objv[i+1]);
Tcl_IncrRefCount(objv[i+1]); /* Since hash now holds ref to it */
}
} else {
int length;
const char *nextElem = TclGetStringFromObj(objPtr, &length);
const char *limit = (nextElem + length);
while (nextElem < limit) {
Tcl_Obj *keyPtr, *valuePtr;
const char *elemStart;
int elemSize, literal;
if (TclFindDictElement(interp, nextElem, (limit - nextElem),
&elemStart, &nextElem, &elemSize, &literal) != TCL_OK) {
goto errorInFindDictElement;
}
if (elemStart == limit) {
break;
|
| ︙ | ︙ | |||
703 704 705 706 707 708 709 |
(void)Tcl_InitStringRep(valuePtr, NULL,
TclCopyAndCollapse(elemSize, elemStart, dst));
}
/* Store key and value in the hash table we're building. */
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
if (!isNew) {
| | | 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 |
(void)Tcl_InitStringRep(valuePtr, NULL,
TclCopyAndCollapse(elemSize, elemStart, dst));
}
/* Store key and value in the hash table we're building. */
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
if (!isNew) {
Tcl_Obj *discardedValue = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
TclDecrRefCount(keyPtr);
TclDecrRefCount(discardedValue);
}
Tcl_SetHashValue(hPtr, valuePtr);
Tcl_IncrRefCount(valuePtr); /* since hash now holds ref to it */
}
|
| ︙ | ︙ | |||
733 734 735 736 737 738 739 |
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing value to go with key", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
}
errorInFindDictElement:
DeleteChainTable(dict);
| | | 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 |
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing value to go with key", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
}
errorInFindDictElement:
DeleteChainTable(dict);
ckfree(dict);
return TCL_ERROR;
}
static Dict *
GetDictFromObj(
Tcl_Interp *interp,
Tcl_Obj *dictPtr)
|
| ︙ | ︙ | |||
838 839 840 841 842 843 844 |
*/
hPtr = CreateChainEntry(dict, keyv[i], &isNew);
tmpObj = Tcl_NewDictObj();
Tcl_IncrRefCount(tmpObj);
Tcl_SetHashValue(hPtr, tmpObj);
} else {
| | | 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 |
*/
hPtr = CreateChainEntry(dict, keyv[i], &isNew);
tmpObj = Tcl_NewDictObj();
Tcl_IncrRefCount(tmpObj);
Tcl_SetHashValue(hPtr, tmpObj);
} else {
tmpObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
DictGetIntRep(tmpObj, newDict);
if (newDict == NULL) {
if (SetDictFromAny(interp, tmpObj) != TCL_OK) {
return NULL;
}
|
| ︙ | ︙ | |||
959 960 961 962 963 964 965 |
TclInvalidateStringRep(dictPtr);
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
dict->refCount++;
TclFreeIntRep(dictPtr)
DictSetIntRep(dictPtr, dict);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
| | | 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 |
TclInvalidateStringRep(dictPtr);
hPtr = CreateChainEntry(dict, keyPtr, &isNew);
dict->refCount++;
TclFreeIntRep(dictPtr)
DictSetIntRep(dictPtr, dict);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
Tcl_Obj *oldValuePtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
TclDecrRefCount(oldValuePtr);
}
Tcl_SetHashValue(hPtr, valuePtr);
dict->epoch++;
return TCL_OK;
}
|
| ︙ | ︙ | |||
1008 1009 1010 1011 1012 1013 1014 |
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&dict->table, keyPtr);
if (hPtr == NULL) {
*valuePtrPtr = NULL;
} else {
| | | 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 |
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(&dict->table, keyPtr);
if (hPtr == NULL) {
*valuePtrPtr = NULL;
} else {
*valuePtrPtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1149 1150 1151 1152 1153 1154 1155 |
} else {
*donePtr = 0;
searchPtr->dictionaryPtr = (Tcl_Dict) dict;
searchPtr->epoch = dict->epoch;
searchPtr->next = cPtr->nextPtr;
dict->refCount++;
if (keyPtrPtr != NULL) {
| | | | 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 |
} else {
*donePtr = 0;
searchPtr->dictionaryPtr = (Tcl_Dict) dict;
searchPtr->epoch = dict->epoch;
searchPtr->next = cPtr->nextPtr;
dict->refCount++;
if (keyPtrPtr != NULL) {
*keyPtrPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry);
}
if (valuePtrPtr != NULL) {
*valuePtrPtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1215 1216 1217 1218 1219 1220 1221 |
* removed. This *shouldn't* happen, but...
*/
if (((Dict *)searchPtr->dictionaryPtr)->epoch != searchPtr->epoch) {
Tcl_Panic("concurrent dictionary modification and search");
}
| | | | | 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 |
* removed. This *shouldn't* happen, but...
*/
if (((Dict *)searchPtr->dictionaryPtr)->epoch != searchPtr->epoch) {
Tcl_Panic("concurrent dictionary modification and search");
}
cPtr = (ChainEntry *)searchPtr->next;
if (cPtr == NULL) {
Tcl_DictObjDone(searchPtr);
*donePtr = 1;
return;
}
searchPtr->next = cPtr->nextPtr;
*donePtr = 0;
if (keyPtrPtr != NULL) {
*keyPtrPtr = (Tcl_Obj *)Tcl_GetHashKey(
&((Dict *)searchPtr->dictionaryPtr)->table, &cPtr->entry);
}
if (valuePtrPtr != NULL) {
*valuePtrPtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_DictObjDone --
|
| ︙ | ︙ | |||
1316 1317 1318 1319 1320 1321 1322 |
}
DictGetIntRep(dictPtr, dict);
assert(dict != NULL);
hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
| | | 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 |
}
DictGetIntRep(dictPtr, dict);
assert(dict != NULL);
hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew);
Tcl_IncrRefCount(valuePtr);
if (!isNew) {
Tcl_Obj *oldValuePtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
TclDecrRefCount(oldValuePtr);
}
Tcl_SetHashValue(hPtr, valuePtr);
InvalidateDictChain(dictPtr);
return TCL_OK;
|
| ︙ | ︙ | |||
1411 1412 1413 1414 1415 1416 1417 |
#else /* !TCL_MEM_DEBUG */
Tcl_Obj *dictPtr;
Dict *dict;
TclNewObj(dictPtr);
TclInvalidateStringRep(dictPtr);
| | | 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 |
#else /* !TCL_MEM_DEBUG */
Tcl_Obj *dictPtr;
Dict *dict;
TclNewObj(dictPtr);
TclInvalidateStringRep(dictPtr);
dict = (Dict *)ckalloc(sizeof(Dict));
InitChainTable(dict);
dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
DictSetIntRep(dictPtr, dict);
return dictPtr;
#endif
|
| ︙ | ︙ | |||
1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 |
*
* Side Effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_DbNewDictObj(
const char *file,
int line)
{
| > < | > > > > > > < > | 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 |
*
* Side Effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewDictObj(
const char *file,
int line)
{
Tcl_Obj *dictPtr;
Dict *dict;
TclDbNewObj(dictPtr, file, line);
TclInvalidateStringRep(dictPtr);
dict = (Dict *)ckalloc(sizeof(Dict));
InitChainTable(dict);
dict->epoch = 1;
dict->chain = NULL;
dict->refCount = 1;
DictSetIntRep(dictPtr, dict);
return dictPtr;
}
#else /* !TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewDictObj(
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewDictObj();
}
#endif
/***** START OF FUNCTIONS IMPLEMENTING TCL COMMANDS *****/
/*
*----------------------------------------------------------------------
*
* DictCreateCmd --
|
| ︙ | ︙ | |||
1493 1494 1495 1496 1497 1498 1499 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictCreateCmd( | | | 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictCreateCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictObj;
int i;
|
| ︙ | ︙ | |||
1543 1544 1545 1546 1547 1548 1549 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictGetCmd( | | | 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictGetCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr = NULL;
int result;
|
| ︙ | ︙ | |||
1636 1637 1638 1639 1640 1641 1642 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictGetDefCmd( | | | 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictGetDefCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *keyPtr, *valuePtr, *defaultPtr;
Tcl_Obj *const *keyPath;
int numKeys;
|
| ︙ | ︙ | |||
1701 1702 1703 1704 1705 1706 1707 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictReplaceCmd( | | | 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictReplaceCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr;
int i;
|
| ︙ | ︙ | |||
1749 1750 1751 1752 1753 1754 1755 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictRemoveCmd( | | | 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictRemoveCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr;
int i;
|
| ︙ | ︙ | |||
1797 1798 1799 1800 1801 1802 1803 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictMergeCmd( | | | 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictMergeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *targetObj, *keyObj = NULL, *valueObj = NULL;
int allocatedDict = 0;
int i, done;
|
| ︙ | ︙ | |||
1884 1885 1886 1887 1888 1889 1890 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictKeysCmd( | | | 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictKeysCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *listPtr;
const char *pattern = NULL;
|
| ︙ | ︙ | |||
1963 1964 1965 1966 1967 1968 1969 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictValuesCmd( | | | 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictValuesCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *valuePtr = NULL, *listPtr;
Tcl_DictSearch search;
int done;
|
| ︙ | ︙ | |||
2023 2024 2025 2026 2027 2028 2029 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictSizeCmd( | | | 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictSizeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
int result, size;
if (objc != 2) {
|
| ︙ | ︙ | |||
2061 2062 2063 2064 2065 2066 2067 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictExistsCmd( | | | 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictExistsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr;
if (objc < 3) {
|
| ︙ | ︙ | |||
2103 2104 2105 2106 2107 2108 2109 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictInfoCmd( | | | | 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 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictInfoCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Dict *dict;
char *statsStr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "dictionary");
return TCL_ERROR;
}
dict = GetDictFromObj(interp, objv[1]);
if (dict == NULL) {
return TCL_ERROR;
}
statsStr = Tcl_HashStats(&dict->table);
Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1));
ckfree(statsStr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* DictIncrCmd --
|
| ︙ | ︙ | |||
2147 2148 2149 2150 2151 2152 2153 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictIncrCmd( | | | 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictIncrCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
int code = TCL_OK;
Tcl_Obj *dictPtr, *valuePtr = NULL;
|
| ︙ | ︙ | |||
2267 2268 2269 2270 2271 2272 2273 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictLappendCmd( | | | 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictLappendCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
int i, allocatedDict = 0, allocatedValue = 0;
|
| ︙ | ︙ | |||
2354 2355 2356 2357 2358 2359 2360 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictAppendCmd( | | | 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictAppendCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
int allocatedDict = 0;
|
| ︙ | ︙ | |||
2456 2457 2458 2459 2460 2461 2462 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictForNRCmd( | | | 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictForNRCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj;
Tcl_Obj **varv, *keyObj, *valueObj;
|
| ︙ | ︙ | |||
2486 2487 2488 2489 2490 2491 2492 |
}
if (varc != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have exactly two variable names", -1));
Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "for", NULL);
return TCL_ERROR;
}
| | | 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 |
}
if (varc != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have exactly two variable names", -1));
Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "for", NULL);
return TCL_ERROR;
}
searchPtr = (Tcl_DictSearch *)TclStackAlloc(interp, sizeof(Tcl_DictSearch));
if (Tcl_DictObjFirst(interp, objv[2], searchPtr, &keyObj, &valueObj,
&done) != TCL_OK) {
TclStackFree(interp, searchPtr);
return TCL_ERROR;
}
if (done) {
TclStackFree(interp, searchPtr);
|
| ︙ | ︙ | |||
2556 2557 2558 2559 2560 2561 2562 |
static int
DictForLoopCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | | | | 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 |
static int
DictForLoopCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_DictSearch *searchPtr = (Tcl_DictSearch *)data[0];
Tcl_Obj *keyVarObj = (Tcl_Obj *)data[1];
Tcl_Obj *valueVarObj = (Tcl_Obj *)data[2];
Tcl_Obj *scriptObj = (Tcl_Obj *)data[3];
Tcl_Obj *keyObj, *valueObj;
int done;
/*
* Process the result from the previous execution of the script body.
*/
|
| ︙ | ︙ | |||
2651 2652 2653 2654 2655 2656 2657 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictMapNRCmd( | | | 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictMapNRCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj **varv, *keyObj, *valueObj;
DictMapStorage *storagePtr;
|
| ︙ | ︙ | |||
2680 2681 2682 2683 2684 2685 2686 |
}
if (varc != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have exactly two variable names", -1));
Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", NULL);
return TCL_ERROR;
}
| | | 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 |
}
if (varc != 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must have exactly two variable names", -1));
Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "dict", "map", NULL);
return TCL_ERROR;
}
storagePtr = (DictMapStorage *)TclStackAlloc(interp, sizeof(DictMapStorage));
if (Tcl_DictObjFirst(interp, objv[2], &storagePtr->search, &keyObj,
&valueObj, &done) != TCL_OK) {
TclStackFree(interp, storagePtr);
return TCL_ERROR;
}
if (done) {
/*
|
| ︙ | ︙ | |||
2760 2761 2762 2763 2764 2765 2766 |
static int
DictMapLoopCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 |
static int
DictMapLoopCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
DictMapStorage *storagePtr = (DictMapStorage *)data[0];
Tcl_Obj *keyObj, *valueObj;
int done;
/*
* Process the result from the previous execution of the script body.
*/
|
| ︙ | ︙ | |||
2863 2864 2865 2866 2867 2868 2869 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictSetCmd( | | | 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictSetCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *resultPtr;
int result, allocatedDict = 0;
|
| ︙ | ︙ | |||
2923 2924 2925 2926 2927 2928 2929 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictUnsetCmd( | | | 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictUnsetCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *resultPtr;
int result, allocatedDict = 0;
|
| ︙ | ︙ | |||
2982 2983 2984 2985 2986 2987 2988 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictFilterCmd( | | | 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictFilterCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
static const char *const filters[] = {
"key", "script", "value", NULL
|
| ︙ | ︙ | |||
3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 | * Force loop termination by calling Tcl_DictObjDone; this * makes the next Tcl_DictObjNext say there is nothing more to * do. */ Tcl_ResetResult(interp); Tcl_DictObjDone(&search); case TCL_CONTINUE: result = TCL_OK; break; case TCL_ERROR: Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"dict filter\" script line %d)", Tcl_GetErrorLine(interp))); | > | 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 | * Force loop termination by calling Tcl_DictObjDone; this * makes the next Tcl_DictObjNext say there is nothing more to * do. */ Tcl_ResetResult(interp); Tcl_DictObjDone(&search); /* FALLTHRU */ case TCL_CONTINUE: result = TCL_OK; break; case TCL_ERROR: Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"dict filter\" script line %d)", Tcl_GetErrorLine(interp))); |
| ︙ | ︙ | |||
3266 3267 3268 3269 3270 3271 3272 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictUpdateCmd( | | | 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictUpdateCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *dictPtr, *objPtr;
int i, dummy;
|
| ︙ | ︙ | |||
3296 3297 3298 3299 3300 3301 3302 |
for (i=2 ; i+2<objc ; i+=2) {
if (Tcl_DictObjGet(interp, dictPtr, objv[i], &objPtr) != TCL_OK) {
TclDecrRefCount(dictPtr);
return TCL_ERROR;
}
if (objPtr == NULL) {
/* ??? */
| | | 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 |
for (i=2 ; i+2<objc ; i+=2) {
if (Tcl_DictObjGet(interp, dictPtr, objv[i], &objPtr) != TCL_OK) {
TclDecrRefCount(dictPtr);
return TCL_ERROR;
}
if (objPtr == NULL) {
/* ??? */
Tcl_UnsetVar2(interp, Tcl_GetString(objv[i+1]), NULL, 0);
} else if (Tcl_ObjSetVar2(interp, objv[i+1], NULL, objPtr,
TCL_LEAVE_ERR_MSG) == NULL) {
TclDecrRefCount(dictPtr);
return TCL_ERROR;
}
}
TclDecrRefCount(dictPtr);
|
| ︙ | ︙ | |||
3327 3328 3329 3330 3331 3332 3333 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj *dictPtr, *objPtr, **objv;
Tcl_InterpState state;
int i, objc;
| | | | 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj *dictPtr, *objPtr, **objv;
Tcl_InterpState state;
int i, objc;
Tcl_Obj *varName = (Tcl_Obj *)data[0];
Tcl_Obj *argsObj = (Tcl_Obj *)data[1];
/*
* ErrorInfo handling.
*/
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (body of \"dict update\")");
|
| ︙ | ︙ | |||
3424 3425 3426 3427 3428 3429 3430 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DictWithCmd( | | | 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DictWithCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *dictPtr, *keysPtr, *pathPtr;
|
| ︙ | ︙ | |||
3478 3479 3480 3481 3482 3483 3484 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj **pathv;
int pathc;
Tcl_InterpState state;
| | | | | 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj **pathv;
int pathc;
Tcl_InterpState state;
Tcl_Obj *varName = (Tcl_Obj *)data[0];
Tcl_Obj *keysPtr = (Tcl_Obj *)data[1];
Tcl_Obj *pathPtr = (Tcl_Obj *)data[2];
Var *varPtr, *arrayPtr;
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (body of \"dict with\")");
}
/*
|
| ︙ | ︙ |
Changes to generic/tclDisassemble.c.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 | #include "tclOOInt.h" #include <assert.h> /* * Prototypes for procedures defined later in this file: */ | | < | < | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | #include "tclOOInt.h" #include <assert.h> /* * Prototypes for procedures defined later in this file: */ static Tcl_Obj * DisassembleByteCodeAsDicts(Tcl_Obj *objPtr); static Tcl_Obj * DisassembleByteCodeObj(Tcl_Obj *objPtr); static int FormatInstruction(ByteCode *codePtr, const unsigned char *pc, Tcl_Obj *bufferObj); static void GetLocationInformation(Proc *procPtr, Tcl_Obj **fileObjPtr, int *linePtr); static void PrintSourceToObj(Tcl_Obj *appendObj, const char *stringPtr, int maxChars); static void UpdateStringOfInstName(Tcl_Obj *objPtr); |
| ︙ | ︙ | |||
128 129 130 131 132 133 134 | * None. * *---------------------------------------------------------------------- */ void TclPrintByteCodeObj( | | | | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 |
* None.
*
*----------------------------------------------------------------------
*/
void
TclPrintByteCodeObj(
TCL_UNUSED(Tcl_Interp *), /* Stuck with this in internal stubs */
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
Tcl_Obj *bufPtr = DisassembleByteCodeObj(objPtr);
fprintf(stdout, "\n%s", TclGetString(bufPtr));
Tcl_DecrRefCount(bufPtr);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
191 192 193 194 195 196 197 |
*/
void
TclPrintObject(
FILE *outFile, /* The file to print the source to. */
Tcl_Obj *objPtr, /* Points to the Tcl object whose string
* representation should be printed. */
| | | | 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 |
*/
void
TclPrintObject(
FILE *outFile, /* The file to print the source to. */
Tcl_Obj *objPtr, /* Points to the Tcl object whose string
* representation should be printed. */
int maxChars) /* Maximum number of chars to print. */
{
char *bytes;
int length;
bytes = TclGetStringFromObj(objPtr, &length);
TclPrintSource(outFile, bytes, TclMin(length, maxChars));
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
222 223 224 225 226 227 228 |
*----------------------------------------------------------------------
*/
void
TclPrintSource(
FILE *outFile, /* The file to print the source to. */
const char *stringPtr, /* The string to print. */
| | | 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 |
*----------------------------------------------------------------------
*/
void
TclPrintSource(
FILE *outFile, /* The file to print the source to. */
const char *stringPtr, /* The string to print. */
int maxChars) /* Maximum number of chars to print. */
{
Tcl_Obj *bufferObj;
TclNewObj(bufferObj);
PrintSourceToObj(bufferObj, stringPtr, maxChars);
fprintf(outFile, "%s", TclGetString(bufferObj));
Tcl_DecrRefCount(bufferObj);
|
| ︙ | ︙ | |||
247 248 249 250 251 252 253 | * are made about the details of the contents of the result. * *---------------------------------------------------------------------- */ static Tcl_Obj * DisassembleByteCodeObj( | < | 245 246 247 248 249 250 251 252 253 254 255 256 257 258 |
* are made about the details of the contents of the result.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *
DisassembleByteCodeObj(
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
ByteCode *codePtr;
unsigned char *codeStart, *codeLimit, *pc;
unsigned char *codeDeltaNext, *codeLengthNext;
unsigned char *srcDeltaNext, *srcLengthNext;
int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i, line;
|
| ︙ | ︙ | |||
276 277 278 279 280 281 282 |
numCmds = codePtr->numCommands;
/*
* Print header lines describing the ByteCode.
*/
Tcl_AppendPrintfToObj(bufferObj,
| | | > | | 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 |
numCmds = codePtr->numCommands;
/*
* Print header lines describing the ByteCode.
*/
Tcl_AppendPrintfToObj(bufferObj,
"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 > -1 && 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,
codePtr->maxStackDepth,
#ifdef TCL_COMPILE_STATS
|
| ︙ | ︙ | |||
320 321 322 323 324 325 326 |
*/
if (codePtr->procPtr != NULL) {
Proc *procPtr = codePtr->procPtr;
int numCompiledLocals = procPtr->numCompiledLocals;
Tcl_AppendPrintfToObj(bufferObj,
| | | 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 |
*/
if (codePtr->procPtr != NULL) {
Proc *procPtr = codePtr->procPtr;
int numCompiledLocals = procPtr->numCompiledLocals;
Tcl_AppendPrintfToObj(bufferObj,
" Proc %p, refCt %u, args %d, compiled locals %d\n",
procPtr, procPtr->refCount, procPtr->numArgs,
numCompiledLocals);
if (numCompiledLocals > 0) {
CompiledLocal *localPtr = procPtr->firstLocalPtr;
for (i = 0; i < numCompiledLocals; i++) {
Tcl_AppendPrintfToObj(bufferObj,
|
| ︙ | ︙ | |||
404 405 406 407 408 409 410 |
Tcl_AppendPrintfToObj(bufferObj, " Commands %d:", numCmds);
codeDeltaNext = codePtr->codeDeltaStart;
codeLengthNext = codePtr->codeLengthStart;
srcDeltaNext = codePtr->srcDeltaStart;
srcLengthNext = codePtr->srcLengthStart;
codeOffset = srcOffset = 0;
for (i = 0; i < numCmds; i++) {
| | | | | | 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 |
Tcl_AppendPrintfToObj(bufferObj, " Commands %d:", numCmds);
codeDeltaNext = codePtr->codeDeltaStart;
codeLengthNext = codePtr->codeLengthStart;
srcDeltaNext = codePtr->srcDeltaStart;
srcLengthNext = codePtr->srcLengthStart;
codeOffset = srcOffset = 0;
for (i = 0; i < numCmds; i++) {
if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) {
codeDeltaNext++;
delta = TclGetInt4AtPtr(codeDeltaNext);
codeDeltaNext += 4;
} else {
delta = TclGetInt1AtPtr(codeDeltaNext);
codeDeltaNext++;
}
codeOffset += delta;
if ((unsigned) *codeLengthNext == (unsigned) 0xFF) {
codeLengthNext++;
codeLen = TclGetInt4AtPtr(codeLengthNext);
codeLengthNext += 4;
} else {
codeLen = TclGetInt1AtPtr(codeLengthNext);
codeLengthNext++;
}
if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) {
srcDeltaNext++;
delta = TclGetInt4AtPtr(srcDeltaNext);
srcDeltaNext += 4;
} else {
delta = TclGetInt1AtPtr(srcDeltaNext);
srcDeltaNext++;
}
srcOffset += delta;
if ((unsigned) *srcLengthNext == (unsigned) 0xFF) {
srcLengthNext++;
srcLen = TclGetInt4AtPtr(srcLengthNext);
srcLengthNext += 4;
} else {
srcLen = TclGetInt1AtPtr(srcLengthNext);
srcLengthNext++;
}
|
| ︙ | ︙ | |||
463 464 465 466 467 468 469 |
codeDeltaNext = codePtr->codeDeltaStart;
srcDeltaNext = codePtr->srcDeltaStart;
srcLengthNext = codePtr->srcLengthStart;
codeOffset = srcOffset = 0;
pc = codeStart;
for (i = 0; i < numCmds; i++) {
| | | | | 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 |
codeDeltaNext = codePtr->codeDeltaStart;
srcDeltaNext = codePtr->srcDeltaStart;
srcLengthNext = codePtr->srcLengthStart;
codeOffset = srcOffset = 0;
pc = codeStart;
for (i = 0; i < numCmds; i++) {
if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) {
codeDeltaNext++;
delta = TclGetInt4AtPtr(codeDeltaNext);
codeDeltaNext += 4;
} else {
delta = TclGetInt1AtPtr(codeDeltaNext);
codeDeltaNext++;
}
codeOffset += delta;
if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) {
srcDeltaNext++;
delta = TclGetInt4AtPtr(srcDeltaNext);
srcDeltaNext += 4;
} else {
delta = TclGetInt1AtPtr(srcDeltaNext);
srcDeltaNext++;
}
srcOffset += delta;
if ((unsigned) *srcLengthNext == (unsigned) 0xFF) {
srcLengthNext++;
srcLen = TclGetInt4AtPtr(srcLengthNext);
srcLengthNext += 4;
} else {
srcLen = TclGetInt1AtPtr(srcLengthNext);
srcLengthNext++;
}
|
| ︙ | ︙ | |||
537 538 539 540 541 542 543 |
FormatInstruction(
ByteCode *codePtr, /* Bytecode containing the instruction. */
const unsigned char *pc, /* Points to first byte of instruction. */
Tcl_Obj *bufferObj) /* Object to append instruction info to. */
{
Proc *procPtr = codePtr->procPtr;
unsigned char opCode = *pc;
| | | 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 |
FormatInstruction(
ByteCode *codePtr, /* Bytecode containing the instruction. */
const unsigned char *pc, /* Points to first byte of instruction. */
Tcl_Obj *bufferObj) /* Object to append instruction info to. */
{
Proc *procPtr = codePtr->procPtr;
unsigned char opCode = *pc;
const InstructionDesc *instDesc = &tclInstructionTable[opCode];
unsigned char *codeStart = codePtr->codeStart;
unsigned pcOffset = pc - codeStart;
int opnd = 0, i, j, numBytes = 1;
int localCt = procPtr ? procPtr->numCompiledLocals : 0;
CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL;
char suffixBuffer[128]; /* Additional info to print after main opcode
* and immediates. */
|
| ︙ | ︙ | |||
563 564 565 566 567 568 569 | break; case OPERAND_INT4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_UINT1: opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; | | | | | | | 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 |
break;
case OPERAND_INT4:
opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
break;
case OPERAND_UINT1:
opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
break;
case OPERAND_UINT4:
opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4;
if (opCode == INST_START_CMD) {
sprintf(suffixBuffer+strlen(suffixBuffer),
", %u cmds start here", opnd);
}
Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
break;
case OPERAND_OFFSET1:
opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++;
sprintf(suffixBuffer, "pc %u", pcOffset+opnd);
Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
break;
case OPERAND_OFFSET4:
opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
if (opCode == INST_START_CMD) {
sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd);
} else {
sprintf(suffixBuffer, "pc %u", pcOffset+opnd);
}
Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
break;
case OPERAND_LIT1:
opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
suffixObj = codePtr->objArrayPtr[opnd];
Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
break;
case OPERAND_LIT4:
opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4;
suffixObj = codePtr->objArrayPtr[opnd];
Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
break;
case OPERAND_AUX4:
opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4;
Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
auxPtr = &codePtr->auxDataArrayPtr[opnd];
break;
case OPERAND_IDX4:
opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
if (opnd >= -1) {
Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd);
} else if (opnd == -2) {
|
| ︙ | ︙ | |||
623 624 625 626 627 628 629 |
case OPERAND_LVT4:
opnd = TclGetUInt4AtPtr(pc+numBytes);
numBytes += 4;
printLVTindex:
if (localPtr != NULL) {
if (opnd >= localCt) {
Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)",
| | | | | | 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 |
case OPERAND_LVT4:
opnd = TclGetUInt4AtPtr(pc+numBytes);
numBytes += 4;
printLVTindex:
if (localPtr != NULL) {
if (opnd >= localCt) {
Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)",
(unsigned) opnd, localCt);
}
for (j = 0; j < opnd; j++) {
localPtr = localPtr->nextPtr;
}
if (TclIsVarTemporary(localPtr)) {
sprintf(suffixBuffer, "temp var %u", (unsigned) opnd);
} else {
sprintf(suffixBuffer, "var ");
suffixSrc = localPtr->name;
}
}
Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd);
break;
case OPERAND_SCLS1:
opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
Tcl_AppendPrintfToObj(bufferObj, "%s ",
tclStringClassTable[opnd].name);
break;
case OPERAND_NONE:
default:
break;
}
}
if (suffixObj) {
const char *bytes;
int length;
Tcl_AppendToObj(bufferObj, "\t# ", -1);
bytes = TclGetStringFromObj(codePtr->objArrayPtr[opnd], &length);
PrintSourceToObj(bufferObj, bytes, TclMin(length, 40));
} else if (suffixBuffer[0]) {
Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer);
if (suffixSrc) {
|
| ︙ | ︙ | |||
836 837 838 839 840 841 842 |
if (inst > LAST_INST_OPCODE) {
dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5);
TclOOM(dst, TCL_INTEGER_SPACE + 5);
sprintf(dst, "inst_%" TCL_Z_MODIFIER "u", inst);
(void) Tcl_InitStringRep(objPtr, NULL, strlen(dst));
} else {
const char *s = tclInstructionTable[inst].name;
| | | 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 |
if (inst > LAST_INST_OPCODE) {
dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5);
TclOOM(dst, TCL_INTEGER_SPACE + 5);
sprintf(dst, "inst_%" TCL_Z_MODIFIER "u", inst);
(void) Tcl_InitStringRep(objPtr, NULL, strlen(dst));
} else {
const char *s = tclInstructionTable[inst].name;
unsigned int len = strlen(s);
dst = Tcl_InitStringRep(objPtr, s, len);
TclOOM(dst, len);
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
858 859 860 861 862 863 864 |
static void
PrintSourceToObj(
Tcl_Obj *appendObj, /* The object to print the source to. */
const char *stringPtr, /* The string to print. */
int maxChars) /* Maximum number of chars to print. */
{
| | | < > | | | 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 |
static void
PrintSourceToObj(
Tcl_Obj *appendObj, /* The object to print the source to. */
const char *stringPtr, /* The string to print. */
int maxChars) /* Maximum number of chars to print. */
{
const char *p;
int i = 0, len;
if (stringPtr == NULL) {
Tcl_AppendToObj(appendObj, "\"\"", -1);
return;
}
Tcl_AppendToObj(appendObj, "\"", -1);
p = stringPtr;
for (; (*p != '\0') && (i < maxChars); p+=len) {
int ucs4;
len = TclUtfToUCS4(p, &ucs4);
switch (ucs4) {
case '"':
Tcl_AppendToObj(appendObj, "\\\"", -1);
i += 2;
continue;
case '\f':
Tcl_AppendToObj(appendObj, "\\f", -1);
i += 2;
|
| ︙ | ︙ | |||
898 899 900 901 902 903 904 | i += 2; continue; case '\v': Tcl_AppendToObj(appendObj, "\\v", -1); i += 2; continue; default: | < < < < < < < < < < | < < | | < < | | | 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 |
i += 2;
continue;
case '\v':
Tcl_AppendToObj(appendObj, "\\v", -1);
i += 2;
continue;
default:
if (ucs4 > 0xFFFF) {
Tcl_AppendPrintfToObj(appendObj, "\\U%08x", ucs4);
i += 10;
} else if (ucs4 < 0x20 || ucs4 >= 0x7F) {
Tcl_AppendPrintfToObj(appendObj, "\\u%04x", ucs4);
i += 6;
} else {
Tcl_AppendPrintfToObj(appendObj, "%c", ucs4);
i++;
}
continue;
}
}
if (*p != '\0') {
Tcl_AppendToObj(appendObj, "...", -1);
|
| ︙ | ︙ | |||
947 948 949 950 951 952 953 | * format. * *---------------------------------------------------------------------- */ static Tcl_Obj * DisassembleByteCodeAsDicts( | < < | 931 932 933 934 935 936 937 938 939 940 941 942 943 944 |
* format.
*
*----------------------------------------------------------------------
*/
static Tcl_Obj *
DisassembleByteCodeAsDicts(
Tcl_Obj *objPtr) /* The bytecode-holding value to take apart */
{
ByteCode *codePtr;
Tcl_Obj *description, *literals, *variables, *instructions, *inst;
Tcl_Obj *aux, *exn, *commands, *file;
unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr;
int codeOffset, codeLength, sourceOffset, sourceLength;
|
| ︙ | ︙ | |||
1572 1573 1574 1575 1576 1577 1578 | unknownMethod: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown method \"%s\"", TclGetString(objv[3]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[3]), NULL); return TCL_ERROR; } | | | 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 |
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[3])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[3]), NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"body not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"METHODTYPE", NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1619 1620 1621 1622 1623 1624 1625 |
"may not disassemble prebuilt bytecode", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"BYTECODE", NULL);
return TCL_ERROR;
}
if (clientData) {
Tcl_SetObjResult(interp,
| | | | 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 |
"may not disassemble prebuilt bytecode", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
"BYTECODE", NULL);
return TCL_ERROR;
}
if (clientData) {
Tcl_SetObjResult(interp,
DisassembleByteCodeAsDicts(codeObjPtr));
} else {
Tcl_SetObjResult(interp,
DisassembleByteCodeObj(codeObjPtr));
}
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
* End:
*/
|
Changes to generic/tclEncoding.c.
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | * points to an array of 256 shorts. If there * is no corresponding character the encoding, * the value in the matrix is 0x0000. * malloc'd. */ } TableEncodingData; /* | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 | * points to an array of 256 shorts. If there * is no corresponding character the encoding, * the value in the matrix is 0x0000. * malloc'd. */ } TableEncodingData; /* * Each of the following structures is the clientData for a dynamically-loaded * escape-driven encoding that is itself comprised of other simpler encodings. * An example is "iso-2022-jp", which uses escape sequences to switch between * ascii, jis0208, jis0212, gb2312, and ksc5601. Note that "escape-driven" * does not necessarily mean that the ESCAPE character is the character used * for switching character sets. */ |
| ︙ | ︙ | |||
113 114 115 116 117 118 119 |
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[1];/* Information about each EscapeSubTable used
| | | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 |
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[1];/* 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
* file.
*/
|
| ︙ | ︙ | |||
152 153 154 155 156 157 158 |
0, 0, NULL, NULL, NULL, NULL, NULL
};
/*
* A list of directories making up the "library path". Historically this
* search path has served many uses, but the only one remaining is a base for
* the encodingSearchPath above. If the application does not explicitly set
| | | | < < < < | | | < < < < | < < < < | | | | | | > | | | > | | | > > > > > > | | | < < < < | | < < < < < < < < < < < < < < < | | < < < < | < < < < | < < < < | < < < < | 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 |
0, 0, NULL, NULL, NULL, NULL, NULL
};
/*
* A list of directories making up the "library path". Historically this
* search path has served many uses, but the only one remaining is a base for
* the encodingSearchPath above. If the application does not explicitly set
* the encodingSearchPath, then it is initialized by appending /encoding
* to each directory in this "libraryPath".
*/
static ProcessGlobalValue libraryPath = {
0, 0, NULL, NULL, TclpInitLibraryPath, NULL, NULL
};
static int encodingsInitialized = 0;
/*
* Hash table that keeps track of all loaded Encodings. Keys are the string
* names that represent the encoding, values are (Encoding *).
*/
static Tcl_HashTable encodingTable;
TCL_DECLARE_MUTEX(encodingMutex)
/*
* The following are used to hold the default and current system encodings.
* If NULL is passed to one of the conversion routines, the current setting of
* the system encoding is used to perform the conversion.
*/
static Tcl_Encoding defaultEncoding = NULL;
static Tcl_Encoding systemEncoding = NULL;
Tcl_Encoding tclIdentityEncoding = NULL;
/*
* The following variable is used in the sparse matrix code for a
* TableEncoding to represent a page in the table that has no entries.
*/
static unsigned short emptyPage[256];
/*
* Functions used only in this module.
*/
static Tcl_EncodingConvertProc BinaryProc;
static Tcl_DupInternalRepProc DupEncodingIntRep;
static Tcl_EncodingFreeProc EscapeFreeProc;
static Tcl_EncodingConvertProc EscapeFromUtfProc;
static Tcl_EncodingConvertProc EscapeToUtfProc;
static void FillEncodingFileMap(void);
static void FreeEncoding(Tcl_Encoding encoding);
static Tcl_FreeInternalRepProc FreeEncodingIntRep;
static Encoding * GetTableEncoding(EscapeEncodingData *dataPtr,
int state);
static Tcl_Encoding LoadEncodingFile(Tcl_Interp *interp,
const char *name);
static Tcl_Encoding LoadTableEncoding(const char *name, int type,
Tcl_Channel chan);
static Tcl_Encoding LoadEscapeEncoding(const char *name,
Tcl_Channel chan);
static Tcl_Channel OpenEncodingFileChannel(Tcl_Interp *interp,
const char *name);
static Tcl_EncodingFreeProc TableFreeProc;
static Tcl_EncodingConvertProc TableFromUtfProc;
static Tcl_EncodingConvertProc TableToUtfProc;
static size_t unilen(const char *src);
static Tcl_EncodingConvertProc Utf16ToUtfProc;
static Tcl_EncodingConvertProc UtfToUtf16Proc;
static Tcl_EncodingConvertProc UtfToUcs2Proc;
static int UtfToUtfProc(ClientData clientData,
const char *src, int srcLen, int flags,
Tcl_EncodingState *statePtr, char *dst,
int dstLen, int *srcReadPtr,
int *dstWrotePtr, int *dstCharsPtr,
int pureNullMode);
static Tcl_EncodingConvertProc UtfIntToUtfExtProc;
static Tcl_EncodingConvertProc UtfExtToUtfIntProc;
static Tcl_EncodingConvertProc Iso88591FromUtfProc;
static Tcl_EncodingConvertProc Iso88591ToUtfProc;
/*
* A Tcl_ObjType for holding a cached Tcl_Encoding in the twoPtrValue.ptr1 field
* of the intrep. This should help the lifetime of encodings be more useful.
* See concerns raised in [Bug 1077262].
*/
|
| ︙ | ︙ | |||
287 288 289 290 291 292 293 |
Tcl_StoreIntRep((objPtr), &encodingType, &ir); \
} while (0)
#define EncodingGetIntRep(objPtr, encoding) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep ((objPtr), &encodingType); \
| | | 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 |
Tcl_StoreIntRep((objPtr), &encodingType, &ir); \
} while (0)
#define EncodingGetIntRep(objPtr, encoding) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep ((objPtr), &encodingType); \
(encoding) = irPtr ? (Tcl_Encoding)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
*----------------------------------------------------------------------
*
* Tcl_GetEncodingFromObj --
|
| ︙ | ︙ | |||
442 443 444 445 446 447 448 | *---------------------------------------------------------------------- * * TclSetLibraryPath -- * * Keeps the per-thread copy of the library path current with changes to * the global copy. * | < | | | 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 |
*----------------------------------------------------------------------
*
* TclSetLibraryPath --
*
* Keeps the per-thread copy of the library path current with changes to
* the global copy.
*
* Since the result of this routine is void, if searchPath is not a valid
* list this routine silently does nothing.
*
*----------------------------------------------------------------------
*/
void
TclSetLibraryPath(
Tcl_Obj *path)
|
| ︙ | ︙ | |||
466 467 468 469 470 471 472 | } /* *--------------------------------------------------------------------------- * * FillEncodingFileMap -- * | | | | < | | | | | 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 | } /* *--------------------------------------------------------------------------- * * FillEncodingFileMap -- * * Called to update the encoding file map with the current value * of the encoding search path. * * Finds *.end files in the directories on the encoding search path and * stores the found pathnames in a map associated with the encoding name. * * If $dir is on the encoding search path and the file $dir/foo.enc is * found, stores a "foo" -> $dir entry in the map. if the "foo" encoding * is needed later, the $dir/foo.enc name can be quickly constructed in * order to read the encoding data. * * Results: * None. * * Side effects: * Entries are added to the encoding file map. * |
| ︙ | ︙ | |||
560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 |
void
TclInitEncodingSubsystem(void)
{
Tcl_EncodingType type;
TableEncodingData *dataPtr;
unsigned size;
unsigned short i;
if (encodingsInitialized) {
return;
}
Tcl_MutexLock(&encodingMutex);
Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS);
Tcl_MutexUnlock(&encodingMutex);
/*
| > > > > > | | | > > > > | > > > > > > > > > | | > > > > > > > | > > > > > | | | | 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 |
void
TclInitEncodingSubsystem(void)
{
Tcl_EncodingType type;
TableEncodingData *dataPtr;
unsigned size;
unsigned short i;
union {
char c;
short s;
} isLe;
if (encodingsInitialized) {
return;
}
isLe.s = 1;
Tcl_MutexLock(&encodingMutex);
Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS);
Tcl_MutexUnlock(&encodingMutex);
/*
* Create a few initial encodings. UTF-8 to UTF-8 translation is not a
* no-op because it turns a stream of improperly formed UTF-8 into a
* properly formed stream.
*/
type.encodingName = NULL;
type.toUtfProc = BinaryProc;
type.fromUtfProc = BinaryProc;
type.freeProc = NULL;
type.nullSize = 1;
type.clientData = NULL;
tclIdentityEncoding = Tcl_CreateEncoding(&type);
type.encodingName = "utf-8";
type.toUtfProc = UtfExtToUtfIntProc;
type.fromUtfProc = UtfIntToUtfExtProc;
type.freeProc = NULL;
type.nullSize = 1;
type.clientData = NULL;
Tcl_CreateEncoding(&type);
type.toUtfProc = Utf16ToUtfProc;
type.fromUtfProc = UtfToUcs2Proc;
type.freeProc = NULL;
type.nullSize = 2;
type.encodingName = "ucs-2le";
type.clientData = INT2PTR(1);
Tcl_CreateEncoding(&type);
type.encodingName = "ucs-2be";
type.clientData = INT2PTR(0);
Tcl_CreateEncoding(&type);
type.encodingName = "ucs-2";
type.clientData = INT2PTR(isLe.c);
Tcl_CreateEncoding(&type);
type.toUtfProc = Utf16ToUtfProc;
type.fromUtfProc = UtfToUtf16Proc;
type.freeProc = NULL;
type.nullSize = 2;
type.encodingName = "utf-16le";
type.clientData = INT2PTR(1);
Tcl_CreateEncoding(&type);
type.encodingName = "utf-16be";
type.clientData = INT2PTR(0);
Tcl_CreateEncoding(&type);
type.encodingName = "utf-16";
type.clientData = INT2PTR(isLe.c);
Tcl_CreateEncoding(&type);
#ifndef TCL_NO_DEPRECATED
type.encodingName = "unicode";
Tcl_CreateEncoding(&type);
#endif
/*
* Need the iso8859-1 encoding in order to process binary data, so force
* it to always be embedded. Note that this encoding *must* be a proper
* table encoding or some of the escape encodings crash! Hence the ugly
* code to duplicate the structure of a table encoding here.
*/
dataPtr = (TableEncodingData *)ckalloc(sizeof(TableEncodingData));
memset(dataPtr, 0, sizeof(TableEncodingData));
dataPtr->fallback = '?';
size = 256*(sizeof(unsigned short *) + sizeof(unsigned short));
dataPtr->toUnicode = (unsigned short **)ckalloc(size);
memset(dataPtr->toUnicode, 0, size);
dataPtr->fromUnicode = (unsigned short **)ckalloc(size);
memset(dataPtr->fromUnicode, 0, size);
dataPtr->toUnicode[0] = (unsigned short *) (dataPtr->toUnicode + 256);
dataPtr->fromUnicode[0] = (unsigned short *) (dataPtr->fromUnicode + 256);
for (i=1 ; i<256 ; i++) {
dataPtr->toUnicode[i] = emptyPage;
dataPtr->fromUnicode[i] = emptyPage;
|
| ︙ | ︙ | |||
679 680 681 682 683 684 685 | /* * Call FreeEncoding instead of doing it directly to handle refcounts * like escape encodings use. [Bug 524674] Make sure to call * Tcl_FirstHashEntry repeatedly so that all encodings are eventually * cleaned up. */ | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < | < < | 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 |
/*
* Call FreeEncoding instead of doing it directly to handle refcounts
* like escape encodings use. [Bug 524674] Make sure to call
* Tcl_FirstHashEntry repeatedly so that all encodings are eventually
* cleaned up.
*/
FreeEncoding((Tcl_Encoding)Tcl_GetHashValue(hPtr));
hPtr = Tcl_FirstHashEntry(&encodingTable, &search);
}
Tcl_DeleteHashTable(&encodingTable);
Tcl_MutexUnlock(&encodingMutex);
}
/*
*-------------------------------------------------------------------------
*
* Tcl_GetDefaultEncodingDir --
*
* Legacy public interface to retrieve first directory in the encoding
* searchPath.
*
* Results:
* The directory pathname, as a string, or NULL for an empty encoding
* search path.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
const char *
Tcl_GetDefaultEncodingDir(void)
{
int numDirs;
Tcl_Obj *first, *searchPath = Tcl_GetEncodingSearchPath();
Tcl_ListObjLength(NULL, searchPath, &numDirs);
if (numDirs == 0) {
return NULL;
}
Tcl_ListObjIndex(NULL, searchPath, 0, &first);
return TclGetString(first);
}
/*
*-------------------------------------------------------------------------
*
* Tcl_SetDefaultEncodingDir --
*
* Legacy public interface to set the first directory in the encoding
* search path.
*
* Results:
* None.
*
* Side effects:
* Modifies the encoding search path.
*
*-------------------------------------------------------------------------
*/
void
Tcl_SetDefaultEncodingDir(
const char *path)
{
Tcl_Obj *searchPath = Tcl_GetEncodingSearchPath();
Tcl_Obj *directory = Tcl_NewStringObj(path, -1);
searchPath = Tcl_DuplicateObj(searchPath);
Tcl_ListObjReplace(NULL, searchPath, 0, 0, 1, &directory);
Tcl_SetEncodingSearchPath(searchPath);
}
#endif
/*
*-------------------------------------------------------------------------
*
* Tcl_GetEncoding --
*
* Given the name of a encoding, find the corresponding Tcl_Encoding
* token. If the encoding did not already exist, Tcl attempts to
* dynamically load an encoding by that name.
*
* Results:
* Returns a token that represents the encoding. If the name didn't refer
* to any known or loadable encoding, NULL is returned. If NULL was
* returned, an error message is left in interp's result object, unless
* interp was NULL.
*
* Side effects:
* LoadEncodingFile is called if necessary.
*
*-------------------------------------------------------------------------
*/
Tcl_Encoding
Tcl_GetEncoding(
Tcl_Interp *interp, /* Interp for error reporting, if not NULL. */
|
| ︙ | ︙ | |||
730 731 732 733 734 735 736 |
encodingPtr->refCount++;
Tcl_MutexUnlock(&encodingMutex);
return systemEncoding;
}
hPtr = Tcl_FindHashEntry(&encodingTable, name);
if (hPtr != NULL) {
| | | | | | | > | 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 |
encodingPtr->refCount++;
Tcl_MutexUnlock(&encodingMutex);
return systemEncoding;
}
hPtr = Tcl_FindHashEntry(&encodingTable, name);
if (hPtr != NULL) {
encodingPtr = (Encoding *)Tcl_GetHashValue(hPtr);
encodingPtr->refCount++;
Tcl_MutexUnlock(&encodingMutex);
return (Tcl_Encoding) encodingPtr;
}
Tcl_MutexUnlock(&encodingMutex);
return LoadEncodingFile(interp, name);
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FreeEncoding --
*
* Releases an encoding allocated by Tcl_CreateEncoding() or
* Tcl_GetEncoding().
*
* Results:
* None.
*
* Side effects:
* The reference count associated with the encoding is decremented and
* the encoding is deleted if nothing is using it anymore.
*
*---------------------------------------------------------------------------
*/
void
Tcl_FreeEncoding(
Tcl_Encoding encoding)
{
Tcl_MutexLock(&encodingMutex);
FreeEncoding(encoding);
Tcl_MutexUnlock(&encodingMutex);
}
/*
*----------------------------------------------------------------------
*
* FreeEncoding --
*
* Decrements the reference count of an encoding. The caller must hold
* encodingMutes.
*
* Results:
* None.
*
* Side effects:
* Releases the resource for an encoding if it is now unused.
* The reference count associated with the encoding is decremented and
* the encoding may be deleted if nothing is using it anymore.
*
*----------------------------------------------------------------------
*/
static void
|
| ︙ | ︙ | |||
802 803 804 805 806 807 808 |
if (encodingPtr->freeProc != NULL) {
encodingPtr->freeProc(encodingPtr->clientData);
}
if (encodingPtr->hPtr != NULL) {
Tcl_DeleteHashEntry(encodingPtr->hPtr);
}
if (encodingPtr->name) {
| | | | 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 |
if (encodingPtr->freeProc != NULL) {
encodingPtr->freeProc(encodingPtr->clientData);
}
if (encodingPtr->hPtr != NULL) {
Tcl_DeleteHashEntry(encodingPtr->hPtr);
}
if (encodingPtr->name) {
ckfree(encodingPtr->name);
}
ckfree(encodingPtr);
}
}
/*
*-------------------------------------------------------------------------
*
* Tcl_GetEncodingName --
|
| ︙ | ︙ | |||
874 875 876 877 878 879 880 |
/*
* Copy encoding names from loaded encoding table to table.
*/
Tcl_MutexLock(&encodingMutex);
for (hPtr = Tcl_FirstHashEntry(&encodingTable, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
| | | 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 |
/*
* Copy encoding names from loaded encoding table to table.
*/
Tcl_MutexLock(&encodingMutex);
for (hPtr = Tcl_FirstHashEntry(&encodingTable, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
Encoding *encodingPtr = (Encoding *)Tcl_GetHashValue(hPtr);
Tcl_CreateHashEntry(&table,
Tcl_NewStringObj(encodingPtr->name, -1), &dummy);
}
Tcl_MutexUnlock(&encodingMutex);
FillEncodingFileMap();
|
| ︙ | ︙ | |||
966 967 968 969 970 971 972 | } /* *--------------------------------------------------------------------------- * * Tcl_CreateEncoding -- * | | | | | | | | | | | < | | 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 |
}
/*
*---------------------------------------------------------------------------
*
* Tcl_CreateEncoding --
*
* Defines a new encoding, along with the functions that are used to
* convert to and from Unicode.
*
* Results:
* Returns a token that represents the encoding. If an encoding with the
* same name already existed, the old encoding token remains valid and
* continues to behave as it used to, and is eventually garbage collected
* when the last reference to it goes away. Any subsequent calls to
* Tcl_GetEncoding with the specified name retrieve the most recent
* encoding token.
*
* Side effects:
* A new record having the name of the encoding is entered into a table of
* encodings visible to all interpreters. For each call to this function,
* there should eventually be a call to Tcl_FreeEncoding, which cleans
* deletes the record in the table when an encoding is no longer needed.
*
*---------------------------------------------------------------------------
*/
Tcl_Encoding
Tcl_CreateEncoding(
const Tcl_EncodingType *typePtr)
/* The encoding type. */
{
Encoding *encodingPtr = (Encoding *)ckalloc(sizeof(Encoding));
encodingPtr->name = NULL;
encodingPtr->toUtfProc = typePtr->toUtfProc;
encodingPtr->fromUtfProc = typePtr->fromUtfProc;
encodingPtr->freeProc = typePtr->freeProc;
encodingPtr->nullSize = typePtr->nullSize;
encodingPtr->clientData = typePtr->clientData;
if (typePtr->nullSize == 1) {
|
| ︙ | ︙ | |||
1020 1021 1022 1023 1024 1025 1026 |
hPtr = Tcl_CreateHashEntry(&encodingTable, typePtr->encodingName, &isNew);
if (isNew == 0) {
/*
* Remove old encoding from hash table, but don't delete it until last
* reference goes away.
*/
| | | | 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 |
hPtr = Tcl_CreateHashEntry(&encodingTable, typePtr->encodingName, &isNew);
if (isNew == 0) {
/*
* Remove old encoding from hash table, but don't delete it until last
* reference goes away.
*/
Encoding *replaceMe = (Encoding *)Tcl_GetHashValue(hPtr);
replaceMe->hPtr = NULL;
}
name = (char *)ckalloc(strlen(typePtr->encodingName) + 1);
encodingPtr->name = strcpy(name, typePtr->encodingName);
encodingPtr->hPtr = hPtr;
Tcl_SetHashValue(hPtr, encodingPtr);
Tcl_MutexUnlock(&encodingMutex);
}
return (Tcl_Encoding) encodingPtr;
|
| ︙ | ︙ | |||
1060 1061 1062 1063 1064 1065 1066 |
*/
char *
Tcl_ExternalToUtfDString(
Tcl_Encoding encoding, /* The encoding for the source string, or NULL
* for the default system encoding. */
const char *src, /* Source string in specified encoding. */
| | | < | | 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 |
*/
char *
Tcl_ExternalToUtfDString(
Tcl_Encoding encoding, /* The encoding for the source string, or NULL
* for the default system encoding. */
const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes, or < 0 for
* encoding-specific string length. */
Tcl_DString *dstPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
char *dst;
Tcl_EncodingState state;
const Encoding *encodingPtr;
int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars;
Tcl_DStringInit(dstPtr);
dst = Tcl_DStringValue(dstPtr);
dstLen = dstPtr->spaceAvl - 1;
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
} else if (srcLen < 0) {
srcLen = encodingPtr->lengthProc(src);
}
flags = TCL_ENCODING_START | TCL_ENCODING_END;
while (1) {
result = encodingPtr->toUtfProc(encodingPtr->clientData, src, srcLen,
|
| ︙ | ︙ | |||
1130 1131 1132 1133 1134 1135 1136 | * The converted bytes are stored in the output buffer. * *------------------------------------------------------------------------- */ int Tcl_ExternalToUtf( | | | | | | 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 |
* The converted bytes are stored in the output buffer.
*
*-------------------------------------------------------------------------
*/
int
Tcl_ExternalToUtf(
TCL_UNUSED(Tcl_Interp *), /* TODO: Re-examine this. */
Tcl_Encoding encoding, /* The encoding for the source string, or NULL
* for the default system encoding. */
const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes, or < 0 for
* encoding-specific string length. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
* information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
* routine under control of flags argument. */
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr, /* Filled with the number of bytes from the
* source string that were converted. This may
* be less than the original source length if
* there was a problem converting some source
* characters. */
int *dstWrotePtr, /* Filled with the number of bytes that were
|
| ︙ | ︙ | |||
1172 1173 1174 1175 1176 1177 1178 |
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
| | | 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 |
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
} else if (srcLen < 0) {
srcLen = encodingPtr->lengthProc(src);
}
if (statePtr == NULL) {
flags |= TCL_ENCODING_START | TCL_ENCODING_END;
statePtr = &state;
}
if (srcReadPtr == NULL) {
|
| ︙ | ︙ | |||
1212 1213 1214 1215 1216 1217 1218 |
result = encodingPtr->toUtfProc(encodingPtr->clientData, src, srcLen,
flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr,
dstCharsPtr);
if (*dstCharsPtr <= maxChars) {
break;
}
| | | | < | | < | | 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 |
result = encodingPtr->toUtfProc(encodingPtr->clientData, src, srcLen,
flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr,
dstCharsPtr);
if (*dstCharsPtr <= maxChars) {
break;
}
dstLen = Tcl_UtfAtIndex(dst, maxChars) - dst + (TCL_UTF_MAX - 1);
flags = savedFlags;
*statePtr = savedState;
} while (1);
if (!noTerminate) {
/* ...and then append it */
dst[*dstWrotePtr] = '\0';
}
return result;
}
/*
*-------------------------------------------------------------------------
*
* Tcl_UtfToExternalDString --
*
* Convert a source buffer from UTF-8 to the specified encoding. If any
* of the bytes in the source buffer are invalid or cannot be represented
* in the target encoding, a default fallback character is substituted.
*
* Results:
* The converted bytes are stored in the DString, which is then NULL
* terminated in an encoding-specific manner. The return value is a
* pointer to the value stored in the DString.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
char *
Tcl_UtfToExternalDString(
Tcl_Encoding encoding, /* The encoding for the converted string, or
* NULL for the default system encoding. */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes, or < 0 for
* strlen(). */
Tcl_DString *dstPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
char *dst;
Tcl_EncodingState state;
const Encoding *encodingPtr;
int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars;
Tcl_DStringInit(dstPtr);
dst = Tcl_DStringValue(dstPtr);
dstLen = dstPtr->spaceAvl - 1;
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
} else if (srcLen < 0) {
srcLen = strlen(src);
}
flags = TCL_ENCODING_START | TCL_ENCODING_END;
while (1) {
result = encodingPtr->fromUtfProc(encodingPtr->clientData, src,
srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote,
&dstChars);
|
| ︙ | ︙ | |||
1323 1324 1325 1326 1327 1328 1329 | * The converted bytes are stored in the output buffer. * *------------------------------------------------------------------------- */ int Tcl_UtfToExternal( | | | | | | 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 |
* The converted bytes are stored in the output buffer.
*
*-------------------------------------------------------------------------
*/
int
Tcl_UtfToExternal(
TCL_UNUSED(Tcl_Interp *), /* TODO: Re-examine this. */
Tcl_Encoding encoding, /* The encoding for the converted string, or
* NULL for the default system encoding. */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes, or < 0 for
* strlen(). */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
* information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
* routine under control of flags argument. */
char *dst, /* Output buffer in which converted string
* is stored. */
int dstLen, /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr, /* Filled with the number of bytes from the
* source string that were converted. This may
* be less than the original source length if
* there was a problem converting some source
* characters. */
int *dstWrotePtr, /* Filled with the number of bytes that were
|
| ︙ | ︙ | |||
1362 1363 1364 1365 1366 1367 1368 |
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
| | | 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 |
if (encoding == NULL) {
encoding = systemEncoding;
}
encodingPtr = (Encoding *) encoding;
if (src == NULL) {
srcLen = 0;
} else if (srcLen < 0) {
srcLen = strlen(src);
}
if (statePtr == NULL) {
flags |= TCL_ENCODING_START | TCL_ENCODING_END;
statePtr = &state;
}
if (srcReadPtr == NULL) {
|
| ︙ | ︙ | |||
1414 1415 1416 1417 1418 1419 1420 |
*/
#undef Tcl_FindExecutable
void
Tcl_FindExecutable(
const char *argv0) /* The value of the application's argv[0]
* (native). */
{
| | | 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 |
*/
#undef Tcl_FindExecutable
void
Tcl_FindExecutable(
const char *argv0) /* The value of the application's argv[0]
* (native). */
{
Tcl_InitSubsystems();
TclpSetInitialEncodings();
TclpFindExecutable(argv0);
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1545 1546 1547 1548 1549 1550 1551 | * * LoadEncodingFile -- * * Read a file that describes an encoding and create a new Encoding from * the data. * * Results: | | | | < | > | | | 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 |
*
* LoadEncodingFile --
*
* Read a file that describes an encoding and create a new Encoding from
* the data.
*
* Results:
* The return value is the newly loaded Tcl_Encoding or NULL if the file
* didn't exist or could not be processed. If NULL is returned and interp
* is not NULL, an error message is left in interp's result object.
*
* Side effects:
* A corresponding encoding file might be read from persistent storage, in
* which case LoadTableEncoding is called.
*
*---------------------------------------------------------------------------
*/
static Tcl_Encoding
LoadEncodingFile(
Tcl_Interp *interp, /* Interp for error reporting, if not NULL. */
const char *name) /* The name of both the encoding file
* and the new encoding. */
{
Tcl_Channel chan = NULL;
Tcl_Encoding encoding = NULL;
int ch;
chan = OpenEncodingFileChannel(interp, name);
if (chan == NULL) {
|
| ︙ | ︙ | |||
1614 1615 1616 1617 1618 1619 1620 | } /* *------------------------------------------------------------------------- * * LoadTableEncoding -- * | | | | | | | | | | | | 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 |
}
/*
*-------------------------------------------------------------------------
*
* LoadTableEncoding --
*
* Helper function for LoadEncodingFile(). Creates a Tcl_EncodingType
* structure along with its corresponding TableEncodingData structure, and
* passes it to Tcl_Createncoding.
*
* The file contains binary data but begins with a marker to indicate
* byte-ordering so a single binary file can be read on big or
* little-endian systems.
*
* Results:
* Returns the new Tcl_Encoding, or NULL if it could could
* not be created because the file contained invalid data.
*
* Side effects:
* See Tcl_CreateEncoding().
*
*-------------------------------------------------------------------------
*/
static Tcl_Encoding
LoadTableEncoding(
const char *name, /* Name of the new encoding. */
int type, /* Type of encoding (ENCODING_?????). */
Tcl_Channel chan) /* File containing new encoding. */
{
Tcl_DString lineString;
Tcl_Obj *objPtr;
char *line;
int i, hi, lo, numPages, symbol, fallback, len;
|
| ︙ | ︙ | |||
1694 1695 1696 1697 1698 1699 1700 |
}
memset(used, 0, sizeof(used));
#undef PAGESIZE
#define PAGESIZE (256 * sizeof(unsigned short))
| | | | | | 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 |
}
memset(used, 0, sizeof(used));
#undef PAGESIZE
#define PAGESIZE (256 * sizeof(unsigned short))
dataPtr = (TableEncodingData *)ckalloc(sizeof(TableEncodingData));
memset(dataPtr, 0, sizeof(TableEncodingData));
dataPtr->fallback = fallback;
/*
* Read the table that maps characters to Unicode. Performs a single
* malloc to get the memory for the array and all the pages needed by the
* array.
*/
size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE;
dataPtr->toUnicode = (unsigned short **)ckalloc(size);
memset(dataPtr->toUnicode, 0, size);
pageMemPtr = (unsigned short *) (dataPtr->toUnicode + 256);
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
for (i = 0; i < numPages; i++) {
int ch;
const char *p;
int expected = 3 + 16 * (16 * 4 + 1);
if (Tcl_ReadChars(chan, objPtr, expected, 0) != expected) {
return NULL;
}
p = TclGetString(objPtr);
hi = (staticHex[UCHAR(p[0])] << 4) + staticHex[UCHAR(p[1])];
dataPtr->toUnicode[hi] = pageMemPtr;
p += 2;
for (lo = 0; lo < 256; lo++) {
if ((lo & 0x0F) == 0) {
p++;
}
ch = (staticHex[UCHAR(p[0])] << 12) + (staticHex[UCHAR(p[1])] << 8)
+ (staticHex[UCHAR(p[2])] << 4) + staticHex[UCHAR(p[3])];
if (ch != 0) {
used[ch >> 8] = 1;
}
|
| ︙ | ︙ | |||
1751 1752 1753 1754 1755 1756 1757 |
if (dataPtr->toUnicode[hi] != NULL) {
dataPtr->prefixBytes[hi] = 1;
}
}
}
/*
| | | | | | | | | | | | | | | | | | 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 |
if (dataPtr->toUnicode[hi] != NULL) {
dataPtr->prefixBytes[hi] = 1;
}
}
}
/*
* Invert the toUnicode array to produce the fromUnicode array. Performs a
* single malloc to get the memory for the array and all the pages needed
* by the array. While reading in the toUnicode array remember what
* pages are needed for the fromUnicode array.
*/
if (symbol) {
used[0] = 1;
}
numPages = 0;
for (hi = 0; hi < 256; hi++) {
if (used[hi]) {
numPages++;
}
}
size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE;
dataPtr->fromUnicode = (unsigned short **)ckalloc(size);
memset(dataPtr->fromUnicode, 0, size);
pageMemPtr = (unsigned short *) (dataPtr->fromUnicode + 256);
for (hi = 0; hi < 256; hi++) {
if (dataPtr->toUnicode[hi] == NULL) {
dataPtr->toUnicode[hi] = emptyPage;
continue;
}
for (lo = 0; lo < 256; lo++) {
int ch = dataPtr->toUnicode[hi][lo];
if (ch != 0) {
page = dataPtr->fromUnicode[ch >> 8];
if (page == NULL) {
page = pageMemPtr;
pageMemPtr += 256;
dataPtr->fromUnicode[ch >> 8] = page;
}
page[ch & 0xFF] = (unsigned short) ((hi << 8) + lo);
}
}
}
if (type == ENCODING_MULTIBYTE) {
/*
* If multibyte encodings don't have a backslash character, define
* one. Otherwise, on Windows, native file names don't work because
* the backslash in the file name maps to the unknown character
* (question mark) when converting from UTF-8 to external encoding.
*/
if (dataPtr->fromUnicode[0] != NULL) {
if (dataPtr->fromUnicode[0][(int)'\\'] == '\0') {
dataPtr->fromUnicode[0][(int)'\\'] = '\\';
}
}
}
if (symbol) {
/*
* Make a special symbol encoding that maps each symbol character from
* its Unicode code point down into page 0, and also ensure that each
* characters on page 0 maps to itself so that a symbol font can be
* used to display a simple string like "abcd" and have alpha, beta,
* chi, delta show up, rather than have "unknown" chars show up because
* strictly speaking the symbol font doesn't have glyphs for those low
* ASCII chars.
*/
page = dataPtr->fromUnicode[0];
if (page == NULL) {
page = pageMemPtr;
dataPtr->fromUnicode[0] = page;
}
|
| ︙ | ︙ | |||
1859 1860 1861 1862 1863 1864 1865 |
line = Tcl_DStringValue(&lineString);
if (line[0] != 'R') {
goto doneParse;
}
/*
| | | | 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 |
line = Tcl_DStringValue(&lineString);
if (line[0] != 'R') {
goto doneParse;
}
/*
* Read lines until EOF.
*/
for (TclDStringClear(&lineString);
(len = Tcl_Gets(chan, &lineString)) >= 0;
TclDStringClear(&lineString)) {
const unsigned char *p;
int to, from;
/*
* Skip short lines.
*/
|
| ︙ | ︙ | |||
1892 1893 1894 1895 1896 1897 1898 |
}
for (p += 5, len -= 5; len >= 0 && *p; p += 5, len -= 5) {
from = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8)
+ (staticHex[p[2]] << 4) + staticHex[p[3]];
if (from == 0) {
continue;
}
| | | 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 |
}
for (p += 5, len -= 5; len >= 0 && *p; p += 5, len -= 5) {
from = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8)
+ (staticHex[p[2]] << 4) + staticHex[p[3]];
if (from == 0) {
continue;
}
dataPtr->fromUnicode[from >> 8][from & 0xFF] = to;
}
}
doneParse:
Tcl_DStringFree(&lineString);
/*
* Package everything into an encoding structure.
|
| ︙ | ︙ | |||
1936 1937 1938 1939 1940 1941 1942 | * None. * *------------------------------------------------------------------------- */ static Tcl_Encoding LoadEscapeEncoding( | | | | 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 |
* None.
*
*-------------------------------------------------------------------------
*/
static Tcl_Encoding
LoadEscapeEncoding(
const char *name, /* Name of the new encoding. */
Tcl_Channel chan) /* File containing new encoding. */
{
int i;
unsigned size;
Tcl_DString escapeData;
char init[16], final[16];
EscapeEncodingData *dataPtr;
Tcl_EncodingType type;
init[0] = '\0';
final[0] = '\0';
Tcl_DStringInit(&escapeData);
while (1) {
int argc;
const char **argv;
char *line;
Tcl_DString lineString;
Tcl_DStringInit(&lineString);
if (Tcl_Gets(chan, &lineString) < 0) {
break;
}
line = Tcl_DStringValue(&lineString);
if (Tcl_SplitList(NULL, line, &argc, &argv) != TCL_OK) {
Tcl_DStringFree(&lineString);
continue;
}
|
| ︙ | ︙ | |||
1999 2000 2001 2002 2003 2004 2005 | Tcl_FreeEncoding((Tcl_Encoding) e); e = NULL; } est.encodingPtr = e; Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est)); } } | | | | 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 |
Tcl_FreeEncoding((Tcl_Encoding) e);
e = NULL;
}
est.encodingPtr = e;
Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est));
}
}
ckfree(argv);
Tcl_DStringFree(&lineString);
}
size = sizeof(EscapeEncodingData) - sizeof(EscapeSubTable)
+ Tcl_DStringLength(&escapeData);
dataPtr = (EscapeEncodingData *)ckalloc(size);
dataPtr->initLen = strlen(init);
memcpy(dataPtr->init, init, dataPtr->initLen + 1);
dataPtr->finalLen = strlen(final);
memcpy(dataPtr->final, final, dataPtr->finalLen + 1);
dataPtr->numSubTables =
Tcl_DStringLength(&escapeData) / sizeof(EscapeSubTable);
memcpy(dataPtr->subTables, Tcl_DStringValue(&escapeData),
|
| ︙ | ︙ | |||
2061 2062 2063 2064 2065 2066 2067 | * None. * *------------------------------------------------------------------------- */ static int BinaryProc( | | | < < < < | 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
BinaryProc(
TCL_UNUSED(ClientData),
const char *src, /* Source string (unknown encoding). */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr, /* Filled with the number of bytes from the
* source string that were converted. */
int *dstWrotePtr, /* Filled with the number of bytes that were
|
| ︙ | ︙ | |||
2108 2109 2110 2111 2112 2113 2114 |
memcpy(dst, src, srcLen);
return result;
}
/*
*-------------------------------------------------------------------------
*
| | | | | 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 |
memcpy(dst, src, srcLen);
return result;
}
/*
*-------------------------------------------------------------------------
*
* UtfIntToUtfExtProc --
*
* Convert from UTF-8 to UTF-8. While converting null-bytes from the
* Tcl's internal representation (0xC0, 0x80) to the official
* representation (0x00). See UtfToUtfProc for details.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
UtfIntToUtfExtProc(
ClientData clientData,
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
* information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
|
| ︙ | ︙ | |||
2160 2161 2162 2163 2164 2165 2166 | /* *------------------------------------------------------------------------- * * UtfExtToUtfIntProc -- * * Convert from UTF-8 to UTF-8 while converting null-bytes from the | | | | 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 |
/*
*-------------------------------------------------------------------------
*
* UtfExtToUtfIntProc --
*
* Convert from UTF-8 to UTF-8 while converting null-bytes from the
* official representation (0x00) to Tcl's internal representation (0xC0,
* 0x80). See UtfToUtfProc for details.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
UtfExtToUtfIntProc(
ClientData clientData,
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
* information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
|
| ︙ | ︙ | |||
2223 2224 2225 2226 2227 2228 2229 | * None. * *------------------------------------------------------------------------- */ static int UtfToUtfProc( | | | 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
UtfToUtfProc(
TCL_UNUSED(ClientData),
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
* information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
|
| ︙ | ︙ | |||
2249 2250 2251 2252 2253 2254 2255 |
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr, /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
int pureNullMode) /* Convert embedded nulls from internal
* representation to real null-bytes or vice
| | | | | | > | | > | | | | > > > > > > > > > > | | < | < < < > | | | | | < < < < | 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 |
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr, /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
int pureNullMode) /* Convert embedded nulls from internal
* representation to real null-bytes or vice
* versa. Also combine or separate surrogate pairs */
{
const char *srcStart, *srcEnd, *srcClose;
const char *dstStart, *dstEnd;
int result, numChars, charLimit = INT_MAX;
int *chPtr = (int *) statePtr;
if (flags & TCL_ENCODING_START) {
*statePtr = 0;
}
result = TCL_OK;
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
if ((flags & TCL_ENCODING_END) == 0) {
srcClose -= 6;
}
if (flags & TCL_ENCODING_CHAR_LIMIT) {
charLimit = *dstCharsPtr;
}
dstStart = dst;
dstEnd = dst + dstLen - TCL_UTF_MAX;
for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
if ((src > srcClose) && (!TclUCS4Complete(src, srcEnd - src))) {
/*
* If there is more string to follow, this will ensure that the
* last UTF-8 character in the source buffer hasn't been cut off.
*/
result = TCL_CONVERT_MULTIBYTE;
break;
}
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
if (UCHAR(*src) < 0x80 && !(UCHAR(*src) == 0 && pureNullMode == 0)) {
/*
* Copy 7bit characters, but skip null-bytes when we are in input
* mode, so that they get converted to 0xC080.
*/
*dst++ = *src++;
*chPtr = 0; /* reset surrogate handling */
} else if (pureNullMode == 1 && UCHAR(*src) == 0xC0 &&
(src + 1 < srcEnd) && UCHAR(*(src+1)) == 0x80) {
/*
* Convert 0xC080 to real nulls when we are in output mode.
*/
*dst++ = 0;
*chPtr = 0; /* reset surrogate handling */
src += 2;
} else if (!TclUCS4Complete(src, srcEnd - src)) {
/*
* Always check before using TclUtfToUCS4. Not doing can so
* cause it run beyond the end of the buffer! If we happen such an
* incomplete char its bytes are made to represent themselves.
*/
*chPtr = UCHAR(*src);
src += 1;
dst += Tcl_UniCharToUtf(*chPtr, dst);
} else {
src += TclUtfToUCS4(src, chPtr);
if ((*chPtr | 0x7FF) == 0xDFFF) {
/* A surrogate character is detected, handle especially */
int low = *chPtr;
size_t len = (src <= srcEnd-3) ? TclUtfToUCS4(src, &low) : 0;
if (((low & ~0x3FF) != 0xDC00) || (*chPtr & 0x400)) {
*dst++ = (char) (((*chPtr >> 12) | 0xE0) & 0xEF);
*dst++ = (char) (((*chPtr >> 6) | 0x80) & 0xBF);
*dst++ = (char) ((*chPtr | 0x80) & 0xBF);
continue;
}
src += len;
dst += Tcl_UniCharToUtf(*chPtr, dst);
*chPtr = low;
}
dst += Tcl_UniCharToUtf(*chPtr, dst);
}
}
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
return result;
}
/*
*-------------------------------------------------------------------------
*
* Utf16ToUtfProc --
*
* Convert from UTF-16 to UTF-8.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
Utf16ToUtfProc(
ClientData clientData, /* != NULL means LE, == NUL means BE */
const char *src, /* Source string in Unicode. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr, /* Filled with the number of bytes from the
* source string that were converted. This may
* be less than the original source length if
|
| ︙ | ︙ | |||
2384 2385 2386 2387 2388 2389 2390 |
int result, numChars, charLimit = INT_MAX;
unsigned short ch;
if (flags & TCL_ENCODING_CHAR_LIMIT) {
charLimit = *dstCharsPtr;
}
result = TCL_OK;
| > > | | > > > > | > > > > > < < | | | | < | 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 |
int result, numChars, charLimit = INT_MAX;
unsigned short ch;
if (flags & TCL_ENCODING_CHAR_LIMIT) {
charLimit = *dstCharsPtr;
}
result = TCL_OK;
/* check alignment with utf-16 (2 == sizeof(UTF-16)) */
if ((srcLen % 2) != 0) {
result = TCL_CONVERT_MULTIBYTE;
srcLen--;
}
/* If last code point is a high surrogate, we cannot handle that yet */
if ((srcLen >= 2) && ((src[srcLen - (clientData?1:2)] & 0xFC) == 0xD8)) {
result = TCL_CONVERT_MULTIBYTE;
srcLen-= 2;
}
srcStart = src;
srcEnd = src + srcLen;
dstStart = dst;
dstEnd = dst + dstLen - TCL_UTF_MAX;
for (numChars = 0; src < srcEnd && numChars <= charLimit; numChars++) {
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
if (clientData) {
ch = (src[1] & 0xFF) << 8 | (src[0] & 0xFF);
} else {
ch = (src[0] & 0xFF) << 8 | (src[1] & 0xFF);
}
/*
* Special case for 1-byte utf chars for speed. Make sure we work with
* unsigned short-size data.
*/
if (ch && ch < 0x80) {
*dst++ = (ch & 0xFF);
} else {
dst += Tcl_UniCharToUtf(ch, dst);
}
src += sizeof(unsigned short);
}
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
return result;
}
/*
*-------------------------------------------------------------------------
*
* UtfToUtf16Proc --
*
* Convert from UTF-8 to UTF-16.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
UtfToUtf16Proc(
ClientData clientData, /* != NULL means LE, == NUL means BE */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
Tcl_EncodingState *statePtr,/* Place for conversion routine to store state
* information used during a piecewise
* conversion. Contents of statePtr are
* initialized and/or reset by conversion
|
| ︙ | ︙ | |||
2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 |
}
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
src += TclUtfToUniChar(src, chPtr);
/*
* Need to handle this in a way that won't cause misalignment by
* casting dst to a Tcl_UniChar. [Bug 1122671]
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < | | | < < < < < < | < < < < < < | < < < < < < < < < < | | 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 |
}
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
src += TclUtfToUniChar(src, chPtr);
if (clientData) {
#if TCL_UTF_MAX > 3
if (*chPtr <= 0xFFFF) {
*dst++ = (*chPtr & 0xFF);
*dst++ = (*chPtr >> 8);
} else {
*dst++ = (((*chPtr - 0x10000) >> 10) & 0xFF);
*dst++ = (((*chPtr - 0x10000) >> 18) & 0x3) | 0xD8;
*dst++ = (*chPtr & 0xFF);
*dst++ = ((*chPtr & 0x3) >> 8) | 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 & 0x3) >> 8) | 0xDC;
*dst++ = (*chPtr & 0xFF);
*dst++ = (((*chPtr - 0x10000) >> 18) & 0x3) | 0xD8;
*dst++ = (((*chPtr - 0x10000) >> 10) & 0xFF);
}
#else
*dst++ = (*chPtr >> 8);
*dst++ = (*chPtr & 0xFF);
#endif
}
}
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
return result;
}
/*
*-------------------------------------------------------------------------
*
* UtfToUcs2Proc --
*
* Convert from UTF-8 to UCS-2.
*
* Results:
* Returns TCL_OK if conversion was successful.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static int
UtfToUcs2Proc(
ClientData clientData, /* != NULL means LE, == NUL means BE */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr, /* Filled with the number of bytes from the
* source string that were converted. This may
* be less than the original source length if
* there was a problem converting some source
* characters. */
int *dstWrotePtr, /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr) /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd;
int result, numChars;
#if TCL_UTF_MAX <= 3
int len;
#endif
Tcl_UniChar ch = 0;
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
if ((flags & TCL_ENCODING_END) == 0) {
srcClose -= TCL_UTF_MAX;
}
dstStart = dst;
dstEnd = dst + dstLen - sizeof(Tcl_UniChar);
result = TCL_OK;
for (numChars = 0; src < srcEnd; numChars++) {
if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
/*
* If there is more string to follow, this will ensure that the
* last UTF-8 character in the source buffer hasn't been cut off.
*/
result = TCL_CONVERT_MULTIBYTE;
break;
}
if (dst > dstEnd) {
result = TCL_CONVERT_NOSPACE;
break;
}
#if TCL_UTF_MAX <= 3
src += (len = TclUtfToUniChar(src, &ch));
if ((ch >= 0xD800) && (len < 3)) {
src += TclUtfToUniChar(src, &ch);
ch = 0xFFFD;
}
#else
src += TclUtfToUniChar(src, &ch);
if (ch > 0xFFFF) {
ch = 0xFFFD;
}
#endif
/*
* Need to handle this in a way that won't cause misalignment by
* casting dst to a Tcl_UniChar. [Bug 1122671]
*/
if (clientData) {
*dst++ = (ch & 0xFF);
*dst++ = (ch >> 8);
} else {
*dst++ = (ch >> 8);
*dst++ = (ch & 0xFF);
}
}
*srcReadPtr = src - srcStart;
*dstWrotePtr = dst - dstStart;
*dstCharsPtr = numChars;
return result;
}
/*
*-------------------------------------------------------------------------
*
* TableToUtfProc --
*
* Convert from the encoding specified by the TableEncodingData into
* UTF-8.
|
| ︙ | ︙ | |||
2567 2568 2569 2570 2571 2572 2573 |
static int
TableToUtfProc(
ClientData clientData, /* TableEncodingData that specifies
* encoding. */
const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
| | < < < < | 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 |
static int
TableToUtfProc(
ClientData clientData, /* TableEncodingData that specifies
* encoding. */
const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr, /* Filled with the number of bytes from the
* source string that were converted. This may
* be less than the original source length if
|
| ︙ | ︙ | |||
2594 2595 2596 2597 2598 2599 2600 |
{
const char *srcStart, *srcEnd;
const char *dstEnd, *dstStart, *prefixBytes;
int result, byte, numChars, charLimit = INT_MAX;
Tcl_UniChar ch = 0;
const unsigned short *const *toUnicode;
const unsigned short *pageZero;
| | | 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 |
{
const char *srcStart, *srcEnd;
const char *dstEnd, *dstStart, *prefixBytes;
int result, byte, numChars, charLimit = INT_MAX;
Tcl_UniChar ch = 0;
const unsigned short *const *toUnicode;
const unsigned short *pageZero;
TableEncodingData *dataPtr = (TableEncodingData *)clientData;
if (flags & TCL_ENCODING_CHAR_LIMIT) {
charLimit = *dstCharsPtr;
}
srcStart = src;
srcEnd = src + srcLen;
|
| ︙ | ︙ | |||
2680 2681 2682 2683 2684 2685 2686 |
static int
TableFromUtfProc(
ClientData clientData, /* TableEncodingData that specifies
* encoding. */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
| | < < < < | | 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 |
static int
TableFromUtfProc(
ClientData clientData, /* TableEncodingData that specifies
* encoding. */
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr, /* Filled with the number of bytes from the
* source string that were converted. This may
* be less than the original source length if
* there was a problem converting some source
* characters. */
int *dstWrotePtr, /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr) /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
const char *srcStart, *srcEnd, *srcClose;
const char *dstStart, *dstEnd, *prefixBytes;
Tcl_UniChar ch = 0;
int result, len, word, numChars;
TableEncodingData *dataPtr = (TableEncodingData *)clientData;
const unsigned short *const *fromUnicode;
result = TCL_OK;
prefixBytes = dataPtr->prefixBytes;
fromUnicode = (const unsigned short *const *) dataPtr->fromUnicode;
|
| ︙ | ︙ | |||
2735 2736 2737 2738 2739 2740 2741 | */ result = TCL_CONVERT_MULTIBYTE; break; } len = TclUtfToUniChar(src, &ch); | | | | | 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 |
*/
result = TCL_CONVERT_MULTIBYTE;
break;
}
len = TclUtfToUniChar(src, &ch);
#if TCL_UTF_MAX > 3
/*
* This prevents a crash condition. More evaluation is required for
* full support of int Tcl_UniChar. [Bug 1004065]
*/
if (ch & 0xFFFF0000) {
word = 0;
} else
#else
if (!len) {
word = 0;
} else
#endif
word = fromUnicode[(ch >> 8)][ch & 0xFF];
if ((word == 0) && (ch != 0)) {
if (flags & TCL_ENCODING_STOPONERROR) {
result = TCL_CONVERT_UNKNOWN;
break;
}
word = dataPtr->fallback;
|
| ︙ | ︙ | |||
2801 2802 2803 2804 2805 2806 2807 | * None. * *------------------------------------------------------------------------- */ static int Iso88591ToUtfProc( | | | < < < < | 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
Iso88591ToUtfProc(
TCL_UNUSED(ClientData),
const char *src, /* Source string in specified encoding. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr, /* Filled with the number of bytes from the
* source string that were converted. This may
* be less than the original source length if
|
| ︙ | ︙ | |||
2885 2886 2887 2888 2889 2890 2891 | * None. * *------------------------------------------------------------------------- */ static int Iso88591FromUtfProc( | | | < < < < | | < < | | | | 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 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
Iso88591FromUtfProc(
TCL_UNUSED(ClientData),
const char *src, /* Source string in UTF-8. */
int srcLen, /* Source string length in bytes. */
int flags, /* Conversion control flags. */
TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer in which converted string is
* stored. */
int dstLen, /* The maximum length of output buffer in
* bytes. */
int *srcReadPtr, /* Filled with the number of bytes from the
* source string that were converted. This may
* be less than the original source length if
* there was a problem converting some source
* characters. */
int *dstWrotePtr, /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr) /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
const char *srcStart, *srcEnd, *srcClose;
const char *dstStart, *dstEnd;
int result = TCL_OK, numChars;
Tcl_UniChar ch = 0;
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
if ((flags & TCL_ENCODING_END) == 0) {
srcClose -= TCL_UTF_MAX;
}
dstStart = dst;
dstEnd = dst + dstLen - 1;
for (numChars = 0; src < srcEnd; numChars++) {
int len;
if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
/*
* If there is more string to follow, this will ensure that the
* last UTF-8 character in the source buffer hasn't been cut off.
*/
result = TCL_CONVERT_MULTIBYTE;
break;
}
len = TclUtfToUniChar(src, &ch);
/*
* Check for illegal characters.
*/
if (ch > 0xFF
#if TCL_UTF_MAX <= 3
|| ((ch >= 0xD800) && (len < 3))
#endif
) {
if (flags & TCL_ENCODING_STOPONERROR) {
result = TCL_CONVERT_UNKNOWN;
break;
}
#if TCL_UTF_MAX <= 3
if ((ch >= 0xD800) && (len < 3)) len = 4;
#endif
/*
* Plunge on, using '?' as a fallback character.
*/
ch = (Tcl_UniChar) '?';
|
| ︙ | ︙ | |||
3000 3001 3002 3003 3004 3005 3006 |
*/
static void
TableFreeProc(
ClientData clientData) /* TableEncodingData that specifies
* encoding. */
{
| | | | | | 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 |
*/
static void
TableFreeProc(
ClientData clientData) /* TableEncodingData that specifies
* encoding. */
{
TableEncodingData *dataPtr = (TableEncodingData *)clientData;
/*
* Make sure we aren't freeing twice on shutdown. [Bug 219314]
*/
ckfree(dataPtr->toUnicode);
dataPtr->toUnicode = NULL;
ckfree(dataPtr->fromUnicode);
dataPtr->fromUnicode = NULL;
ckfree(dataPtr);
}
/*
*-------------------------------------------------------------------------
*
* EscapeToUtfProc --
*
|
| ︙ | ︙ | |||
3058 3059 3060 3061 3062 3063 3064 |
int *dstWrotePtr, /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr) /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
| | | | | 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 |
int *dstWrotePtr, /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr) /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData;
const char *prefixBytes, *tablePrefixBytes, *srcStart, *srcEnd;
const unsigned short *const *tableToUnicode;
const Encoding *encodingPtr;
int state, result, numChars, charLimit = INT_MAX;
const char *dstStart, *dstEnd;
if (flags & TCL_ENCODING_CHAR_LIMIT) {
charLimit = *dstCharsPtr;
}
result = TCL_OK;
tablePrefixBytes = NULL;
tableToUnicode = NULL;
prefixBytes = dataPtr->prefixBytes;
encodingPtr = NULL;
srcStart = src;
srcEnd = src + srcLen;
dstStart = dst;
|
| ︙ | ︙ | |||
3194 3195 3196 3197 3198 3199 3200 |
break;
}
if (encodingPtr == NULL) {
TableEncodingData *tableDataPtr;
encodingPtr = GetTableEncoding(dataPtr, state);
| | | 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 |
break;
}
if (encodingPtr == NULL) {
TableEncodingData *tableDataPtr;
encodingPtr = GetTableEncoding(dataPtr, state);
tableDataPtr = (TableEncodingData *)encodingPtr->clientData;
tablePrefixBytes = tableDataPtr->prefixBytes;
tableToUnicode = (const unsigned short *const*)
tableDataPtr->toUnicode;
}
if (tablePrefixBytes[byte]) {
src++;
|
| ︙ | ︙ | |||
3272 3273 3274 3275 3276 3277 3278 |
int *dstWrotePtr, /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr) /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
| | > | 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 |
int *dstWrotePtr, /* Filled with the number of bytes that were
* stored in the output buffer as a result of
* the conversion. */
int *dstCharsPtr) /* Filled with the number of characters that
* correspond to the bytes stored in the
* output buffer. */
{
EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData;
const Encoding *encodingPtr;
const char *srcStart, *srcEnd, *srcClose;
const char *dstStart, *dstEnd;
int state, result, numChars;
const TableEncodingData *tableDataPtr;
const char *tablePrefixBytes;
const unsigned short *const *tableFromUnicode;
Tcl_UniChar ch = 0;
result = TCL_OK;
srcStart = src;
srcEnd = src + srcLen;
srcClose = srcEnd;
if ((flags & TCL_ENCODING_END) == 0) {
|
| ︙ | ︙ | |||
3312 3313 3314 3315 3316 3317 3318 |
memcpy(dst, dataPtr->init, dataPtr->initLen);
dst += dataPtr->initLen;
} else {
state = PTR2INT(*statePtr);
}
encodingPtr = GetTableEncoding(dataPtr, state);
| | < | | | | | 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 |
memcpy(dst, dataPtr->init, dataPtr->initLen);
dst += dataPtr->initLen;
} else {
state = PTR2INT(*statePtr);
}
encodingPtr = GetTableEncoding(dataPtr, state);
tableDataPtr = (const TableEncodingData *)encodingPtr->clientData;
tablePrefixBytes = tableDataPtr->prefixBytes;
tableFromUnicode = (const unsigned short *const *)
tableDataPtr->fromUnicode;
for (numChars = 0; src < srcEnd; numChars++) {
unsigned len;
int word;
if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) {
/*
* If there is more string to follow, this will ensure that the
* last UTF-8 character in the source buffer hasn't been cut off.
*/
result = TCL_CONVERT_MULTIBYTE;
break;
}
len = TclUtfToUniChar(src, &ch);
word = tableFromUnicode[(ch >> 8)][ch & 0xFF];
if ((word == 0) && (ch != 0)) {
int oldState;
const EscapeSubTable *subTablePtr;
oldState = state;
for (state = 0; state < dataPtr->numSubTables; state++) {
encodingPtr = GetTableEncoding(dataPtr, state);
tableDataPtr = (const TableEncodingData *)encodingPtr->clientData;
word = tableDataPtr->fromUnicode[(ch >> 8)][ch & 0xFF];
if (word != 0) {
break;
}
}
if (word == 0) {
state = oldState;
if (flags & TCL_ENCODING_STOPONERROR) {
result = TCL_CONVERT_UNKNOWN;
break;
}
encodingPtr = GetTableEncoding(dataPtr, state);
tableDataPtr = (const TableEncodingData *)encodingPtr->clientData;
word = tableDataPtr->fallback;
}
tablePrefixBytes = (const char *) tableDataPtr->prefixBytes;
tableFromUnicode = (const unsigned short *const *)
tableDataPtr->fromUnicode;
|
| ︙ | ︙ | |||
3383 3384 3385 3386 3387 3388 3389 | * in the next conversion. */ state = oldState; result = TCL_CONVERT_NOSPACE; break; } | | > | 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 |
* in the next conversion.
*/
state = oldState;
result = TCL_CONVERT_NOSPACE;
break;
}
memcpy(dst, subTablePtr->sequence,
subTablePtr->sequenceLen);
dst += subTablePtr->sequenceLen;
}
}
if (tablePrefixBytes[(word >> 8)] != 0) {
if (dst + 1 > dstEnd) {
result = TCL_CONVERT_NOSPACE;
|
| ︙ | ︙ | |||
3444 3445 3446 3447 3448 3449 3450 | } /* *--------------------------------------------------------------------------- * * EscapeFreeProc -- * | < | | | | 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 |
}
/*
*---------------------------------------------------------------------------
*
* EscapeFreeProc --
*
* Frees resources used by the encoding.
*
* Results:
* None.
*
* Side effects:
* Memory is freed.
*
*---------------------------------------------------------------------------
*/
static void
EscapeFreeProc(
ClientData clientData) /* EscapeEncodingData that specifies
* encoding. */
{
EscapeEncodingData *dataPtr = (EscapeEncodingData *)clientData;
EscapeSubTable *subTablePtr;
int i;
if (dataPtr == NULL) {
return;
}
|
| ︙ | ︙ | |||
3488 3489 3490 3491 3492 3493 3494 |
subTablePtr = dataPtr->subTables;
for (i = 0; i < dataPtr->numSubTables; i++) {
FreeEncoding((Tcl_Encoding) subTablePtr->encodingPtr);
subTablePtr->encodingPtr = NULL;
subTablePtr++;
}
}
| | | 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 |
subTablePtr = dataPtr->subTables;
for (i = 0; i < dataPtr->numSubTables; i++) {
FreeEncoding((Tcl_Encoding) subTablePtr->encodingPtr);
subTablePtr->encodingPtr = NULL;
subTablePtr++;
}
}
ckfree(dataPtr);
}
/*
*---------------------------------------------------------------------------
*
* GetTableEncoding --
*
|
| ︙ | ︙ | |||
3589 3590 3591 3592 3593 3594 3595 |
*
*-------------------------------------------------------------------------
*/
static void
InitializeEncodingSearchPath(
char **valuePtr,
| | | 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 |
*
*-------------------------------------------------------------------------
*/
static void
InitializeEncodingSearchPath(
char **valuePtr,
unsigned int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
const char *bytes;
int i, numDirs;
Tcl_Obj *libPathObj, *encodingObj, *searchPathObj;
TclNewLiteralStringObj(encodingObj, "encoding");
|
| ︙ | ︙ | |||
3623 3624 3625 3626 3627 3628 3629 |
Tcl_DecrRefCount(libPathObj);
Tcl_DecrRefCount(encodingObj);
*encodingPtr = libraryPath.encoding;
if (*encodingPtr) {
((Encoding *)(*encodingPtr))->refCount++;
}
| | > > | | 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 |
Tcl_DecrRefCount(libPathObj);
Tcl_DecrRefCount(encodingObj);
*encodingPtr = libraryPath.encoding;
if (*encodingPtr) {
((Encoding *)(*encodingPtr))->refCount++;
}
bytes = TclGetString(searchPathObj);
*lengthPtr = searchPathObj->length;
*valuePtr = (char *)ckalloc(*lengthPtr + 1);
memcpy(*valuePtr, bytes, *lengthPtr + 1);
Tcl_DecrRefCount(searchPathObj);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclEnsemble.c.
| ︙ | ︙ | |||
92 93 94 95 96 97 98 |
Tcl_StoreIntRep((objPtr), &ensembleCmdType, &ir); \
} while (0)
#define ECRGetIntRep(objPtr, ecRepPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &ensembleCmdType); \
| | | | | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 |
Tcl_StoreIntRep((objPtr), &ensembleCmdType, &ir); \
} while (0)
#define ECRGetIntRep(objPtr, ecRepPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &ensembleCmdType); \
(ecRepPtr) = irPtr ? (EnsembleCmdRep *)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
* The internal rep for caching ensemble subcommand lookups and spelling
* corrections.
*/
typedef struct {
unsigned int epoch; /* Used to confirm when the data in this
* really structure matches up with the
* ensemble. */
Command *token; /* Reference to the command for which this
* structure is a cache of the resolution. */
Tcl_Obj *fix; /* Corrected spelling, if needed. */
Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand hash
* table. */
} EnsembleCmdRep;
static inline Tcl_Obj *
NewNsObj(
Tcl_Namespace *namespacePtr)
{
Namespace *nsPtr = (Namespace *) namespacePtr;
if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) {
return Tcl_NewStringObj("::", 2);
}
return Tcl_NewStringObj(nsPtr->fullName, -1);
}
|
| ︙ | ︙ | |||
147 148 149 150 151 152 153 | * implementation prefix is configured. * *---------------------------------------------------------------------- */ int TclNamespaceEnsembleCmd( | | | 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 |
* implementation prefix is configured.
*
*----------------------------------------------------------------------
*/
int
TclNamespaceEnsembleCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Namespace *namespacePtr;
Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr,
*foundNsPtr, *altFoundNsPtr, *actualCxtPtr;
|
| ︙ | ︙ | |||
671 672 673 674 675 676 677 |
/* Name of the namespace for the ensemble. */
int flags)
{
Namespace *nsPtr = (Namespace *) ensembleNsPtr;
EnsembleConfig *ensemblePtr;
Tcl_Command token;
| | | | 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 |
/* Name of the namespace for the ensemble. */
int flags)
{
Namespace *nsPtr = (Namespace *) ensembleNsPtr;
EnsembleConfig *ensemblePtr;
Tcl_Command token;
ensemblePtr = (EnsembleConfig *)ckalloc(sizeof(EnsembleConfig));
token = TclNRCreateCommandInNs(interp, name,
(Tcl_Namespace *) nameNsPtr, TclEnsembleImplementationCmd,
NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig);
if (token == NULL) {
ckfree(ensemblePtr);
return NULL;
}
ensemblePtr->nsPtr = nsPtr;
ensemblePtr->epoch = 0;
Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS);
ensemblePtr->subcommandArrayPtr = NULL;
|
| ︙ | ︙ | |||
794 795 796 797 798 799 800 |
return TCL_ERROR;
}
if (length < 1) {
subcmdList = NULL;
}
}
| | | 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 |
return TCL_ERROR;
}
if (length < 1) {
subcmdList = NULL;
}
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
oldList = ensemblePtr->subcmdList;
ensemblePtr->subcmdList = subcmdList;
if (subcmdList != NULL) {
Tcl_IncrRefCount(subcmdList);
}
if (oldList != NULL) {
TclDecrRefCount(oldList);
|
| ︙ | ︙ | |||
870 871 872 873 874 875 876 |
return TCL_ERROR;
}
if (length < 1) {
paramList = NULL;
}
}
| | | 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 |
return TCL_ERROR;
}
if (length < 1) {
paramList = NULL;
}
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
oldList = ensemblePtr->parameterList;
ensemblePtr->parameterList = paramList;
if (paramList != NULL) {
Tcl_IncrRefCount(paramList);
}
if (oldList != NULL) {
TclDecrRefCount(oldList);
|
| ︙ | ︙ | |||
970 971 972 973 974 975 976 |
}
if (size < 1) {
mapDict = NULL;
}
}
| | | 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 |
}
if (size < 1) {
mapDict = NULL;
}
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
oldDict = ensemblePtr->subcommandDict;
ensemblePtr->subcommandDict = mapDict;
if (mapDict != NULL) {
Tcl_IncrRefCount(mapDict);
}
if (oldDict != NULL) {
TclDecrRefCount(oldDict);
|
| ︙ | ︙ | |||
1045 1046 1047 1048 1049 1050 1051 |
return TCL_ERROR;
}
if (length < 1) {
unknownList = NULL;
}
}
| | | 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 |
return TCL_ERROR;
}
if (length < 1) {
unknownList = NULL;
}
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
oldList = ensemblePtr->unknownHandler;
ensemblePtr->unknownHandler = unknownList;
if (unknownList != NULL) {
Tcl_IncrRefCount(unknownList);
}
if (oldList != NULL) {
TclDecrRefCount(oldList);
|
| ︙ | ︙ | |||
1101 1102 1103 1104 1105 1106 1107 |
if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
| | | 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 |
if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
return TCL_ERROR;
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE;
/*
* This API refuses to set the ENSEMBLE_DEAD flag...
*/
ensemblePtr->flags &= ENSEMBLE_DEAD;
|
| ︙ | ︙ | |||
1179 1180 1181 1182 1183 1184 1185 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
| | | 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*subcmdListPtr = ensemblePtr->subcmdList;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1221 1222 1223 1224 1225 1226 1227 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
| | | 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*paramListPtr = ensemblePtr->parameterList;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1263 1264 1265 1266 1267 1268 1269 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
| | | 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*mapDictPtr = ensemblePtr->subcommandDict;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1304 1305 1306 1307 1308 1309 1310 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
| | | 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*unknownListPtr = ensemblePtr->unknownHandler;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1345 1346 1347 1348 1349 1350 1351 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
| | | 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*flagsPtr = ensemblePtr->flags;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1386 1387 1388 1389 1390 1391 1392 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
| | | 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"command is not an ensemble", -1));
Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
}
return TCL_ERROR;
}
ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
*namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1620 1621 1622 1623 1624 1625 1626 |
if (map[i].unsafe && Tcl_IsSafe(interp)) {
cmdPtr = (Command *)
Tcl_NRCreateCommand(interp, "___tmp", map[i].proc,
map[i].nreProc, map[i].clientData, NULL);
Tcl_DStringSetLength(&hiddenBuf, hiddenLen);
if (Tcl_HideCommand(interp, "___tmp",
Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) {
| | | | 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 |
if (map[i].unsafe && Tcl_IsSafe(interp)) {
cmdPtr = (Command *)
Tcl_NRCreateCommand(interp, "___tmp", map[i].proc,
map[i].nreProc, map[i].clientData, NULL);
Tcl_DStringSetLength(&hiddenBuf, hiddenLen);
if (Tcl_HideCommand(interp, "___tmp",
Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) {
Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
}
} else {
/*
* Not hidden, so just create it. Yay!
*/
cmdPtr = (Command *)
Tcl_NRCreateCommand(interp, TclGetString(toObj),
map[i].proc, map[i].nreProc, map[i].clientData,
NULL);
}
cmdPtr->compileProc = map[i].compileProc;
}
}
Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict);
}
Tcl_DStringFree(&buf);
Tcl_DStringFree(&hiddenBuf);
if (nameParts != NULL) {
ckfree(nameParts);
}
return ensemble;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1686 1687 1688 1689 1690 1691 1692 |
static int
NsEnsembleImplementationCmdNR(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| | | | | 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 |
static int
NsEnsembleImplementationCmdNR(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData;
/* The ensemble itself. */
Tcl_Obj *prefixObj; /* An object containing the prefix words of
* the command that implements the
* subcommand. */
Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully
* specified but not yet cached command
* names. */
int reparseCount = 0; /* Number of reparses. */
Tcl_Obj *errorObj; /* Used for building error messages. */
Tcl_Obj *subObj;
int subIdx;
/*
* Must recheck objc, since numParameters might have changed. Cf. test
* namespace-53.9.
*/
restartEnsembleParse:
subIdx = 1 + ensemblePtr->numParameters;
if (objc < subIdx + 1) {
/*
* We don't have a subcommand argument. Make error message.
*/
Tcl_DString buf; /* Message being built */
Tcl_DStringInit(&buf);
|
| ︙ | ︙ | |||
1759 1760 1761 1762 1763 1764 1765 |
*/
EnsembleCmdRep *ensembleCmd;
ECRGetIntRep(subObj, ensembleCmd);
if (ensembleCmd) {
if (ensembleCmd->epoch == ensemblePtr->epoch &&
ensembleCmd->token == (Command *)ensemblePtr->token) {
| | | 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 |
*/
EnsembleCmdRep *ensembleCmd;
ECRGetIntRep(subObj, ensembleCmd);
if (ensembleCmd) {
if (ensembleCmd->epoch == ensemblePtr->epoch &&
ensembleCmd->token == (Command *)ensemblePtr->token) {
prefixObj = (Tcl_Obj *)Tcl_GetHashValue(ensembleCmd->hPtr);
Tcl_IncrRefCount(prefixObj);
if (ensembleCmd->fix) {
TclSpellFix(interp, objv, objc, subIdx, subObj, ensembleCmd->fix);
}
goto runResultingSubcommand;
}
}
|
| ︙ | ︙ | |||
1803 1804 1805 1806 1807 1808 1809 | * matches. */ const char *subcmdName; /* Name of the subcommand, or unique prefix of * it (will be an error for a non-unique * prefix). */ char *fullName = NULL; /* Full name of the subcommand. */ | | | | | 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 |
* matches.
*/
const char *subcmdName; /* Name of the subcommand, or unique prefix of
* it (will be an error for a non-unique
* prefix). */
char *fullName = NULL; /* Full name of the subcommand. */
int stringLength, i;
int tableLength = ensemblePtr->subcommandTable.numEntries;
Tcl_Obj *fix;
subcmdName = TclGetStringFromObj(subObj, &stringLength);
for (i=0 ; i<tableLength ; i++) {
int cmp = strncmp(subcmdName,
ensemblePtr->subcommandArrayPtr[i],
stringLength);
if (cmp == 0) {
if (fullName != NULL) {
/*
* Since there's never the exact-match case to worry about
|
| ︙ | ︙ | |||
1862 1863 1864 1865 1866 1867 1868 |
* Cache for later in the subcommand object.
*/
MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, fix);
TclSpellFix(interp, objv, objc, subIdx, subObj, fix);
}
| | | 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 |
* Cache for later in the subcommand object.
*/
MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, fix);
TclSpellFix(interp, objv, objc, subIdx, subObj, fix);
}
prefixObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
Tcl_IncrRefCount(prefixObj);
runResultingSubcommand:
/*
* Do the real work of execution of the subcommand by building an array of
* objects (note that this is potentially not the same length as the
* number of arguments to this ensemble command), populating it and then
|
| ︙ | ︙ | |||
1968 1969 1970 1971 1972 1973 1974 |
}
errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ",
(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""),
TclGetString(subObj));
if (ensemblePtr->subcommandTable.numEntries == 1) {
Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1);
} else {
| | | | 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 |
}
errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ",
(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""),
TclGetString(subObj));
if (ensemblePtr->subcommandTable.numEntries == 1) {
Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1);
} else {
int i;
for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i], -1);
Tcl_AppendToObj(errorObj, ", ", 2);
}
Tcl_AppendPrintfToObj(errorObj, "or %s",
ensemblePtr->subcommandArrayPtr[i]);
}
Tcl_SetObjResult(interp, errorObj);
return TCL_ERROR;
}
int
TclClearRootEnsemble(
TCL_UNUSED(ClientData *),
Tcl_Interp *interp,
int result)
{
TclResetRewriteEnsemble(interp, 1);
return result;
}
|
| ︙ | ︙ | |||
2013 2014 2015 2016 2017 2018 2019 |
*
*----------------------------------------------------------------------
*/
int
TclInitRewriteEnsemble(
Tcl_Interp *interp,
| | | | | 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 |
*
*----------------------------------------------------------------------
*/
int
TclInitRewriteEnsemble(
Tcl_Interp *interp,
int numRemoved,
int numInserted,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
if (isRootEnsemble) {
iPtr->ensembleRewrite.sourceObjs = objv;
iPtr->ensembleRewrite.numRemovedObjs = numRemoved;
iPtr->ensembleRewrite.numInsertedObjs = numInserted;
} else {
int numIns = iPtr->ensembleRewrite.numInsertedObjs;
if (numIns < numRemoved) {
iPtr->ensembleRewrite.numRemovedObjs += numRemoved - numIns;
iPtr->ensembleRewrite.numInsertedObjs = numInserted;
} else {
iPtr->ensembleRewrite.numInsertedObjs += numInserted - numRemoved;
}
|
| ︙ | ︙ | |||
2090 2091 2092 2093 2094 2095 2096 |
*
*----------------------------------------------------------------------
*/
static int
FreeER(
ClientData data[],
| | | | | | | | 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 |
*
*----------------------------------------------------------------------
*/
static int
FreeER(
ClientData data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
Tcl_Obj **tmp = (Tcl_Obj **) data[0];
Tcl_Obj **store = (Tcl_Obj **) data[1];
ckfree(store);
ckfree(tmp);
return result;
}
void
TclSpellFix(
Tcl_Interp *interp,
Tcl_Obj *const *objv,
int objc,
int badIdx,
Tcl_Obj *bad,
Tcl_Obj *fix)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *const *search;
Tcl_Obj **store;
int idx;
int size;
if (iPtr->ensembleRewrite.sourceObjs == NULL) {
iPtr->ensembleRewrite.sourceObjs = objv;
iPtr->ensembleRewrite.numRemovedObjs = 0;
iPtr->ensembleRewrite.numInsertedObjs = 0;
}
|
| ︙ | ︙ | |||
2172 2173 2174 2175 2176 2177 2178 |
}
}
search = iPtr->ensembleRewrite.sourceObjs;
if (search[0] == NULL) {
store = (Tcl_Obj **) search[2];
} else {
| | | | 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 |
}
}
search = iPtr->ensembleRewrite.sourceObjs;
if (search[0] == NULL) {
store = (Tcl_Obj **) search[2];
} else {
Tcl_Obj **tmp = (Tcl_Obj **)ckalloc(3 * sizeof(Tcl_Obj *));
store = (Tcl_Obj **)ckalloc(size * sizeof(Tcl_Obj *));
memcpy(store, iPtr->ensembleRewrite.sourceObjs,
size * sizeof(Tcl_Obj *));
/*
* Awful casting abuse here! Note that the NULL in the first element
* indicates that the initial objects are a raw array in the second
* element and the rewritten ones are a raw array in the third.
|
| ︙ | ︙ | |||
2400 2401 2402 2403 2404 2405 2406 |
static void
MakeCachedEnsembleCommand(
Tcl_Obj *objPtr,
EnsembleConfig *ensemblePtr,
Tcl_HashEntry *hPtr,
Tcl_Obj *fix)
{
| | | | 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 |
static void
MakeCachedEnsembleCommand(
Tcl_Obj *objPtr,
EnsembleConfig *ensemblePtr,
Tcl_HashEntry *hPtr,
Tcl_Obj *fix)
{
EnsembleCmdRep *ensembleCmd;
ECRGetIntRep(objPtr, ensembleCmd);
if (ensembleCmd) {
TclCleanupCommandMacro(ensembleCmd->token);
if (ensembleCmd->fix) {
Tcl_DecrRefCount(ensembleCmd->fix);
}
} else {
/*
* Kill the old internal rep, and replace it with a brand new one of
* our own.
*/
ensembleCmd = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep));
ECRSetIntRep(objPtr, ensembleCmd);
}
/*
* Populate the internal rep.
*/
|
| ︙ | ︙ | |||
2463 2464 2465 2466 2467 2468 2469 |
Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
if (hash->numEntries != 0) {
Tcl_HashSearch search;
Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search);
while (hPtr != NULL) {
| | | | | 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 |
Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
if (hash->numEntries != 0) {
Tcl_HashSearch search;
Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search);
while (hPtr != NULL) {
Tcl_Obj *prefixObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
Tcl_DecrRefCount(prefixObj);
hPtr = Tcl_NextHashEntry(&search);
}
ckfree((char *) ensemblePtr->subcommandArrayPtr);
}
Tcl_DeleteHashTable(hash);
}
static void
DeleteEnsembleConfig(
ClientData clientData)
{
EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData;
Namespace *nsPtr = ensemblePtr->nsPtr;
/*
* Unlink from the ensemble chain if it has not been marked as having been
* done already.
*/
|
| ︙ | ︙ | |||
2564 2565 2566 2567 2568 2569 2570 |
static void
BuildEnsembleConfig(
EnsembleConfig *ensemblePtr)
{
Tcl_HashSearch search; /* Used for scanning the set of commands in
* the namespace that backs up this
* ensemble. */
| | < | | | 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 |
static void
BuildEnsembleConfig(
EnsembleConfig *ensemblePtr)
{
Tcl_HashSearch search; /* Used for scanning the set of commands in
* the namespace that backs up this
* ensemble. */
int i, j, isNew;
Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
Tcl_HashEntry *hPtr;
Tcl_Obj *mapDict = ensemblePtr->subcommandDict;
Tcl_Obj *subList = ensemblePtr->subcmdList;
ClearTable(ensemblePtr);
Tcl_InitHashTable(hash, TCL_STRING_KEYS);
if (subList) {
int subc;
Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj;
const char *name;
/*
* There is a list of exactly what subcommands go in the table.
* Must determine the target for each.
*/
Tcl_ListObjGetElements(NULL, subList, &subc, &subv);
if (subList == mapDict) {
/*
* Strange case where explicit list of subcommands is same value
* as the dict mapping to targets.
*/
for (i = 0; i < subc; i += 2) {
name = TclGetString(subv[i]);
hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
if (!isNew) {
cmdObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
Tcl_DecrRefCount(cmdObj);
}
Tcl_SetHashValue(hPtr, subv[i+1]);
|
| ︙ | ︙ | |||
2615 2616 2617 2618 2619 2620 2621 |
}
}
} else {
/*
* Usual case where we can freely act on the list and dict.
*/
| | | 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 |
}
}
} else {
/*
* Usual case where we can freely act on the list and dict.
*/
for (i = 0; i < subc; i++) {
name = TclGetString(subv[i]);
hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
if (!isNew) {
continue;
}
/*
|
| ︙ | ︙ | |||
2662 2663 2664 2665 2666 2667 2668 |
Tcl_DictSearch dictSearch;
Tcl_Obj *keyObj, *valueObj;
int done;
Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch,
&keyObj, &valueObj, &done);
while (!done) {
| | | 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 |
Tcl_DictSearch dictSearch;
Tcl_Obj *keyObj, *valueObj;
int done;
Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch,
&keyObj, &valueObj, &done);
while (!done) {
const char *name = TclGetString(keyObj);
hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
Tcl_SetHashValue(hPtr, valueObj);
Tcl_IncrRefCount(valueObj);
Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done);
}
} else {
|
| ︙ | ︙ | |||
2688 2689 2690 2691 2692 2693 2694 |
* place them in the hash too, which should make for even faster
* matching.
*/
hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search);
for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) {
char *nsCmdName = /* Name of command in namespace. */
| | | 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 |
* place them in the hash too, which should make for even faster
* matching.
*/
hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search);
for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) {
char *nsCmdName = /* Name of command in namespace. */
(char *)Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr);
for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) {
if (Tcl_StringMatch(nsCmdName,
ensemblePtr->nsPtr->exportArrayPtr[i])) {
hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew);
/*
|
| ︙ | ︙ | |||
2737 2738 2739 2740 2741 2742 2743 |
*
* We do this by filling an array with the names (we use the hash keys
* directly to save a copy, since any time we change the array we change
* the hash too, and vice versa) and running quicksort over the array.
*/
ensemblePtr->subcommandArrayPtr =
| | | 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 |
*
* We do this by filling an array with the names (we use the hash keys
* directly to save a copy, since any time we change the array we change
* the hash too, and vice versa) and running quicksort over the array.
*/
ensemblePtr->subcommandArrayPtr =
(char **)ckalloc(sizeof(char *) * hash->numEntries);
/*
* Fill array from both ends as this makes us less likely to end up with
* performance problems in qsort(), which is good. Note that doing this
* makes this code much more opaque, but the naive alternatve:
*
* for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ;
|
| ︙ | ︙ | |||
2761 2762 2763 2764 2765 2766 2767 |
* awful runtime behaviour.
*/
i = 0;
j = hash->numEntries;
hPtr = Tcl_FirstHashEntry(hash, &search);
while (hPtr != NULL) {
| | | | 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 |
* awful runtime behaviour.
*/
i = 0;
j = hash->numEntries;
hPtr = Tcl_FirstHashEntry(hash, &search);
while (hPtr != NULL) {
ensemblePtr->subcommandArrayPtr[i++] = (char *)Tcl_GetHashKey(hash, hPtr);
hPtr = Tcl_NextHashEntry(&search);
if (hPtr == NULL) {
break;
}
ensemblePtr->subcommandArrayPtr[--j] = (char *)Tcl_GetHashKey(hash, hPtr);
hPtr = Tcl_NextHashEntry(&search);
}
if (hash->numEntries > 1) {
qsort(ensemblePtr->subcommandArrayPtr, hash->numEntries,
sizeof(char *), NsEnsembleStringOrder);
}
}
|
| ︙ | ︙ | |||
2831 2832 2833 2834 2835 2836 2837 |
EnsembleCmdRep *ensembleCmd;
ECRGetIntRep(objPtr, ensembleCmd);
TclCleanupCommandMacro(ensembleCmd->token);
if (ensembleCmd->fix) {
Tcl_DecrRefCount(ensembleCmd->fix);
}
| | | 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 |
EnsembleCmdRep *ensembleCmd;
ECRGetIntRep(objPtr, ensembleCmd);
TclCleanupCommandMacro(ensembleCmd->token);
if (ensembleCmd->fix) {
Tcl_DecrRefCount(ensembleCmd->fix);
}
ckfree(ensembleCmd);
}
/*
*----------------------------------------------------------------------
*
* DupEnsembleCmdRep --
*
|
| ︙ | ︙ | |||
2858 2859 2860 2861 2862 2863 2864 |
static void
DupEnsembleCmdRep(
Tcl_Obj *objPtr,
Tcl_Obj *copyPtr)
{
EnsembleCmdRep *ensembleCmd;
| | | 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 |
static void
DupEnsembleCmdRep(
Tcl_Obj *objPtr,
Tcl_Obj *copyPtr)
{
EnsembleCmdRep *ensembleCmd;
EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep));
ECRGetIntRep(objPtr, ensembleCmd);
ECRSetIntRep(copyPtr, ensembleCopy);
ensembleCopy->epoch = ensembleCmd->epoch;
ensembleCopy->token = ensembleCmd->token;
ensembleCopy->token->refCount++;
|
| ︙ | ︙ | |||
2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 |
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
Tcl_Obj *replaced = Tcl_NewObj(), *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;
| > | < | 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 |
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Parse *parsePtr, /* Points to a parse structure for the command
* created by Tcl_ParseCommand. */
Command *cmdPtr, /* Points to defintion of command being
* compiled. */
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation;
Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
Tcl_Obj *replaced = Tcl_NewObj(), *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;
Tcl_IncrRefCount(replaced);
if (parsePtr->numWords < depth + 1) {
goto failed;
}
if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
/*
|
| ︙ | ︙ | |||
2980 2981 2982 2983 2984 2985 2986 |
* Check to see if there's also a subcommand list; must check to see if
* the subcommand we are calling is in that list if it exists, since that
* list filters the entries in the map.
*/
(void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
if (listObj != NULL) {
| | | | 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 |
* Check to see if there's also a subcommand list; must check to see if
* the subcommand we are calling is in that list if it exists, since that
* list filters the entries in the map.
*/
(void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
if (listObj != NULL) {
int sclen;
const char *str;
Tcl_Obj *matchObj = NULL;
if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) {
goto failed;
}
for (i=0 ; i<len ; i++) {
str = TclGetStringFromObj(elems[i], &sclen);
if ((sclen == (int) numBytes) && !memcmp(word, str, numBytes)) {
/*
* Exact match! Excellent!
*/
result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj);
if (result != TCL_OK || targetCmdObj == NULL) {
goto failed;
|
| ︙ | ︙ | |||
3036 3037 3038 3039 3040 3041 3042 | int done, matched; Tcl_Obj *tmpObj; /* * No map, so check the dictionary directly. */ | | | 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 |
int done, matched;
Tcl_Obj *tmpObj;
/*
* No map, so check the dictionary directly.
*/
TclNewStringObj(subcmdObj, word, (int) numBytes);
result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj);
if (result == TCL_OK && targetCmdObj != NULL) {
/*
* Got it. Skip the fiddling around with prefixes.
*/
replacement = subcmdObj;
|
| ︙ | ︙ | |||
3177 3178 3179 3180 3181 3182 3183 |
/*
* Throw out any line information generated by the failed compile attempt.
*/
while (mapPtr->nuloc - 1 > eclIndex) {
mapPtr->nuloc--;
| | | 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 |
/*
* Throw out any line information generated by the failed compile attempt.
*/
while (mapPtr->nuloc - 1 > eclIndex) {
mapPtr->nuloc--;
ckfree(mapPtr->loc[mapPtr->nuloc].line);
mapPtr->loc[mapPtr->nuloc].line = NULL;
}
/*
* Reset the index of next command. Toss out any from failed nested
* partial compiles.
*/
|
| ︙ | ︙ | |||
3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 |
TclAttemptCompileProc(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
int depth,
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
int result, i;
Tcl_Token *saveTokenPtr = parsePtr->tokenPtr;
int savedStackDepth = envPtr->currStackDepth;
unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
int savedAuxDataArrayNext = envPtr->auxDataArrayNext;
int savedExceptArrayNext = envPtr->exceptArrayNext;
#ifdef TCL_COMPILE_DEBUG
int savedExceptDepth = envPtr->exceptDepth;
#endif
| > < | 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 |
TclAttemptCompileProc(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
int depth,
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation;
int result, i;
Tcl_Token *saveTokenPtr = parsePtr->tokenPtr;
int savedStackDepth = envPtr->currStackDepth;
unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
int savedAuxDataArrayNext = envPtr->auxDataArrayNext;
int savedExceptArrayNext = envPtr->exceptArrayNext;
#ifdef TCL_COMPILE_DEBUG
int savedExceptDepth = envPtr->exceptDepth;
#endif
if (cmdPtr->compileProc == NULL) {
return TCL_ERROR;
}
/*
* Advance parsePtr->tokenPtr so that it points at the last subcommand.
|
| ︙ | ︙ | |||
3352 3353 3354 3355 3356 3357 3358 |
* way to fix it anyway.
*/
int diff = envPtr->currStackDepth - savedStackDepth;
if (diff != 1) {
Tcl_Panic("bad stack adjustment when compiling"
| | | 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 |
* way to fix it anyway.
*/
int diff = envPtr->currStackDepth - savedStackDepth;
if (diff != 1) {
Tcl_Panic("bad stack adjustment when compiling"
" %.*s (was %d instead of 1)", parsePtr->tokenPtr->size,
parsePtr->tokenPtr->start, diff);
}
#endif
}
return result;
}
|
| ︙ | ︙ | |||
3374 3375 3376 3377 3378 3379 3380 3381 3382 |
CompileToInvokedCommand(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
Tcl_Obj *replacements,
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
| > | < < | | | 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 |
CompileToInvokedCommand(
Tcl_Interp *interp,
Tcl_Parse *parsePtr,
Tcl_Obj *replacements,
Command *cmdPtr,
CompileEnv *envPtr) /* Holds resulting instructions. */
{
DefineLineInformation;
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
const char *bytes;
int i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
/*
* Push the words of the command. Take care; the command words may be
* scripts that have backslashes in them, and [info frame 0] can see the
* difference. Hence the call to TclContinuationsEnterDerived...
*/
Tcl_ListObjGetElements(NULL, replacements, &numWords, &words);
for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords;
i++, tokPtr = TokenAfter(tokPtr)) {
if (i > 0 && i < numWords+1) {
bytes = TclGetString(words[i-1]);
PushLiteral(envPtr, bytes, words[i-1]->length);
continue;
}
SetLineInformation(i);
if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
int literal = TclRegisterLiteral(envPtr,
tokPtr[1].start, tokPtr[1].size, 0);
|
| ︙ | ︙ | |||
3420 3421 3422 3423 3424 3425 3426 |
/*
* Push the name of the command we're actually dispatching to as part of
* the implementation.
*/
objPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
| | | | 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 |
/*
* Push the name of the command we're actually dispatching to as part of
* the implementation.
*/
objPtr = Tcl_NewObj();
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);
TclEmitPush(cmdLit, envPtr);
TclDecrRefCount(objPtr);
/*
* Do the replacing dispatch.
*/
|
| ︙ | ︙ |
Changes to generic/tclEnv.c.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 |
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ. */
static struct {
| > > > > > > > > > > > > > > > > > > > | | | > > | 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 |
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
TCL_DECLARE_MUTEX(envMutex) /* To serialize access to environ. */
#if defined(_WIN32)
# define tenviron _wenviron
# define tenviron2utfdstr(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \
(char *)Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr)))
# define utf2tenvirondstr(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \
(const WCHAR *)Tcl_UtfToChar16DString((string), (len), (dsPtr)))
# define techar WCHAR
# ifdef USE_PUTENV
# define putenv(env) _wputenv((const wchar_t *)env)
# endif
#else
# define tenviron environ
# define tenviron2utfdstr(tenvstr, len, dstr) \
Tcl_ExternalToUtfDString(NULL, tenvstr, len, dstr)
# define utf2tenvirondstr(str, len, dstr) \
Tcl_UtfToExternalDString(NULL, str, len, dstr)
# define techar char
#endif
static struct {
int cacheSize; /* Number of env strings in cache. */
char **cache; /* Array containing all of the environment
* strings that Tcl has allocated. */
#ifndef USE_PUTENV
techar **ourEnviron; /* Cache of the array that we allocate. We
* need to track this in case another
* subsystem swaps around the environ array
* like we do. */
int ourEnvironSize; /* Non-zero means that the environ array was
* malloced and has this many total entries
* allocated to it (not all may be in use at
* once). Zero means that the environment
* array is in its original static state. */
#endif
} env;
#define tNTL sizeof(techar)
/*
* Declarations for local functions defined in this file:
*/
static char * EnvTraceProc(ClientData clientData, Tcl_Interp *interp,
const char *name1, const char *name2, int flags);
|
| ︙ | ︙ | |||
102 103 104 105 106 107 108 109 110 111 112 113 114 115 |
TclNewLiteralStringObj(varNamePtr, "env");
Tcl_IncrRefCount(varNamePtr);
Tcl_InitObjHashTable(&namesHash);
varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, TCL_GLOBAL_ONLY,
/*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
TclFindArrayPtrElements(varPtr, &namesHash);
/*
* Go through the environment array and transfer its values into Tcl. At
* the same time, remove those elements we add/update from the hash table
* of existing elements, so that after this part processes, that table
* will hold just the parts to remove.
*/
| > > > > > > > > > > > | | | | | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 |
TclNewLiteralStringObj(varNamePtr, "env");
Tcl_IncrRefCount(varNamePtr);
Tcl_InitObjHashTable(&namesHash);
varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL, TCL_GLOBAL_ONLY,
/*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
TclFindArrayPtrElements(varPtr, &namesHash);
#if defined(_WIN32)
if (tenviron == NULL) {
/*
* When we are started from main(), the _wenviron array could
* be NULL and will be initialized by the first _wgetenv() call.
*/
(void) _wgetenv(L"WINDIR");
}
#endif
/*
* Go through the environment array and transfer its values into Tcl. At
* the same time, remove those elements we add/update from the hash table
* of existing elements, so that after this part processes, that table
* will hold just the parts to remove.
*/
if (tenviron[0] != NULL) {
int i;
Tcl_MutexLock(&envMutex);
for (i = 0; tenviron[i] != NULL; i++) {
Tcl_Obj *obj1, *obj2;
const char *p1;
char *p2;
p1 = tenviron2utfdstr(tenviron[i], -1, &envString);
p2 = (char *)strchr(p1, '=');
if (p2 == NULL) {
/*
* This condition seem to happen occasionally under some
* versions of Solaris, or when encoding accidents swallow the
* '='; ignore the entry.
*/
|
| ︙ | ︙ | |||
168 169 170 171 172 173 174 |
/*
* Delete those elements that existed in the array but which had no
* counterparts in the environment array.
*/
for (hPtr=Tcl_FirstHashEntry(&namesHash, &search); hPtr!=NULL;
hPtr=Tcl_NextHashEntry(&search)) {
| | | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 |
/*
* Delete those elements that existed in the array but which had no
* counterparts in the environment array.
*/
for (hPtr=Tcl_FirstHashEntry(&namesHash, &search); hPtr!=NULL;
hPtr=Tcl_NextHashEntry(&search)) {
Tcl_Obj *elemName = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
TclObjUnsetVar2(interp, varNamePtr, elemName, TCL_GLOBAL_ONLY);
}
Tcl_DeleteHashTable(&namesHash);
Tcl_DecrRefCount(varNamePtr);
/*
|
| ︙ | ︙ | |||
212 213 214 215 216 217 218 |
void
TclSetEnv(
const char *name, /* Name of variable whose value is to be set
* (UTF-8). */
const char *value) /* New value for variable (UTF-8). */
{
Tcl_DString envString;
| | | | | | | | | | | | | | | | | | | | | | | 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 |
void
TclSetEnv(
const char *name, /* Name of variable whose value is to be set
* (UTF-8). */
const char *value) /* New value for variable (UTF-8). */
{
Tcl_DString envString;
unsigned nameLength, valueLength;
int index, length;
char *p, *oldValue;
const techar *p2;
/*
* Figure out where the entry is going to go. If the name doesn't already
* exist, enlarge the array if necessary to make room. If the name exists,
* free its old entry.
*/
Tcl_MutexLock(&envMutex);
index = TclpFindVariable(name, &length);
if (index == -1) {
#ifndef USE_PUTENV
/*
* We need to handle the case where the environment may be changed
* outside our control. ourEnvironSize is only valid if the current
* environment is the one we allocated. [Bug 979640]
*/
if ((env.ourEnviron != tenviron) || (length+2 > env.ourEnvironSize)) {
techar **newEnviron = (techar **)ckalloc((length + 5) * sizeof(techar *));
memcpy(newEnviron, tenviron, length * sizeof(techar *));
if ((env.ourEnvironSize != 0) && (env.ourEnviron != NULL)) {
ckfree(env.ourEnviron);
}
tenviron = (env.ourEnviron = newEnviron);
env.ourEnvironSize = length + 5;
}
index = length;
tenviron[index + 1] = NULL;
#endif /* USE_PUTENV */
oldValue = NULL;
nameLength = strlen(name);
} else {
const char *oldEnv;
/*
* Compare the new value to the existing value. If they're the same
* then quit immediately (e.g. don't rewrite the value or propagate it
* to other interpreters). Otherwise, when there are N interpreters
* there will be N! propagations of the same value among the
* interpreters.
*/
oldEnv = tenviron2utfdstr(tenviron[index], -1, &envString);
if (strcmp(value, oldEnv + (length + 1)) == 0) {
Tcl_DStringFree(&envString);
Tcl_MutexUnlock(&envMutex);
return;
}
Tcl_DStringFree(&envString);
oldValue = (char *)tenviron[index];
nameLength = length;
}
/*
* Create a new entry. Build a complete UTF string that contains a
* "name=value" pattern. Then convert the string to the native encoding,
* and set the environ array value.
*/
valueLength = strlen(value);
p = (char *)ckalloc(nameLength + valueLength + 2);
memcpy(p, name, nameLength);
p[nameLength] = '=';
memcpy(p+nameLength+1, value, valueLength+1);
p2 = utf2tenvirondstr(p, -1, &envString);
/*
* Copy the native string to heap memory.
*/
p = (char *)ckrealloc(p, Tcl_DStringLength(&envString) + tNTL);
memcpy(p, p2, Tcl_DStringLength(&envString) + tNTL);
Tcl_DStringFree(&envString);
#ifdef USE_PUTENV
/*
* Update the system environment.
*/
putenv(p);
index = TclpFindVariable(name, &length);
#else
tenviron[index] = (techar *)p;
#endif /* USE_PUTENV */
/*
* Watch out for versions of putenv that copy the string (e.g. VC++). In
* this case we need to free the string immediately. Otherwise update the
* string in the cache.
*/
if ((index != -1) && (tenviron[index] == (techar *)p)) {
ReplaceString(oldValue, p);
#ifdef HAVE_PUTENV_THAT_COPIES
} else {
/*
* This putenv() copies instead of taking ownership.
*/
ckfree(p);
#endif /* HAVE_PUTENV_THAT_COPIES */
}
Tcl_MutexUnlock(&envMutex);
if (!strcmp(name, "HOME")) {
/*
|
| ︙ | ︙ | |||
375 376 377 378 379 380 381 |
/*
* First convert the native string to UTF. Then separate the string into
* name and value parts, and call TclSetEnv to do all of the real work.
*/
name = Tcl_ExternalToUtfDString(NULL, assignment, -1, &nameString);
| | | 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 |
/*
* First convert the native string to UTF. Then separate the string into
* name and value parts, and call TclSetEnv to do all of the real work.
*/
name = Tcl_ExternalToUtfDString(NULL, assignment, -1, &nameString);
value = (char *)strchr(name, '=');
if ((value != NULL) && (value != name)) {
value[0] = '\0';
TclSetEnv(name, value+1);
}
Tcl_DStringFree(&nameString);
|
| ︙ | ︙ | |||
410 411 412 413 414 415 416 |
*/
void
TclUnsetEnv(
const char *name) /* Name of variable to remove (UTF-8). */
{
char *oldValue;
| | > | | | | | | | | | | | 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 |
*/
void
TclUnsetEnv(
const char *name) /* Name of variable to remove (UTF-8). */
{
char *oldValue;
int length;
int index;
#ifdef USE_PUTENV_FOR_UNSET
Tcl_DString envString;
char *string;
#else
char **envPtr;
#endif /* USE_PUTENV_FOR_UNSET */
Tcl_MutexLock(&envMutex);
index = TclpFindVariable(name, &length);
/*
* First make sure that the environment variable exists to avoid doing
* needless work and to avoid recursion on the unset.
*/
if (index == -1) {
Tcl_MutexUnlock(&envMutex);
return;
}
/*
* Remember the old value so we can free it if Tcl created the string.
*/
oldValue = (char *)tenviron[index];
/*
* Update the system environment. This must be done before we update the
* interpreters or we will recurse.
*/
#ifdef USE_PUTENV_FOR_UNSET
/*
* For those platforms that support putenv to unset, Linux indicates
* that no = should be included, and Windows requires it.
*/
#if defined(_WIN32)
string = (char *)ckalloc(length + 2);
memcpy(string, name, length);
string[length] = '=';
string[length+1] = '\0';
#else
string = (char *)ckalloc(length + 1);
memcpy(string, name, length);
string[length] = '\0';
#endif /* _WIN32 */
utf2tenvirondstr(string, -1, &envString);
string = (char *)ckrealloc(string, Tcl_DStringLength(&envString) + tNTL);
memcpy(string, Tcl_DStringValue(&envString),
Tcl_DStringLength(&envString) + tNTL);
Tcl_DStringFree(&envString);
putenv(string);
/*
* Watch out for versions of putenv that copy the string (e.g. VC++). In
* this case we need to free the string immediately. Otherwise update the
* string in the cache.
*/
if (tenviron[index] == (techar *)string) {
ReplaceString(oldValue, string);
#ifdef HAVE_PUTENV_THAT_COPIES
} else {
/*
* This putenv() copies instead of taking ownership.
*/
ckfree(string);
#endif /* HAVE_PUTENV_THAT_COPIES */
}
#else /* !USE_PUTENV_FOR_UNSET */
for (envPtr = (char **)(tenviron+index+1); ; envPtr++) {
envPtr[-1] = *envPtr;
if (*envPtr == NULL) {
break;
}
}
ReplaceString(oldValue, NULL);
#endif /* USE_PUTENV_FOR_UNSET */
|
| ︙ | ︙ | |||
525 526 527 528 529 530 531 |
TclGetEnv(
const char *name, /* Name of environment variable to find
* (UTF-8). */
Tcl_DString *valuePtr) /* Uninitialized or free DString in which the
* value of the environment variable is
* stored. */
{
| | | | | 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 |
TclGetEnv(
const char *name, /* Name of environment variable to find
* (UTF-8). */
Tcl_DString *valuePtr) /* Uninitialized or free DString in which the
* value of the environment variable is
* stored. */
{
int length, index;
const char *result;
Tcl_MutexLock(&envMutex);
index = TclpFindVariable(name, &length);
result = NULL;
if (index != -1) {
Tcl_DString envStr;
result = tenviron2utfdstr(tenviron[index], -1, &envStr);
result += length;
if (*result == '=') {
result++;
Tcl_DStringInit(valuePtr);
Tcl_DStringAppend(valuePtr, result, -1);
result = Tcl_DStringValue(valuePtr);
} else {
|
| ︙ | ︙ | |||
571 572 573 574 575 576 577 | * Environment variable changes get propagated. If the whole "env" array * is deleted, then we stop managing things for this interpreter (usually * this happens because the whole interpreter is being deleted). * *---------------------------------------------------------------------- */ | < | | 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 |
* Environment variable changes get propagated. If the whole "env" array
* is deleted, then we stop managing things for this interpreter (usually
* this happens because the whole interpreter is being deleted).
*
*----------------------------------------------------------------------
*/
static char *
EnvTraceProc(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter whose "env" variable is being
* modified. */
const char *name1, /* Better be "env". */
const char *name2, /* Name of variable being modified, or NULL if
* whole array is being deleted (UTF-8). */
int flags) /* Indicates what's happening. */
{
|
| ︙ | ︙ | |||
658 659 660 661 662 663 664 |
*/
static void
ReplaceString(
const char *oldStr, /* Old environment string. */
char *newStr) /* New environment string. */
{
| | | | | | 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 |
*/
static void
ReplaceString(
const char *oldStr, /* Old environment string. */
char *newStr) /* New environment string. */
{
int i;
/*
* Check to see if the old value was allocated by Tcl. If so, it needs to
* be deallocated to avoid memory leaks. Note that this algorithm is O(n),
* not O(1). This will result in n-squared behavior if lots of environment
* changes are being made.
*/
for (i = 0; i < env.cacheSize; i++) {
if (env.cache[i]==oldStr || env.cache[i]==NULL) {
break;
}
}
if (i < env.cacheSize) {
/*
* Replace or delete the old value.
*/
if (env.cache[i]) {
ckfree(env.cache[i]);
}
if (newStr) {
env.cache[i] = newStr;
} else {
for (; i < env.cacheSize-1; i++) {
env.cache[i] = env.cache[i+1];
}
env.cache[env.cacheSize-1] = NULL;
}
} else {
/*
* We need to grow the cache in order to hold the new string.
*/
const int growth = 5;
env.cache = (char **)ckrealloc(env.cache,
(env.cacheSize + growth) * sizeof(char *));
env.cache[env.cacheSize] = newStr;
(void) memset(env.cache+env.cacheSize+1, 0,
(size_t) (growth-1) * sizeof(char *));
env.cacheSize += growth;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
739 740 741 742 743 744 745 |
* free all strings in the cache.
*/
if (env.cache) {
#ifdef PURIFY
int i;
for (i = 0; i < env.cacheSize; i++) {
| | | | | 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 |
* free all strings in the cache.
*/
if (env.cache) {
#ifdef PURIFY
int i;
for (i = 0; i < env.cacheSize; i++) {
ckfree(env.cache[i]);
}
#endif
ckfree(env.cache);
env.cache = NULL;
env.cacheSize = 0;
#ifndef USE_PUTENV
if ((env.ourEnviron != NULL)) {
ckfree(env.ourEnviron);
env.ourEnviron = NULL;
}
env.ourEnvironSize = 0;
#endif
}
}
|
| ︙ | ︙ |
Changes to generic/tclEvent.c.
| ︙ | ︙ | |||
51 52 53 54 55 56 57 |
/*
* For each exit handler created with a call to Tcl_Create(Late)ExitHandler
* there is a structure of the following type:
*/
typedef struct ExitHandler {
Tcl_ExitProc *proc; /* Function to call when process exits. */
| | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
/*
* For each exit handler created with a call to Tcl_Create(Late)ExitHandler
* there is a structure of the following type:
*/
typedef struct ExitHandler {
Tcl_ExitProc *proc; /* Function to call when process exits. */
void *clientData; /* One word of information to pass to proc. */
struct ExitHandler *nextPtr;/* Next in list of all exit handlers for this
* application, or NULL for end of list. */
} ExitHandler;
/*
* There is both per-process and per-thread exit handlers. The first list is
* controlled by a mutex. The other is in thread local storage.
|
| ︙ | ︙ | |||
99 100 101 102 103 104 105 |
* standard channels. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#if TCL_THREADS
typedef struct {
Tcl_ThreadCreateProc *proc; /* Main() function of the thread */
| | | | | | | > > > > > > > > > > > | | | 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 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 |
* standard channels. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#if TCL_THREADS
typedef struct {
Tcl_ThreadCreateProc *proc; /* Main() function of the thread */
void *clientData; /* The one argument to Main() */
} ThreadClientData;
static Tcl_ThreadCreateType NewThreadProc(void *clientData);
#endif /* TCL_THREADS */
/*
* Prototypes for functions referenced only in this file:
*/
static void BgErrorDeleteProc(void *clientData,
Tcl_Interp *interp);
static void HandleBgErrors(void *clientData);
static char * VwaitVarProc(void *clientData,
Tcl_Interp *interp, const char *name1,
const char *name2, int flags);
static void InvokeExitHandlers(void);
static void FinalizeThread(int quick);
/*
*----------------------------------------------------------------------
*
* Tcl_BackgroundError --
*
* This function is invoked to handle errors that occur in Tcl commands
* that are invoked in "background" (e.g. from event or timer bindings).
*
* Results:
* None.
*
* Side effects:
* A handler command is invoked later as an idle handler to process the
* error, passing it the interp result and return options.
*
*----------------------------------------------------------------------
*/
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
#undef Tcl_BackgroundError
void
Tcl_BackgroundError(
Tcl_Interp *interp) /* Interpreter in which an error has
* occurred. */
{
Tcl_BackgroundException(interp, TCL_ERROR);
}
#endif /* TCL_NO_DEPRECATED */
void
Tcl_BackgroundException(
Tcl_Interp *interp, /* Interpreter in which an exception has
* occurred. */
int code) /* The exception code value */
{
BgError *errPtr;
ErrAssocData *assocPtr;
if (code == TCL_OK) {
return;
}
errPtr = (BgError*)ckalloc(sizeof(BgError));
errPtr->errorMsg = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(errPtr->errorMsg);
errPtr->returnOpts = Tcl_GetReturnOptions(interp, code);
Tcl_IncrRefCount(errPtr->returnOpts);
errPtr->nextPtr = NULL;
(void) TclGetBgErrorHandler(interp);
assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL);
if (assocPtr->firstBgPtr == NULL) {
assocPtr->firstBgPtr = errPtr;
Tcl_DoWhenIdle(HandleBgErrors, assocPtr);
} else {
assocPtr->lastBgPtr->nextPtr = errPtr;
}
assocPtr->lastBgPtr = errPtr;
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 | * Depends on what actions the handler command takes for the errors. * *---------------------------------------------------------------------- */ static void HandleBgErrors( | | | | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 |
* Depends on what actions the handler command takes for the errors.
*
*----------------------------------------------------------------------
*/
static void
HandleBgErrors(
void *clientData) /* Pointer to ErrAssocData structure. */
{
ErrAssocData *assocPtr = (ErrAssocData *)clientData;
Tcl_Interp *interp = assocPtr->interp;
BgError *errPtr;
/*
* Not bothering to save/restore the interp state. Assume that any code
* that has interp state it needs to keep will make its own
* Tcl_SaveInterpState call before calling something like Tcl_DoOneEvent()
|
| ︙ | ︙ | |||
215 216 217 218 219 220 221 | */ Tcl_Obj *copyObj = TclListObjCopy(NULL, assocPtr->cmdPrefix); errPtr = assocPtr->firstBgPtr; Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); | | | | | | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 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 |
*/
Tcl_Obj *copyObj = TclListObjCopy(NULL, assocPtr->cmdPrefix);
errPtr = assocPtr->firstBgPtr;
Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv);
tempObjv = (Tcl_Obj**)ckalloc((prefixObjc+2) * sizeof(Tcl_Obj *));
memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *));
tempObjv[prefixObjc] = errPtr->errorMsg;
tempObjv[prefixObjc+1] = errPtr->returnOpts;
Tcl_AllowExceptions(interp);
code = Tcl_EvalObjv(interp, prefixObjc+2, tempObjv, TCL_EVAL_GLOBAL);
/*
* Discard the command and the information about the error report.
*/
Tcl_DecrRefCount(copyObj);
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
assocPtr->firstBgPtr = errPtr->nextPtr;
ckfree(errPtr);
ckfree(tempObjv);
if (code == TCL_BREAK) {
/*
* Break means cancel any remaining error reports for this
* interpreter.
*/
while (assocPtr->firstBgPtr != NULL) {
errPtr = assocPtr->firstBgPtr;
assocPtr->firstBgPtr = errPtr->nextPtr;
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
ckfree(errPtr);
}
} else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) {
Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel != NULL) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
Tcl_Obj *keyPtr, *valuePtr = NULL;
|
| ︙ | ︙ | |||
296 297 298 299 300 301 302 | * 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(ClientData),
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;
|
| ︙ | ︙ | |||
503 504 505 506 507 508 509 |
*/
void
TclSetBgErrorHandler(
Tcl_Interp *interp,
Tcl_Obj *cmdPrefix)
{
| | | | 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 |
*/
void
TclSetBgErrorHandler(
Tcl_Interp *interp,
Tcl_Obj *cmdPrefix)
{
ErrAssocData *assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL);
if (cmdPrefix == NULL) {
Tcl_Panic("TclSetBgErrorHandler: NULL cmdPrefix argument");
}
if (assocPtr == NULL) {
/*
* First access: initialize.
*/
assocPtr = (ErrAssocData*)ckalloc(sizeof(ErrAssocData));
assocPtr->interp = interp;
assocPtr->cmdPrefix = NULL;
assocPtr->firstBgPtr = NULL;
assocPtr->lastBgPtr = NULL;
Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc, assocPtr);
}
if (assocPtr->cmdPrefix) {
|
| ︙ | ︙ | |||
548 549 550 551 552 553 554 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclGetBgErrorHandler(
Tcl_Interp *interp)
{
| | | | 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclGetBgErrorHandler(
Tcl_Interp *interp)
{
ErrAssocData *assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL);
if (assocPtr == NULL) {
Tcl_Obj *bgerrorObj;
TclNewLiteralStringObj(bgerrorObj, "::tcl::Bgerror");
TclSetBgErrorHandler(interp, bgerrorObj);
assocPtr = (ErrAssocData *)Tcl_GetAssocData(interp, "tclBgError", NULL);
}
return assocPtr->cmdPrefix;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
581 582 583 584 585 586 587 | * reports, they are canceled. * *---------------------------------------------------------------------- */ static void BgErrorDeleteProc( | | | | | | 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 |
* reports, they are canceled.
*
*----------------------------------------------------------------------
*/
static void
BgErrorDeleteProc(
void *clientData, /* Pointer to ErrAssocData structure. */
TCL_UNUSED(Tcl_Interp *))
{
ErrAssocData *assocPtr = (ErrAssocData *)clientData;
BgError *errPtr;
while (assocPtr->firstBgPtr != NULL) {
errPtr = assocPtr->firstBgPtr;
assocPtr->firstBgPtr = errPtr->nextPtr;
Tcl_DecrRefCount(errPtr->errorMsg);
Tcl_DecrRefCount(errPtr->returnOpts);
ckfree(errPtr);
}
Tcl_CancelIdleCall(HandleBgErrors, assocPtr);
Tcl_DecrRefCount(assocPtr->cmdPrefix);
Tcl_EventuallyFree(assocPtr, TCL_DYNAMIC);
}
/*
|
| ︙ | ︙ | |||
620 621 622 623 624 625 626 |
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
| | | | 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 |
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
Tcl_MutexLock(&exitMutex);
exitPtr->nextPtr = firstExitPtr;
firstExitPtr = exitPtr;
Tcl_MutexUnlock(&exitMutex);
|
| ︙ | ︙ | |||
653 654 655 656 657 658 659 |
*
*----------------------------------------------------------------------
*/
void
TclCreateLateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
| | | | 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 |
*
*----------------------------------------------------------------------
*/
void
TclCreateLateExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
Tcl_MutexLock(&exitMutex);
exitPtr->nextPtr = firstLateExitPtr;
firstLateExitPtr = exitPtr;
Tcl_MutexUnlock(&exitMutex);
|
| ︙ | ︙ | |||
686 687 688 689 690 691 692 |
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
| | | | 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 |
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
Tcl_MutexLock(&exitMutex);
for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL;
prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
if ((exitPtr->proc == proc)
&& (exitPtr->clientData == clientData)) {
if (prevPtr == NULL) {
firstExitPtr = exitPtr->nextPtr;
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
ckfree(exitPtr);
break;
}
}
Tcl_MutexUnlock(&exitMutex);
return;
}
|
| ︙ | ︙ | |||
729 730 731 732 733 734 735 |
*
*----------------------------------------------------------------------
*/
void
TclDeleteLateExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
| | | | 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 |
*
*----------------------------------------------------------------------
*/
void
TclDeleteLateExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
Tcl_MutexLock(&exitMutex);
for (prevPtr = NULL, exitPtr = firstLateExitPtr; exitPtr != NULL;
prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
if ((exitPtr->proc == proc)
&& (exitPtr->clientData == clientData)) {
if (prevPtr == NULL) {
firstLateExitPtr = exitPtr->nextPtr;
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
ckfree(exitPtr);
break;
}
}
Tcl_MutexUnlock(&exitMutex);
return;
}
|
| ︙ | ︙ | |||
772 773 774 775 776 777 778 |
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateThreadExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
| | | | 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 |
*
*----------------------------------------------------------------------
*/
void
Tcl_CreateThreadExitHandler(
Tcl_ExitProc *proc, /* Function to invoke. */
void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler));
exitPtr->proc = proc;
exitPtr->clientData = clientData;
exitPtr->nextPtr = tsdPtr->firstExitPtr;
tsdPtr->firstExitPtr = exitPtr;
}
/*
|
| ︙ | ︙ | |||
805 806 807 808 809 810 811 |
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteThreadExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
| | | | 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 |
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteThreadExitHandler(
Tcl_ExitProc *proc, /* Function that was previously registered. */
void *clientData) /* Arbitrary value to pass to proc. */
{
ExitHandler *exitPtr, *prevPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
for (prevPtr = NULL, exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
if ((exitPtr->proc == proc)
&& (exitPtr->clientData == clientData)) {
if (prevPtr == NULL) {
tsdPtr->firstExitPtr = exitPtr->nextPtr;
} else {
prevPtr->nextPtr = exitPtr->nextPtr;
}
ckfree(exitPtr);
return;
}
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
897 898 899 900 901 902 903 | * callback. This protects us against double-freeing if the callback * should call Tcl_DeleteExitHandler on itself. */ firstExitPtr = exitPtr->nextPtr; Tcl_MutexUnlock(&exitMutex); exitPtr->proc(exitPtr->clientData); | | | 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 |
* callback. This protects us against double-freeing if the callback
* should call Tcl_DeleteExitHandler on itself.
*/
firstExitPtr = exitPtr->nextPtr;
Tcl_MutexUnlock(&exitMutex);
exitPtr->proc(exitPtr->clientData);
ckfree(exitPtr);
Tcl_MutexLock(&exitMutex);
}
firstExitPtr = NULL;
Tcl_MutexUnlock(&exitMutex);
}
|
| ︙ | ︙ | |||
987 988 989 990 991 992 993 |
TclpExit(status);
Tcl_Panic("OS exit failed!");
}
/*
*-------------------------------------------------------------------------
*
| | | 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 |
TclpExit(status);
Tcl_Panic("OS exit failed!");
}
/*
*-------------------------------------------------------------------------
*
* Tcl_InitSubsystems --
*
* Initialize various subsytems in Tcl. This should be called the first
* time an interp is created, or before any of the subsystems are used.
* This function ensures an order for the initialization of subsystems:
*
* 1. that cannot be initialized in lazy order because they are mutually
* dependent.
|
| ︙ | ︙ | |||
1010 1011 1012 1013 1014 1015 1016 | * Side effects: * Varied, see the respective initialization routines. * *------------------------------------------------------------------------- */ void | | | | 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 |
* Side effects:
* Varied, see the respective initialization routines.
*
*-------------------------------------------------------------------------
*/
void
Tcl_InitSubsystems(void)
{
if (inExit != 0) {
Tcl_Panic("Tcl_InitSubsystems called while exiting");
}
if (subsystemsInitialized == 0) {
/*
* Double check inside the mutex. There are definitly calls back into
* this routine from some of the functions below.
*/
|
| ︙ | ︙ | |||
1125 1126 1127 1128 1129 1130 1131 | * callback. This protects us against double-freeing if the callback * should call Tcl_DeleteLateExitHandler on itself. */ firstLateExitPtr = exitPtr->nextPtr; Tcl_MutexUnlock(&exitMutex); exitPtr->proc(exitPtr->clientData); | | | 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 |
* callback. This protects us against double-freeing if the callback
* should call Tcl_DeleteLateExitHandler on itself.
*/
firstLateExitPtr = exitPtr->nextPtr;
Tcl_MutexUnlock(&exitMutex);
exitPtr->proc(exitPtr->clientData);
ckfree(exitPtr);
Tcl_MutexLock(&exitMutex);
}
firstLateExitPtr = NULL;
Tcl_MutexUnlock(&exitMutex);
/*
* Now finalize the Tcl execution environment. Note that this must be done
|
| ︙ | ︙ | |||
1236 1237 1238 1239 1240 1241 1242 |
* original state.
*/
TclFinalizeLoad();
TclResetFilesystem();
/*
| | | 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 |
* original state.
*/
TclFinalizeLoad();
TclResetFilesystem();
/*
* At this point, there should no longer be any ckalloc'ed memory.
*/
TclFinalizeMemorySubsystem();
alreadyFinalized:
TclFinalizeLock();
}
|
| ︙ | ︙ | |||
1281 1282 1283 1284 1285 1286 1287 |
/*
* We use TclThreadDataKeyGet here, rather than Tcl_GetThreadData, because
* we don't want to initialize the data block if it hasn't been
* initialized already.
*/
| | | | 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 |
/*
* We use TclThreadDataKeyGet here, rather than Tcl_GetThreadData, because
* we don't want to initialize the data block if it hasn't been
* initialized already.
*/
tsdPtr = (ThreadSpecificData*)TclThreadDataKeyGet(&dataKey);
if (tsdPtr != NULL) {
tsdPtr->inExit = 1;
for (exitPtr = tsdPtr->firstExitPtr; exitPtr != NULL;
exitPtr = tsdPtr->firstExitPtr) {
/*
* Be careful to remove the handler from the list before invoking
* its callback. This protects us against double-freeing if the
* callback should call Tcl_DeleteThreadExitHandler on itself.
*/
tsdPtr->firstExitPtr = exitPtr->nextPtr;
exitPtr->proc(exitPtr->clientData);
ckfree(exitPtr);
}
TclFinalizeIOSubsystem();
TclFinalizeNotifier();
TclFinalizeAsync();
TclFinalizeThreadObjects();
}
|
| ︙ | ︙ | |||
1356 1357 1358 1359 1360 1361 1362 |
*
*----------------------------------------------------------------------
*/
int
TclInThreadExit(void)
{
| | | 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 |
*
*----------------------------------------------------------------------
*/
int
TclInThreadExit(void)
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
return 0;
}
return tsdPtr->inExit;
}
|
| ︙ | ︙ | |||
1381 1382 1383 1384 1385 1386 1387 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | | 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 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_VwaitObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int done, foundEvent;
const char *nameString;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
nameString = Tcl_GetString(objv[1]);
if (Tcl_TraceVar2(interp, nameString, NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, &done) != TCL_OK) {
return TCL_ERROR;
};
done = 0;
foundEvent = 1;
|
| ︙ | ︙ | |||
1445 1446 1447 1448 1449 1450 1451 |
* handlers.
*/
Tcl_ResetResult(interp);
return TCL_OK;
}
| < | | | | | 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 |
* handlers.
*/
Tcl_ResetResult(interp);
return TCL_OK;
}
static char *
VwaitVarProc(
void *clientData, /* Pointer to integer to set to 1. */
Tcl_Interp *interp, /* Interpreter containing variable. */
const char *name1, /* Name of variable. */
const char *name2, /* Second part of variable name. */
TCL_UNUSED(int) /*flags*/) /* Information about what happened. */
{
int *donePtr = (int *)clientData;
*donePtr = 1;
Tcl_UntraceVar2(interp, name1, name2, TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, clientData);
return NULL;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1479 1480 1481 1482 1483 1484 1485 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_UpdateObjCmd(
TCL_UNUSED(ClientData),
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};
|
| ︙ | ︙ | |||
1550 1551 1552 1553 1554 1555 1556 | * Initializes Tcl notifier for the current thread. * *---------------------------------------------------------------------- */ static Tcl_ThreadCreateType NewThreadProc( | | | | | | 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 |
* Initializes Tcl notifier for the current thread.
*
*----------------------------------------------------------------------
*/
static Tcl_ThreadCreateType
NewThreadProc(
void *clientData)
{
ThreadClientData *cdPtr = (ThreadClientData *)clientData;
void *threadClientData;
Tcl_ThreadCreateProc *threadProc;
threadProc = cdPtr->proc;
threadClientData = cdPtr->clientData;
ckfree(clientData); /* Allocated in Tcl_CreateThread() */
threadProc(threadClientData);
TCL_THREAD_CREATE_RETURN;
}
#endif
|
| ︙ | ︙ | |||
1589 1590 1591 1592 1593 1594 1595 |
*----------------------------------------------------------------------
*/
int
Tcl_CreateThread(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread */
| | | | | | 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 |
*----------------------------------------------------------------------
*/
int
Tcl_CreateThread(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread */
void *clientData, /* The one argument to Main() */
int stackSize, /* Size of stack for the new thread */
int flags) /* Flags controlling behaviour of the new
* thread. */
{
#if TCL_THREADS
ThreadClientData *cdPtr = (ThreadClientData *)ckalloc(sizeof(ThreadClientData));
int result;
cdPtr->proc = proc;
cdPtr->clientData = clientData;
result = TclpThreadCreate(idPtr, NewThreadProc, cdPtr, stackSize, flags);
if (result != TCL_OK) {
ckfree(cdPtr);
}
return result;
#else
return TCL_ERROR;
#endif /* TCL_THREADS */
}
|
| ︙ | ︙ |
Changes to generic/tclExecute.c.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" #include "tclOOInt.h" | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclCompile.h" #include "tclOOInt.h" #include "tclTomMath.h" #include <math.h> #include <assert.h> /* * Hack to determine whether we may expect IEEE floating point. The hack is * formally incorrect in that non-IEEE platforms might have the same precision * and range, but VAX, IBM, and Cray do not; are there any other floating |
| ︙ | ︙ | |||
69 70 71 72 73 74 75 | /* * Mapping from expression instruction opcodes to strings; used for error * messages. Note that these entries must match the order and number of the * expression opcodes (e.g., INST_LOR) in tclCompile.h. * * Does not include the string for INST_EXPON (and beyond), as that is | | | | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 |
/*
* Mapping from expression instruction opcodes to strings; used for error
* messages. Note that these entries must match the order and number of the
* expression opcodes (e.g., INST_LOR) in tclCompile.h.
*
* Does not include the string for INST_EXPON (and beyond), as that is
* disjoint for backward-compatability reasons.
*/
static const char *const operatorStrings[] = {
"||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
"+", "-", "*", "/", "%", "+", "-", "~", "!"
};
/*
* Mapping from Tcl result codes to strings; used for error and debugging
* messages.
*/
|
| ︙ | ︙ | |||
97 98 99 100 101 102 103 |
*/
#ifdef TCL_COMPILE_STATS
size_t tclObjsAlloced = 0;
size_t tclObjsFreed = 0;
size_t tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
#endif /* TCL_COMPILE_STATS */
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 |
*/
#ifdef TCL_COMPILE_STATS
size_t tclObjsAlloced = 0;
size_t tclObjsFreed = 0;
size_t tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
#endif /* TCL_COMPILE_STATS */
/*
* Support pre-8.5 bytecodes unless specifically requested otherwise.
*/
#ifndef TCL_SUPPORT_84_BYTECODE
#define TCL_SUPPORT_84_BYTECODE 1
#endif
#if TCL_SUPPORT_84_BYTECODE
/*
* We need to know the tclBuiltinFuncTable to support translation of pre-8.5
* math functions to the namespace-based ::tcl::mathfunc::op in 8.5+.
*/
typedef struct {
const char *name; /* Name of function. */
int numArgs; /* Number of arguments for function. */
} BuiltinFunc;
/*
* Table describing the built-in math functions. Entries in this table are
* indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
* operand byte.
*/
static BuiltinFunc const tclBuiltinFuncTable[] = {
{"acos", 1},
{"asin", 1},
{"atan", 1},
{"atan2", 2},
{"ceil", 1},
{"cos", 1},
{"cosh", 1},
{"exp", 1},
{"floor", 1},
{"fmod", 2},
{"hypot", 2},
{"log", 1},
{"log10", 1},
{"pow", 2},
{"sin", 1},
{"sinh", 1},
{"sqrt", 1},
{"tan", 1},
{"tanh", 1},
{"abs", 1},
{"double", 1},
{"int", 1},
{"rand", 0},
{"round", 1},
{"srand", 1},
{"wide", 1},
{NULL, 0},
};
#define LAST_BUILTIN_FUNC 25
#endif
/*
* NR_TEBC
* Helpers for NR - non-recursive calls to TEBC
* Minimal data required to fully reconstruct the execution state.
*/
typedef struct TEBCdata {
ByteCode *codePtr; /* Constant until the BC returns */
/* -----------------------------------------*/
ptrdiff_t *catchTop; /* These fields are used on return TO this */
Tcl_Obj *auxObjList; /* this level: they record the state when a */
CmdFrame cmdFrame; /* new codePtr was received for NR */
/* execution. */
void *stack[1]; /* Start of the actual combined catch and obj
|
| ︙ | ︙ | |||
140 141 142 143 144 145 146 |
objPtr->internalRep.twoPtrValue.ptr1 = auxObjList; \
auxObjList = objPtr; \
} while (0)
#define POP_TAUX_OBJ() \
do { \
tmpPtr = auxObjList; \
| | | 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 |
objPtr->internalRep.twoPtrValue.ptr1 = auxObjList; \
auxObjList = objPtr; \
} while (0)
#define POP_TAUX_OBJ() \
do { \
tmpPtr = auxObjList; \
auxObjList = (Tcl_Obj *)tmpPtr->internalRep.twoPtrValue.ptr1; \
Tcl_DecrRefCount(tmpPtr); \
} while (0)
/*
* These variable-access macros have to coincide with those in tclVar.c
*/
|
| ︙ | ︙ | |||
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 |
#ifndef TCL_COMPILE_DEBUG
#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \
do { \
pc += (pcAdjustment); \
switch (*pc) { \
case INST_JUMP_FALSE1: \
NEXT_INST_F(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \
case INST_JUMP_TRUE1: \
NEXT_INST_F(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \
case INST_JUMP_FALSE4: \
NEXT_INST_F(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \
case INST_JUMP_TRUE4: \
NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \
default: \
if ((condition) < 0) { \
TclNewIntObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
NEXT_INST_F(0, (cleanup), 1); \
} \
} while (0)
#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \
do { \
pc += (pcAdjustment); \
switch (*pc) { \
case INST_JUMP_FALSE1: \
NEXT_INST_V(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \
case INST_JUMP_TRUE1: \
NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \
case INST_JUMP_FALSE4: \
NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \
case INST_JUMP_TRUE4: \
NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \
default: \
if ((condition) < 0) { \
TclNewIntObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
NEXT_INST_V(0, (cleanup), 1); \
} \
} while (0)
#else /* TCL_COMPILE_DEBUG */
#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \
do{ \
if ((condition) < 0) { \
TclNewIntObj(objResultPtr, -1); \
| > > > > > > > > > > | 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 |
#ifndef TCL_COMPILE_DEBUG
#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \
do { \
pc += (pcAdjustment); \
switch (*pc) { \
case INST_JUMP_FALSE1: \
NEXT_INST_F(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \
break; \
case INST_JUMP_TRUE1: \
NEXT_INST_F(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \
break; \
case INST_JUMP_FALSE4: \
NEXT_INST_F(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \
break; \
case INST_JUMP_TRUE4: \
NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \
break; \
default: \
if ((condition) < 0) { \
TclNewIntObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
NEXT_INST_F(0, (cleanup), 1); \
break; \
} \
} while (0)
#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \
do { \
pc += (pcAdjustment); \
switch (*pc) { \
case INST_JUMP_FALSE1: \
NEXT_INST_V(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \
break; \
case INST_JUMP_TRUE1: \
NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \
break; \
case INST_JUMP_FALSE4: \
NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \
break; \
case INST_JUMP_TRUE4: \
NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \
break; \
default: \
if ((condition) < 0) { \
TclNewIntObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
NEXT_INST_V(0, (cleanup), 1); \
break; \
} \
} while (0)
#else /* TCL_COMPILE_DEBUG */
#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \
do{ \
if ((condition) < 0) { \
TclNewIntObj(objResultPtr, -1); \
|
| ︙ | ︙ | |||
439 440 441 442 443 444 445 |
* MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
* ClientData *ptrPtr, int *tPtr);
*/
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
((TclHasIntRep((objPtr), &tclIntType)) \
? (*(tPtr) = TCL_NUMBER_INT, \
| | | | 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 |
* MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
* ClientData *ptrPtr, int *tPtr);
*/
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
((TclHasIntRep((objPtr), &tclIntType)) \
? (*(tPtr) = TCL_NUMBER_INT, \
*(ptrPtr) = (ClientData) \
(&((objPtr)->internalRep.wideValue)), TCL_OK) : \
TclHasIntRep((objPtr), &tclDoubleType) \
? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \
? (*(tPtr) = TCL_NUMBER_NAN) \
: (*(tPtr) = TCL_NUMBER_DOUBLE)), \
*(ptrPtr) = (ClientData) \
(&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \
? TCL_ERROR : \
TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
/*
* Macro used to make the check for type overflow more mnemonic. This works by
|
| ︙ | ︙ | |||
590 591 592 593 594 595 596 597 598 599 600 601 602 603 | /* * Markers for ExecuteExtendedBinaryMathOp. */ #define DIVIDED_BY_ZERO ((Tcl_Obj *) -1) #define EXPONENT_OF_ZERO ((Tcl_Obj *) -2) #define GENERAL_ARITHMETIC_ERROR ((Tcl_Obj *) -3) /* * Declarations for local procedures to this file: */ #ifdef TCL_COMPILE_STATS static int EvalStatsCmd(ClientData clientData, | > | 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 | /* * Markers for ExecuteExtendedBinaryMathOp. */ #define DIVIDED_BY_ZERO ((Tcl_Obj *) -1) #define EXPONENT_OF_ZERO ((Tcl_Obj *) -2) #define GENERAL_ARITHMETIC_ERROR ((Tcl_Obj *) -3) #define OUT_OF_MEMORY ((Tcl_Obj *) -4) /* * Declarations for local procedures to this file: */ #ifdef TCL_COMPILE_STATS static int EvalStatsCmd(ClientData clientData, |
| ︙ | ︙ | |||
621 622 623 624 625 626 627 | Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); static Tcl_Obj * ExecuteExtendedUnaryMathOp(int opcode, Tcl_Obj *valuePtr); static void FreeExprCodeInternalRep(Tcl_Obj *objPtr); static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, int searchMode, ByteCode *codePtr); static const char * GetSrcInfoForPc(const unsigned char *pc, | | | | | 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 | Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); static Tcl_Obj * ExecuteExtendedUnaryMathOp(int opcode, Tcl_Obj *valuePtr); static void FreeExprCodeInternalRep(Tcl_Obj *objPtr); static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, int searchMode, ByteCode *codePtr); static const char * GetSrcInfoForPc(const unsigned char *pc, ByteCode *codePtr, int *lengthPtr, const unsigned char **pcBeg, int *cmdIdxPtr); static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth, int move); static void IllegalExprOperandType(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj *opndPtr); static void InitByteCodeExecution(Tcl_Interp *interp); static inline int wordSkip(void *ptr); static void ReleaseDictIterator(Tcl_Obj *objPtr); /* Useful elsewhere, make available in tclInt.h or stubs? */ static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords); static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords); static Tcl_NRPostProc CopyCallback; static Tcl_NRPostProc ExprObjCallback; static Tcl_NRPostProc FinalizeOONext; static Tcl_NRPostProc FinalizeOONextFilter; static Tcl_NRPostProc TEBCresume; /* |
| ︙ | ︙ | |||
696 697 698 699 700 701 702 |
assert(irPtr != NULL);
/*
* First kill the search, and then release the reference to the dictionary
* that we were holding.
*/
| | | | | 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 |
assert(irPtr != NULL);
/*
* First kill the search, and then release the reference to the dictionary
* that we were holding.
*/
searchPtr = (Tcl_DictSearch *)irPtr->twoPtrValue.ptr1;
Tcl_DictObjDone(searchPtr);
ckfree(searchPtr);
dictPtr = (Tcl_Obj *)irPtr->twoPtrValue.ptr2;
TclDecrRefCount(dictPtr);
}
/*
*----------------------------------------------------------------------
*
* InitByteCodeExecution --
|
| ︙ | ︙ | |||
725 726 727 728 729 730 731 732 733 734 735 736 737 738 |
* that counts the executions of each instruction and it creates the
* "evalstats" command. It also establishes the link between the Tcl
* "tcl_traceExec" and C "tclTraceExec" variables.
*
*----------------------------------------------------------------------
*/
static void
InitByteCodeExecution(
Tcl_Interp *interp) /* Interpreter for which the Tcl variable
* "tcl_traceExec" is linked to control
* instruction tracing. */
{
#ifdef TCL_COMPILE_DEBUG
| > | > > > > > > > > > | 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 |
* that counts the executions of each instruction and it creates the
* "evalstats" command. It also establishes the link between the Tcl
* "tcl_traceExec" and C "tclTraceExec" variables.
*
*----------------------------------------------------------------------
*/
#if defined(TCL_COMPILE_STATS) || defined(TCL_COMPILE_DEBUG)
static void
InitByteCodeExecution(
Tcl_Interp *interp) /* Interpreter for which the Tcl variable
* "tcl_traceExec" is linked to control
* instruction tracing. */
{
#ifdef TCL_COMPILE_DEBUG
if (Tcl_LinkVar(interp, "tcl_traceExec", &tclTraceExec,
TCL_LINK_INT) != TCL_OK) {
Tcl_Panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
}
#endif
#ifdef TCL_COMPILE_STATS
Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd, NULL, NULL);
#endif /* TCL_COMPILE_STATS */
}
#else
static void
InitByteCodeExecution(
TCL_UNUSED(Tcl_Interp *))
{
}
#endif
/*
*----------------------------------------------------------------------
*
* TclCreateExecEnv --
*
* This procedure creates a new execution environment for Tcl bytecode
|
| ︙ | ︙ | |||
768 769 770 771 772 773 774 |
*----------------------------------------------------------------------
*/
ExecEnv *
TclCreateExecEnv(
Tcl_Interp *interp, /* Interpreter for which the execution
* environment is being created. */
| | | | | | 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 |
*----------------------------------------------------------------------
*/
ExecEnv *
TclCreateExecEnv(
Tcl_Interp *interp, /* Interpreter for which the execution
* environment is being created. */
int size) /* The initial stack size, in number of words
* [sizeof(Tcl_Obj*)] */
{
ExecEnv *eePtr = (ExecEnv *)ckalloc(sizeof(ExecEnv));
ExecStack *esPtr = (ExecStack *)ckalloc(sizeof(ExecStack)
+ (size_t) (size-1) * 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;
|
| ︙ | ︙ | |||
832 833 834 835 836 837 838 |
if (esPtr->prevPtr) {
esPtr->prevPtr->nextPtr = esPtr->nextPtr;
}
if (esPtr->nextPtr) {
esPtr->nextPtr->prevPtr = esPtr->prevPtr;
}
| | | 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 |
if (esPtr->prevPtr) {
esPtr->prevPtr->nextPtr = esPtr->nextPtr;
}
if (esPtr->nextPtr) {
esPtr->nextPtr->prevPtr = esPtr->prevPtr;
}
ckfree(esPtr);
}
void
TclDeleteExecEnv(
ExecEnv *eePtr) /* Execution environment to free. */
{
ExecStack *esPtr = eePtr->execStackPtr, *tmpPtr;
|
| ︙ | ︙ | |||
864 865 866 867 868 869 870 |
TclDecrRefCount(eePtr->constants[1]);
if (eePtr->callbackPtr && !cachedInExit) {
Tcl_Panic("Deleting execEnv with pending TEOV callbacks!");
}
if (eePtr->corPtr && !cachedInExit) {
Tcl_Panic("Deleting execEnv with existing coroutine");
}
| | | 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 |
TclDecrRefCount(eePtr->constants[1]);
if (eePtr->callbackPtr && !cachedInExit) {
Tcl_Panic("Deleting execEnv with pending TEOV callbacks!");
}
if (eePtr->corPtr && !cachedInExit) {
Tcl_Panic("Deleting execEnv with existing coroutine");
}
ckfree(eePtr);
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeExecution --
*
|
| ︙ | ︙ | |||
955 956 957 958 959 960 961 |
ExecEnv *eePtr, /* Points to the ExecEnv with an evaluation
* stack to enlarge. */
int growth, /* How much larger than the current used
* size. */
int move) /* 1 if move words since last marker. */
{
ExecStack *esPtr = eePtr->execStackPtr, *oldPtr = NULL;
| | | | 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 |
ExecEnv *eePtr, /* Points to the ExecEnv with an evaluation
* stack to enlarge. */
int growth, /* How much larger than the current used
* size. */
int move) /* 1 if move words since last marker. */
{
ExecStack *esPtr = eePtr->execStackPtr, *oldPtr = NULL;
int newBytes, newElems, currElems;
int needed = growth - (esPtr->endPtr - esPtr->tosPtr);
Tcl_Obj **markerPtr = esPtr->markerPtr, **memStart;
int moveWords = 0;
if (move) {
if (!markerPtr) {
Tcl_Panic("STACK: Reallocating with no previous alloc");
}
|
| ︙ | ︙ | |||
1041 1042 1043 1044 1045 1046 1047 |
#else
newElems = needed;
#endif
newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *);
oldPtr = esPtr;
| | | 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 |
#else
newElems = needed;
#endif
newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *);
oldPtr = esPtr;
esPtr = (ExecStack *)ckalloc(newBytes);
oldPtr->nextPtr = esPtr;
esPtr->prevPtr = oldPtr;
esPtr->nextPtr = NULL;
esPtr->endPtr = &esPtr->stackWords[newElems-1];
newStackReady:
|
| ︙ | ︙ | |||
1101 1102 1103 1104 1105 1106 1107 |
*
*--------------------------------------------------------------
*/
static Tcl_Obj **
StackAllocWords(
Tcl_Interp *interp,
| | | | | 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 |
*
*--------------------------------------------------------------
*/
static Tcl_Obj **
StackAllocWords(
Tcl_Interp *interp,
int numWords)
{
/*
* Note that GrowEvaluationStack sets a marker in the stack. This marker
* is read when rewinding, e.g., by TclStackFree.
*/
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr = iPtr->execEnvPtr;
Tcl_Obj **resPtr = GrowEvaluationStack(eePtr, numWords, 0);
eePtr->execStackPtr->tosPtr += numWords;
return resPtr;
}
static Tcl_Obj **
StackReallocWords(
Tcl_Interp *interp,
int numWords)
{
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr = iPtr->execEnvPtr;
Tcl_Obj **resPtr = GrowEvaluationStack(eePtr, numWords, 1);
eePtr->execStackPtr->tosPtr += numWords;
return resPtr;
}
void
TclStackFree(
Tcl_Interp *interp,
void *freePtr)
{
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr;
ExecStack *esPtr;
Tcl_Obj **markerPtr, *marker;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
ckfree(freePtr);
return;
}
/*
* Rewind the stack to the previous marker position. The current marker,
* as set in the last call to GrowEvaluationStack, contains a pointer to
* the previous marker.
|
| ︙ | ︙ | |||
1198 1199 1200 1201 1202 1203 1204 |
eePtr->execStackPtr = esPtr;
}
}
void *
TclStackAlloc(
Tcl_Interp *interp,
| | | | | | | | | 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 |
eePtr->execStackPtr = esPtr;
}
}
void *
TclStackAlloc(
Tcl_Interp *interp,
int numBytes)
{
Interp *iPtr = (Interp *) interp;
int numWords;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
return (void *) ckalloc(numBytes);
}
numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *);
return (void *) StackAllocWords(interp, numWords);
}
void *
TclStackRealloc(
Tcl_Interp *interp,
void *ptr,
int numBytes)
{
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr;
ExecStack *esPtr;
Tcl_Obj **markerPtr;
int numWords;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
return (void *) ckrealloc((char *) ptr, numBytes);
}
eePtr = iPtr->execEnvPtr;
esPtr = eePtr->execStackPtr;
markerPtr = esPtr->markerPtr;
if (MEMSTART(markerPtr) != (Tcl_Obj **)ptr) {
|
| ︙ | ︙ | |||
1265 1266 1267 1268 1269 1270 1271 |
*--------------------------------------------------------------
*/
int
Tcl_ExprObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
| | | | | | 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 |
*--------------------------------------------------------------
*/
int
Tcl_ExprObj(
Tcl_Interp *interp, /* Context in which to evaluate the
* expression. */
Tcl_Obj *objPtr, /* Points to Tcl object containing expression
* to evaluate. */
Tcl_Obj **resultPtrPtr) /* Where the Tcl_Obj* that is the expression
* result is stored if no errors occur. */
{
NRE_callback *rootPtr = TOP_CB(interp);
Tcl_Obj *resultPtr;
TclNewObj(resultPtr);
TclNRAddCallback(interp, CopyCallback, resultPtrPtr, resultPtr,
NULL, NULL);
Tcl_NRExprObj(interp, objPtr, resultPtr);
return TclNRRunCallbacks(interp, TCL_OK, rootPtr);
}
static int
CopyCallback(
ClientData data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
Tcl_Obj **resultPtrPtr = (Tcl_Obj **)data[0];
Tcl_Obj *resultPtr = (Tcl_Obj *)data[1];
if (result == TCL_OK) {
*resultPtrPtr = resultPtr;
Tcl_IncrRefCount(resultPtr);
} else {
Tcl_DecrRefCount(resultPtr);
}
|
| ︙ | ︙ | |||
1344 1345 1346 1347 1348 1349 1350 |
static int
ExprObjCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 |
static int
ExprObjCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_InterpState state = (Tcl_InterpState)data[0];
Tcl_Obj *resultPtr = (Tcl_Obj *)data[1];
if (result == TCL_OK) {
TclSetDuplicateObj(resultPtr, Tcl_GetObjResult(interp));
(void) Tcl_RestoreInterpState(interp, state);
} else {
Tcl_DiscardInterpState(state);
}
|
| ︙ | ︙ | |||
1411 1412 1413 1414 1415 1416 1417 |
}
if (codePtr == NULL) {
/*
* TIP #280: No invoker (yet) - Expression compilation.
*/
| < | | | | 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 |
}
if (codePtr == NULL) {
/*
* TIP #280: No invoker (yet) - Expression compilation.
*/
const char *string = TclGetString(objPtr);
TclInitCompileEnv(interp, &compEnv, string, objPtr->length, NULL, 0);
TclCompileExpr(interp, string, objPtr->length, &compEnv, 0);
/*
* Successful compilation. If the expression yielded no instructions,
* push an zero object as the expression's result.
*/
if (compEnv.codeNext == compEnv.codeStart) {
|
| ︙ | ︙ | |||
1479 1480 1481 1482 1483 1484 1485 | * None. * *---------------------------------------------------------------------- */ static void DupExprCodeInternalRep( | | | | 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 |
* None.
*
*----------------------------------------------------------------------
*/
static void
DupExprCodeInternalRep(
TCL_UNUSED(Tcl_Obj *),
TCL_UNUSED(Tcl_Obj *))
{
return;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1632 1633 1634 1635 1636 1637 1638 |
CmdFrame *ctxCopyPtr;
int redo;
if (!hePtr) {
return codePtr;
}
| | | | 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 |
CmdFrame *ctxCopyPtr;
int redo;
if (!hePtr) {
return codePtr;
}
eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr);
redo = 0;
ctxCopyPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
*ctxCopyPtr = *invoker;
if (invoker->type == TCL_LOCATION_BC) {
/*
* Note: Type BC => ctx.data.eval.path is not used.
* ctx.data.tebc.codePtr used instead
*/
|
| ︙ | ︙ | |||
1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 |
Tcl_Interp *interp,
Tcl_Obj *valuePtr,
Tcl_Obj *incrPtr)
{
ClientData ptr1, ptr2;
int type1, type2;
mp_int value, incr;
if (Tcl_IsShared(valuePtr)) {
Tcl_Panic("%s called with shared object", "TclIncrObj");
}
if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) {
/*
| > | 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 |
Tcl_Interp *interp,
Tcl_Obj *valuePtr,
Tcl_Obj *incrPtr)
{
ClientData ptr1, ptr2;
int type1, type2;
mp_int value, incr;
mp_err err;
if (Tcl_IsShared(valuePtr)) {
Tcl_Panic("%s called with shared object", "TclIncrObj");
}
if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) {
/*
|
| ︙ | ︙ | |||
1788 1789 1790 1791 1792 1793 1794 |
TclSetIntObj(valuePtr, sum);
return TCL_OK;
}
}
Tcl_TakeBignumFromObj(interp, valuePtr, &value);
Tcl_GetBignumFromObj(interp, incrPtr, &incr);
| | > > > | 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 |
TclSetIntObj(valuePtr, sum);
return TCL_OK;
}
}
Tcl_TakeBignumFromObj(interp, valuePtr, &value);
Tcl_GetBignumFromObj(interp, incrPtr, &incr);
err = mp_add(&value, &incr, &value);
mp_clear(&incr);
if (err != MP_OKAY) {
return TCL_ERROR;
}
Tcl_SetBignumObj(valuePtr, &value);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1920 1921 1922 1923 1924 1925 1926 |
TclResetRewriteEnsemble(interp, 1);
/*
* Push the callback for bytecode execution
*/
TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL,
| | > > > > > > > | 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 |
TclResetRewriteEnsemble(interp, 1);
/*
* Push the callback for bytecode execution
*/
TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL,
/* cleanup */ INT2PTR(0), INT2PTR(iPtr->evalFlags));
/*
* Reset discard result flag - because it is applicable for this call only,
* and should not affect all the nested invocations may return result.
*/
iPtr->evalFlags &= ~TCL_EVAL_DISCARD_RESULT;
return TCL_OK;
}
static int
TEBCresume(
ClientData data[],
Tcl_Interp *interp,
|
| ︙ | ︙ | |||
1978 1979 1980 1981 1982 1983 1984 |
#define TCONST(i) (constants[(i)])
/*
* These macros are just meant to save some global variables that are not
* used too frequently
*/
| | > | | | | 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 |
#define TCONST(i) (constants[(i)])
/*
* These macros are just meant to save some global variables that are not
* used too frequently
*/
TEBCdata *TD = (TEBCdata *)data[0];
#define auxObjList (TD->auxObjList)
#define catchTop (TD->catchTop)
#define codePtr (TD->codePtr)
#define curEvalFlags PTR2INT(data[3]) /* calling iPtr->evalFlags */
/*
* Globals: variables that store state, must remain valid at all times.
*/
Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation
* stack. */
const unsigned char *pc = (const unsigned char *)data[1];
/* The current program counter. */
unsigned char inst; /* The currently running instruction */
/*
* Transfer variables - needed only between opcodes, but not while
* executing an instruction.
*/
int cleanup = PTR2INT(data[2]);
Tcl_Obj *objResultPtr;
int checkInterp = 0; /* Indicates when a check of interp readyness
* is necessary. Set by CACHE_STACK_INFO() */
/*
* Locals - variables that are used within opcodes or bounded sections of
* the file (jumps between opcodes within a family).
* NOTE: These are now mostly defined locally where needed.
*/
Tcl_Obj *objPtr, *valuePtr, *value2Ptr, *part1Ptr, *part2Ptr, *tmpPtr;
Tcl_Obj **objv = NULL;
int objc = 0;
int opnd, length, pcAdjustment;
Var *varPtr, *arrayPtr;
#ifdef TCL_COMPILE_DEBUG
char cmdNameBuf[21];
#endif
|
| ︙ | ︙ | |||
2035 2036 2037 2038 2039 2040 2041 |
fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH);
fflush(stdout);
}
#endif
if (!pc) {
/* bytecode is starting from scratch */
| < | 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 |
fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH);
fflush(stdout);
}
#endif
if (!pc) {
/* bytecode is starting from scratch */
pc = codePtr->codeStart;
goto cleanup0;
} else {
/* resume from invocation */
CACHE_STACK_INFO();
NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
|
| ︙ | ︙ | |||
2057 2058 2059 2060 2061 2062 2063 |
TclArgumentBCRelease(interp, bcFramePtr);
}
if (iPtr->execEnvPtr->rewind) {
result = TCL_ERROR;
goto abnormalReturn;
}
if (codePtr->flags & TCL_BYTECODE_RECOMPILE) {
| < > > | 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 |
TclArgumentBCRelease(interp, bcFramePtr);
}
if (iPtr->execEnvPtr->rewind) {
result = TCL_ERROR;
goto abnormalReturn;
}
if (codePtr->flags & TCL_BYTECODE_RECOMPILE) {
codePtr->flags &= ~TCL_BYTECODE_RECOMPILE;
checkInterp = 1;
iPtr->flags |= ERR_ALREADY_LOGGED;
}
if (result != TCL_OK) {
pc--;
goto processExceptionReturn;
}
|
| ︙ | ︙ | |||
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 |
goto cleanup0;
default:
cleanup -= 2;
while (cleanup--) {
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
}
case 2:
cleanup2_pushObjResultPtr:
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
case 1:
cleanup1_pushObjResultPtr:
objPtr = OBJ_AT_TOS;
TclDecrRefCount(objPtr);
}
OBJ_AT_TOS = objResultPtr;
goto cleanup0;
cleanupV:
switch (cleanup) {
default:
cleanup -= 2;
while (cleanup--) {
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
}
case 2:
cleanup2:
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
case 1:
cleanup1:
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
case 0:
/*
* We really want to do nothing now, but this is needed for some
* compilers (SunPro CC).
*/
break;
| > > > > > | 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 |
goto cleanup0;
default:
cleanup -= 2;
while (cleanup--) {
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
}
/* FALLTHRU */
case 2:
cleanup2_pushObjResultPtr:
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
/* FALLTHRU */
case 1:
cleanup1_pushObjResultPtr:
objPtr = OBJ_AT_TOS;
TclDecrRefCount(objPtr);
}
OBJ_AT_TOS = objResultPtr;
goto cleanup0;
cleanupV:
switch (cleanup) {
default:
cleanup -= 2;
while (cleanup--) {
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
}
/* FALLTHRU */
case 2:
cleanup2:
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
/* FALLTHRU */
case 1:
cleanup1:
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
/* FALLTHRU */
case 0:
/*
* We really want to do nothing now, but this is needed for some
* compilers (SunPro CC).
*/
break;
|
| ︙ | ︙ | |||
2233 2234 2235 2236 2237 2238 2239 |
} else if (inst == INST_START_CMD) {
/*
* Peephole: do not run INST_START_CMD, just skip it
*/
iPtr->cmdCount += TclGetUInt4AtPtr(pc+5);
if (checkInterp) {
| < > | 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 |
} else if (inst == INST_START_CMD) {
/*
* Peephole: do not run INST_START_CMD, just skip it
*/
iPtr->cmdCount += TclGetUInt4AtPtr(pc+5);
if (checkInterp) {
if (((codePtr->compileEpoch != iPtr->compileEpoch) ||
(codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) &&
!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
goto instStartCmdFailed;
}
checkInterp = 0;
}
inst = *(pc += 9);
goto peepholeStart;
} else if (inst == INST_NOP) {
#ifndef TCL_COMPILE_DEBUG
while (inst == INST_NOP)
#endif
|
| ︙ | ︙ | |||
2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 |
result = TCL_RETURN;
cleanup = opnd;
goto processExceptionReturn;
}
case INST_DONE:
if (tosPtr > initTosPtr) {
/*
* Set the interpreter's object result to point to the topmost
* object from the stack, and check for a possible [catch]. The
* stackTop's level and refCount will be handled by "processCatch"
* or "abnormalReturn".
*/
| > > > > > > > > | 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 |
result = TCL_RETURN;
cleanup = opnd;
goto processExceptionReturn;
}
case INST_DONE:
if (tosPtr > initTosPtr) {
if ((curEvalFlags & TCL_EVAL_DISCARD_RESULT) && (result == TCL_OK)) {
/* simulate pop & fast done (like it does continue in loop) */
TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS);
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
goto abnormalReturn;
}
/*
* Set the interpreter's object result to point to the topmost
* object from the stack, and check for a possible [catch]. The
* stackTop's level and refCount will be handled by "processCatch"
* or "abnormalReturn".
*/
|
| ︙ | ︙ | |||
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 |
(void) POP_OBJECT();
goto abnormalReturn;
case INST_PUSH4:
objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr);
NEXT_INST_F(5, 0, 1);
case INST_POP:
TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS);
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
NEXT_INST_F(1, 0, 0);
case INST_DUP:
objResultPtr = OBJ_AT_TOS;
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
case INST_OVER:
opnd = TclGetUInt4AtPtr(pc+1);
objResultPtr = OBJ_AT_DEPTH(opnd);
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_F(5, 0, 1);
case INST_REVERSE: {
Tcl_Obj **a, **b;
opnd = TclGetUInt4AtPtr(pc+1);
a = tosPtr-(opnd-1);
b = tosPtr;
while (a<b) {
tmpPtr = *a;
*a = *b;
*b = tmpPtr;
a++; b--;
}
TRACE(("%u => OK\n", opnd));
NEXT_INST_F(5, 0, 0);
}
case INST_STR_CONCAT1:
opnd = TclGetUInt1AtPtr(pc+1);
objResultPtr = TclStringCat(interp, opnd, &OBJ_AT_DEPTH(opnd-1),
TCL_STRING_IN_PLACE);
if (objResultPtr == NULL) {
TRACE_ERROR(interp);
goto gotError;
}
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(2, opnd, 1);
case INST_CONCAT_STK:
/*
* Pop the opnd (objc) top stack elements, run through Tcl_ConcatObj,
* and then decrement their ref counts.
*/
opnd = TclGetUInt4AtPtr(pc+1);
objResultPtr = Tcl_ConcatObj(opnd, &OBJ_AT_DEPTH(opnd-1));
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(5, opnd, 1);
case INST_EXPAND_START:
/*
* Push an element to the auxObjList. This records the current
* stack depth - i.e., the point in the stack where the expanded
* command starts.
*
* Use a Tcl_Obj as linked list element; slight mem waste, but faster
| > > > > > > > | > | 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 |
(void) POP_OBJECT();
goto abnormalReturn;
case INST_PUSH4:
objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr);
NEXT_INST_F(5, 0, 1);
break;
case INST_POP:
TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS);
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr);
NEXT_INST_F(1, 0, 0);
break;
case INST_DUP:
objResultPtr = OBJ_AT_TOS;
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
break;
case INST_OVER:
opnd = TclGetUInt4AtPtr(pc+1);
objResultPtr = OBJ_AT_DEPTH(opnd);
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_F(5, 0, 1);
break;
case INST_REVERSE: {
Tcl_Obj **a, **b;
opnd = TclGetUInt4AtPtr(pc+1);
a = tosPtr-(opnd-1);
b = tosPtr;
while (a<b) {
tmpPtr = *a;
*a = *b;
*b = tmpPtr;
a++; b--;
}
TRACE(("%u => OK\n", opnd));
NEXT_INST_F(5, 0, 0);
}
break;
case INST_STR_CONCAT1:
opnd = TclGetUInt1AtPtr(pc+1);
objResultPtr = TclStringCat(interp, opnd, &OBJ_AT_DEPTH(opnd-1),
TCL_STRING_IN_PLACE);
if (objResultPtr == NULL) {
TRACE_ERROR(interp);
goto gotError;
}
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(2, opnd, 1);
break;
case INST_CONCAT_STK:
/*
* Pop the opnd (objc) top stack elements, run through Tcl_ConcatObj,
* and then decrement their ref counts.
*/
opnd = TclGetUInt4AtPtr(pc+1);
objResultPtr = Tcl_ConcatObj(opnd, &OBJ_AT_DEPTH(opnd-1));
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(5, opnd, 1);
break;
case INST_EXPAND_START:
/*
* Push an element to the auxObjList. This records the current
* stack depth - i.e., the point in the stack where the expanded
* command starts.
*
* Use a Tcl_Obj as linked list element; slight mem waste, but faster
* allocation than ckalloc. This also abuses the Tcl_Obj structure, as
* we do not define a special tclObjType for it. It is not dangerous
* as the obj is never passed anywhere, so that all manipulations are
* performed here and in INST_INVOKE_EXPANDED (in case of an expansion
* error, also in INST_EXPAND_STKTOP).
*/
TclNewObj(objPtr);
objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(CURR_DEPTH);
objPtr->length = 0;
PUSH_TAUX_OBJ(objPtr);
TRACE(("=> mark depth as %d\n", (int) CURR_DEPTH));
NEXT_INST_F(1, 0, 0);
break;
case INST_EXPAND_DROP:
/*
* Drops an element of the auxObjList, popping stack elements to
* restore the stack to the state before the point where the aux
* element was created.
*/
|
| ︙ | ︙ | |||
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 |
PUSH_OBJECT(objv[i]);
}
TRACE_APPEND(("OK\n"));
Tcl_DecrRefCount(objPtr);
NEXT_INST_F(5, 0, 0);
}
case INST_EXPR_STK: {
ByteCode *newCodePtr;
bcFramePtr->data.tebc.pc = (char *) pc;
iPtr->cmdFramePtr = bcFramePtr;
DECACHE_STACK_INFO();
newCodePtr = CompileExprObj(interp, OBJ_AT_TOS);
CACHE_STACK_INFO();
cleanup = 1;
pc++;
TEBC_YIELD();
return TclNRExecuteByteCode(interp, newCodePtr);
}
/*
* INVOCATION BLOCK
*/
| > < > > > > | > | 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 |
PUSH_OBJECT(objv[i]);
}
TRACE_APPEND(("OK\n"));
Tcl_DecrRefCount(objPtr);
NEXT_INST_F(5, 0, 0);
}
break;
case INST_EXPR_STK: {
ByteCode *newCodePtr;
bcFramePtr->data.tebc.pc = (char *) pc;
iPtr->cmdFramePtr = bcFramePtr;
DECACHE_STACK_INFO();
newCodePtr = CompileExprObj(interp, OBJ_AT_TOS);
CACHE_STACK_INFO();
cleanup = 1;
pc++;
TEBC_YIELD();
return TclNRExecuteByteCode(interp, newCodePtr);
}
/*
* INVOCATION BLOCK
*/
case INST_EVAL_STK:
instEvalStk:
bcFramePtr->data.tebc.pc = (char *) pc;
iPtr->cmdFramePtr = bcFramePtr;
cleanup = 1;
pc += 1;
/* yield next instruction */
TEBC_YIELD();
/* add TEBCResume for object at top of stack */
return TclNRExecuteByteCode(interp,
TclCompileObj(interp, OBJ_AT_TOS, NULL, 0));
case INST_INVOKE_EXPANDED:
CLANG_ASSERT(auxObjList);
objc = CURR_DEPTH - PTR2INT(auxObjList->internalRep.twoPtrValue.ptr2);
POP_TAUX_OBJ();
if (objc) {
pcAdjustment = 1;
goto doInvocation;
}
/*
* Nothing was expanded, return {}.
*/
TclNewObj(objResultPtr);
NEXT_INST_F(1, 0, 1);
break;
case INST_INVOKE_STK4:
objc = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doInvocation;
case INST_INVOKE_STK1:
|
| ︙ | ︙ | |||
2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 |
DECACHE_STACK_INFO();
pc += pcAdjustment;
TEBC_YIELD();
return TclNREvalObjv(interp, objc, objv,
TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME, NULL);
case INST_INVOKE_REPLACE:
objc = TclGetUInt4AtPtr(pc+1);
opnd = TclGetUInt1AtPtr(pc+5);
objPtr = POP_OBJECT();
objv = &OBJ_AT_DEPTH(objc-1);
cleanup = objc;
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
DECACHE_STACK_INFO();
pc += pcAdjustment;
TEBC_YIELD();
return TclNREvalObjv(interp, objc, objv,
TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME, NULL);
#if TCL_SUPPORT_84_BYTECODE
case INST_CALL_BUILTIN_FUNC1:
/*
* Call one of the built-in pre-8.5 Tcl math functions. This
* translates to INST_INVOKE_STK1 with the first argument of
* ::tcl::mathfunc::$objv[0]. We need to insert the named math
* function into the stack.
*/
opnd = TclGetUInt1AtPtr(pc+1);
if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
Tcl_Panic("TclNRExecuteByteCode: unrecognized builtin function code %d", opnd);
}
TclNewLiteralStringObj(objPtr, "::tcl::mathfunc::");
Tcl_AppendToObj(objPtr, tclBuiltinFuncTable[opnd].name, -1);
/*
* Only 0, 1 or 2 args.
*/
{
int numArgs = tclBuiltinFuncTable[opnd].numArgs;
Tcl_Obj *tmpPtr1, *tmpPtr2;
if (numArgs == 0) {
PUSH_OBJECT(objPtr);
} else if (numArgs == 1) {
tmpPtr1 = POP_OBJECT();
PUSH_OBJECT(objPtr);
PUSH_OBJECT(tmpPtr1);
Tcl_DecrRefCount(tmpPtr1);
} else {
tmpPtr2 = POP_OBJECT();
tmpPtr1 = POP_OBJECT();
PUSH_OBJECT(objPtr);
PUSH_OBJECT(tmpPtr1);
PUSH_OBJECT(tmpPtr2);
Tcl_DecrRefCount(tmpPtr1);
Tcl_DecrRefCount(tmpPtr2);
}
objc = numArgs + 1;
}
pcAdjustment = 2;
goto doInvocation;
case INST_CALL_FUNC1:
/*
* Call a non-builtin Tcl math function previously registered by a
* call to Tcl_CreateMathFunc pre-8.5. This is essentially
* INST_INVOKE_STK1 converting the first arg to
* ::tcl::mathfunc::$objv[0].
*/
objc = TclGetUInt1AtPtr(pc+1); /* Number of arguments. The function
* name is the 0-th argument. */
objPtr = OBJ_AT_DEPTH(objc-1);
TclNewLiteralStringObj(tmpPtr, "::tcl::mathfunc::");
Tcl_AppendObjToObj(tmpPtr, objPtr);
Tcl_DecrRefCount(objPtr);
/*
* Variation of PUSH_OBJECT.
*/
OBJ_AT_DEPTH(objc-1) = tmpPtr;
Tcl_IncrRefCount(tmpPtr);
pcAdjustment = 2;
goto doInvocation;
#else
/*
* INST_CALL_BUILTIN_FUNC1 and INST_CALL_FUNC1 were made obsolete by the
* changes to add a ::tcl::mathfunc namespace in 8.5. Optional support
* remains for existing bytecode precompiled files.
*/
case INST_CALL_BUILTIN_FUNC1:
Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found");
case INST_CALL_FUNC1:
Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_FUNC1 found");
#endif
case INST_INVOKE_REPLACE:
objc = TclGetUInt4AtPtr(pc+1);
opnd = TclGetUInt1AtPtr(pc+5);
objPtr = POP_OBJECT();
objv = &OBJ_AT_DEPTH(objc-1);
cleanup = objc;
|
| ︙ | ︙ | |||
3564 3565 3566 3567 3568 3569 3570 |
varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
arrayPtr = NULL;
part1Ptr = part2Ptr = NULL;
cleanup = 0;
| | | 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 |
varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
arrayPtr = NULL;
part1Ptr = part2Ptr = NULL;
cleanup = 0;
TRACE(("%u %s => ", opnd, Tcl_GetString(incrPtr)));
doIncrVar:
if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) {
objPtr = varPtr->value.objPtr;
if (Tcl_IsShared(objPtr)) {
objPtr->refCount--; /* We know it's shared */
objResultPtr = Tcl_DuplicateObj(objPtr);
|
| ︙ | ︙ | |||
3831 3832 3833 3834 3835 3836 3837 |
TRACE_APPEND(("OK\n"));
NEXT_INST_V(2, cleanup, 0);
errorInUnset:
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
| | > > > > > > > > > > > > > > > > > > > > > > > > | 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 |
TRACE_APPEND(("OK\n"));
NEXT_INST_V(2, cleanup, 0);
errorInUnset:
CACHE_STACK_INFO();
TRACE_ERROR(interp);
goto gotError;
/*
* This is really an unset operation these days. Do not issue.
*/
case INST_DICT_DONE:
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => OK\n", opnd));
varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) {
if (!TclIsVarUndefined(varPtr)) {
TclDecrRefCount(varPtr->value.objPtr);
}
varPtr->value.objPtr = NULL;
} else {
DECACHE_STACK_INFO();
TclPtrUnsetVarIdx(interp, varPtr, NULL, NULL, NULL, 0, opnd);
CACHE_STACK_INFO();
}
NEXT_INST_F(5, 0, 0);
}
break;
/*
* End of INST_UNSET instructions.
* -----------------------------------------------------------------
* Start of INST_ARRAY instructions.
*/
|
| ︙ | ︙ | |||
4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 |
* Do not pop the namespace or frame index, it may be needed for other
* variables - and [variable] did not push it at all.
*/
TRACE_APPEND(("link made\n"));
NEXT_INST_F(5, 1, 0);
}
/*
* End of variable linking instructions.
* -----------------------------------------------------------------
*/
case INST_JUMP1:
opnd = TclGetInt1AtPtr(pc+1);
TRACE(("%d => new pc %u\n", opnd,
(unsigned)(pc + opnd - codePtr->codeStart)));
NEXT_INST_F(opnd, 0, 0);
case INST_JUMP4:
opnd = TclGetInt4AtPtr(pc+1);
TRACE(("%d => new pc %u\n", opnd,
(unsigned)(pc + opnd - codePtr->codeStart)));
NEXT_INST_F(opnd, 0, 0);
| > > | 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 |
* Do not pop the namespace or frame index, it may be needed for other
* variables - and [variable] did not push it at all.
*/
TRACE_APPEND(("link made\n"));
NEXT_INST_F(5, 1, 0);
}
break;
/*
* End of variable linking instructions.
* -----------------------------------------------------------------
*/
case INST_JUMP1:
opnd = TclGetInt1AtPtr(pc+1);
TRACE(("%d => new pc %u\n", opnd,
(unsigned)(pc + opnd - codePtr->codeStart)));
NEXT_INST_F(opnd, 0, 0);
break;
case INST_JUMP4:
opnd = TclGetInt4AtPtr(pc+1);
TRACE(("%d => new pc %u\n", opnd,
(unsigned)(pc + opnd - codePtr->codeStart)));
NEXT_INST_F(opnd, 0, 0);
|
| ︙ | ︙ | |||
4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 |
TRACE_APPEND(("%.20s false, new pc %u\n", O2S(valuePtr),
(unsigned)(pc + jmpOffset[0] - codePtr->codeStart)));
}
}
#endif
NEXT_INST_F(jmpOffset[b], 1, 0);
}
case INST_JUMP_TABLE: {
Tcl_HashEntry *hPtr;
JumptableInfo *jtPtr;
/*
* Jump to location looked up in a hashtable; fall through to next
| > | 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 |
TRACE_APPEND(("%.20s false, new pc %u\n", O2S(valuePtr),
(unsigned)(pc + jmpOffset[0] - codePtr->codeStart)));
}
}
#endif
NEXT_INST_F(jmpOffset[b], 1, 0);
}
break;
case INST_JUMP_TABLE: {
Tcl_HashEntry *hPtr;
JumptableInfo *jtPtr;
/*
* Jump to location looked up in a hashtable; fall through to next
|
| ︙ | ︙ | |||
4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 |
(unsigned)(pc - codePtr->codeStart + jumpOffset)));
NEXT_INST_F(jumpOffset, 1, 0);
} else {
TRACE_APPEND(("not found in table\n"));
NEXT_INST_F(5, 1, 0);
}
}
/*
* -----------------------------------------------------------------
* Start of general introspector instructions.
*/
case INST_NS_CURRENT: {
Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) {
TclNewLiteralStringObj(objResultPtr, "::");
} else {
TclNewStringObj(objResultPtr, currNsPtr->fullName,
strlen(currNsPtr->fullName));
}
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
}
case INST_COROUTINE_NAME: {
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
TclNewObj(objResultPtr);
if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) {
Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr,
objResultPtr);
}
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
}
case INST_INFO_LEVEL_NUM:
TclNewIntObj(objResultPtr, iPtr->varFramePtr->level);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
case INST_INFO_LEVEL_ARGS: {
int level;
CallFrame *framePtr = iPtr->varFramePtr;
CallFrame *rootFramePtr = iPtr->rootFramePtr;
TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
if (TclGetIntFromObj(interp, OBJ_AT_TOS, &level) != TCL_OK) {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 |
(unsigned)(pc - codePtr->codeStart + jumpOffset)));
NEXT_INST_F(jumpOffset, 1, 0);
} else {
TRACE_APPEND(("not found in table\n"));
NEXT_INST_F(5, 1, 0);
}
}
break;
/*
* These two instructions are now redundant: the complete logic of the LOR
* and LAND is now handled by the expression compiler.
*/
case INST_LOR:
case INST_LAND: {
/*
* Operands must be boolean or numeric. No int->double conversions are
* performed.
*/
int i1, i2, iResult;
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
if (TclGetBooleanFromObj(NULL, valuePtr, &i1) != TCL_OK) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
goto gotError;
}
if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr),
(value2Ptr->typePtr? value2Ptr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, value2Ptr);
CACHE_STACK_INFO();
goto gotError;
}
if (*pc == INST_LOR) {
iResult = (i1 || i2);
} else {
iResult = (i1 && i2);
}
objResultPtr = TCONST(iResult);
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult));
NEXT_INST_F(1, 2, 1);
}
break;
/*
* -----------------------------------------------------------------
* Start of general introspector instructions.
*/
case INST_NS_CURRENT: {
Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) {
TclNewLiteralStringObj(objResultPtr, "::");
} else {
TclNewStringObj(objResultPtr, currNsPtr->fullName,
strlen(currNsPtr->fullName));
}
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
}
break;
case INST_COROUTINE_NAME: {
CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
TclNewObj(objResultPtr);
if (corPtr && !(corPtr->cmdPtr->flags & CMD_IS_DELETED)) {
Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr,
objResultPtr);
}
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
}
break;
case INST_INFO_LEVEL_NUM:
TclNewIntObj(objResultPtr, iPtr->varFramePtr->level);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
break;
case INST_INFO_LEVEL_ARGS: {
int level;
CallFrame *framePtr = iPtr->varFramePtr;
CallFrame *rootFramePtr = iPtr->rootFramePtr;
TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
if (TclGetIntFromObj(interp, OBJ_AT_TOS, &level) != TCL_OK) {
|
| ︙ | ︙ | |||
4270 4271 4272 4273 4274 4275 4276 | "self may only be called from inside a method", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); CACHE_STACK_INFO(); goto gotError; } | | | 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 |
"self may only be called from inside a method",
-1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
CACHE_STACK_INFO();
goto gotError;
}
contextPtr = (CallContext *)framePtr->clientData;
/*
* Call out to get the name; it's expensive to compute but cached.
*/
objResultPtr = TclOOObjectName(interp, contextPtr->oPtr);
TRACE_WITH_OBJ(("=> "), objResultPtr);
|
| ︙ | ︙ | |||
4298 4299 4300 4301 4302 4303 4304 | "nextto may only be called from inside a method", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); CACHE_STACK_INFO(); goto gotError; } | | | 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 |
"nextto may only be called from inside a method",
-1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
CACHE_STACK_INFO();
goto gotError;
}
contextPtr = (CallContext *)framePtr->clientData;
oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr);
if (oPtr == NULL) {
TRACE_APPEND(("ERROR: \"%.30s\" not object\n", O2S(valuePtr)));
goto gotError;
} else {
Class *classPtr = oPtr->classPtr;
|
| ︙ | ︙ | |||
4397 4398 4399 4400 4401 4402 4403 | "next may only be called from inside a method", -1)); DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL); CACHE_STACK_INFO(); goto gotError; } | | | 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 |
"next may only be called from inside a method",
-1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
CACHE_STACK_INFO();
goto gotError;
}
contextPtr = (CallContext *)framePtr->clientData;
newDepth = contextPtr->index + 1;
if (newDepth >= contextPtr->callPtr->numChain) {
/*
* We're at the end of the chain; generate an error message unless
* the interpreter is being torn down, in which case we might be
* getting here because of methods/destructors doing a [next] (or
|
| ︙ | ︙ | |||
4525 4526 4527 4528 4529 4530 4531 |
/*
* End of TclOO support instructions.
* -----------------------------------------------------------------
* Start of INST_LIST and related instructions.
*/
{
| | | | 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 |
/*
* End of TclOO support instructions.
* -----------------------------------------------------------------
* Start of INST_LIST and related instructions.
*/
{
int index, numIndices, fromIdx, toIdx;
int nocase, match, length2, cflags, s1len, s2len;
const char *s1, *s2;
case INST_LIST:
/*
* Pop the opnd (objc) top stack elements into a new list obj and then
* decrement their ref counts.
*/
|
| ︙ | ︙ | |||
4609 4610 4611 4612 4613 4614 4615 |
/* Decode end-offset index values. */
index = TclIndexDecode(opnd, objc - 1);
pcAdjustment = 5;
lindexFastPath:
| | | 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 |
/* Decode end-offset index values. */
index = TclIndexDecode(opnd, objc - 1);
pcAdjustment = 5;
lindexFastPath:
if (index >= 0 && index < objc) {
objResultPtr = objv[index];
} else {
TclNewObj(objResultPtr);
}
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_F(pcAdjustment, 1, 1);
|
| ︙ | ︙ | |||
4772 4773 4774 4775 4776 4777 4778 |
if (toIdx == TCL_INDEX_NONE) {
emptyList:
objResultPtr = Tcl_NewObj();
TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
NEXT_INST_F(9, 1, 1);
}
toIdx = TclIndexDecode(toIdx, objc - 1);
| | | | | 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 |
if (toIdx == TCL_INDEX_NONE) {
emptyList:
objResultPtr = Tcl_NewObj();
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) {
toIdx = objc - 1;
}
assert ( toIdx >= 0 && toIdx < objc);
/*
assert ( fromIdx != TCL_INDEX_NONE );
*
* Extra safety for legacy bytecodes:
*/
if (fromIdx == TCL_INDEX_NONE) {
fromIdx = TCL_INDEX_START;
|
| ︙ | ︙ | |||
4934 4935 4936 4937 4938 4939 4940 |
TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr),
(match < 0 ? -1 : match > 0 ? 1 : 0)));
JUMP_PEEPHOLE_F(match, 1, 2);
case INST_STR_LEN:
valuePtr = OBJ_AT_TOS;
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 5274 5275 5276 5277 5278 5279 5280 5281 5282 5283 5284 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 5310 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 5364 5365 5366 5367 5368 5369 5370 5371 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 5449 5450 |
TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr),
(match < 0 ? -1 : match > 0 ? 1 : 0)));
JUMP_PEEPHOLE_F(match, 1, 2);
case INST_STR_LEN:
valuePtr = OBJ_AT_TOS;
length = Tcl_GetCharLength(valuePtr);
TclNewIntObj(objResultPtr, length);
TRACE(("\"%.20s\" => %d\n", O2S(valuePtr), length));
NEXT_INST_F(1, 1, 1);
case INST_STR_UPPER:
valuePtr = OBJ_AT_TOS;
TRACE(("\"%.20s\" => ", O2S(valuePtr)));
if (Tcl_IsShared(valuePtr)) {
s1 = TclGetStringFromObj(valuePtr, &length);
TclNewStringObj(objResultPtr, s1, length);
length = Tcl_UtfToUpper(TclGetString(objResultPtr));
Tcl_SetObjLength(objResultPtr, length);
TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
} else {
length = Tcl_UtfToUpper(TclGetString(valuePtr));
Tcl_SetObjLength(valuePtr, length);
TclFreeIntRep(valuePtr);
TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
case INST_STR_LOWER:
valuePtr = OBJ_AT_TOS;
TRACE(("\"%.20s\" => ", O2S(valuePtr)));
if (Tcl_IsShared(valuePtr)) {
s1 = TclGetStringFromObj(valuePtr, &length);
TclNewStringObj(objResultPtr, s1, length);
length = Tcl_UtfToLower(TclGetString(objResultPtr));
Tcl_SetObjLength(objResultPtr, length);
TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
} else {
length = Tcl_UtfToLower(TclGetString(valuePtr));
Tcl_SetObjLength(valuePtr, length);
TclFreeIntRep(valuePtr);
TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
case INST_STR_TITLE:
valuePtr = OBJ_AT_TOS;
TRACE(("\"%.20s\" => ", O2S(valuePtr)));
if (Tcl_IsShared(valuePtr)) {
s1 = TclGetStringFromObj(valuePtr, &length);
TclNewStringObj(objResultPtr, s1, length);
length = Tcl_UtfToTitle(TclGetString(objResultPtr));
Tcl_SetObjLength(objResultPtr, length);
TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
} else {
length = Tcl_UtfToTitle(TclGetString(valuePtr));
Tcl_SetObjLength(valuePtr, length);
TclFreeIntRep(valuePtr);
TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
case INST_STR_INDEX:
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
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) {
objResultPtr = Tcl_NewObj();
} 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;
if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length,
&fromIdx) != TCL_OK
|| TclGetIntForIndexM(interp, OBJ_AT_TOS, length,
&toIdx) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if (fromIdx < 0) {
fromIdx = 0;
}
if (toIdx >= length) {
toIdx = length;
}
if (toIdx >= fromIdx) {
objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx);
} else {
TclNewObj(objResultPtr);
}
TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_V(1, 3, 1);
case INST_STR_RANGE_IMM:
valuePtr = OBJ_AT_TOS;
fromIdx = TclGetInt4AtPtr(pc+1);
toIdx = TclGetInt4AtPtr(pc+5);
length = Tcl_GetCharLength(valuePtr);
TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx));
/* Every range of an empty value is an empty value */
if (length == 0) {
TRACE_APPEND(("\n"));
NEXT_INST_F(9, 0, 0);
}
/* Decode index operands. */
/*
assert ( toIdx != TCL_INDEX_NONE );
*
* Extra safety for legacy bytecodes:
*/
if (toIdx == TCL_INDEX_NONE) {
goto emptyRange;
}
toIdx = TclIndexDecode(toIdx, length - 1);
if (toIdx < 0) {
goto emptyRange;
} else if (toIdx >= length) {
toIdx = length - 1;
}
assert ( toIdx >= 0 && toIdx < length );
/*
assert ( fromIdx != TCL_INDEX_NONE );
*
* Extra safety for legacy bytecodes:
*/
if (fromIdx == TCL_INDEX_NONE) {
fromIdx = TCL_INDEX_START;
}
fromIdx = TclIndexDecode(fromIdx, length - 1);
if (fromIdx < 0) {
fromIdx = 0;
}
if (fromIdx <= toIdx) {
objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx);
} else {
emptyRange:
TclNewObj(objResultPtr);
}
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(9, 1, 1);
{
Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p;
int length3, endIdx;
Tcl_Obj *value3Ptr;
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) ||
(toIdx < fromIdx)) {
TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
TclDecrRefCount(value3Ptr);
NEXT_INST_F(1, 0, 0);
}
if (fromIdx < 0) {
fromIdx = 0;
}
if (toIdx > endIdx) {
toIdx = endIdx;
}
if (fromIdx == 0 && toIdx == endIdx) {
TclDecrRefCount(OBJ_AT_TOS);
OBJ_AT_TOS = value3Ptr;
TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr)));
NEXT_INST_F(1, 0, 0);
}
objResultPtr = TclStringReplace(interp, valuePtr, fromIdx,
|
| ︙ | ︙ | |||
5191 5192 5193 5194 5195 5196 5197 |
if (value3Ptr == value2Ptr) {
objResultPtr = valuePtr;
goto doneStringMap;
} else if (valuePtr == value2Ptr) {
objResultPtr = value3Ptr;
goto doneStringMap;
}
| | | | | | | | | | 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 5502 5503 |
if (value3Ptr == value2Ptr) {
objResultPtr = valuePtr;
goto doneStringMap;
} else if (valuePtr == value2Ptr) {
objResultPtr = value3Ptr;
goto doneStringMap;
}
ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
if (length == 0) {
objResultPtr = valuePtr;
goto doneStringMap;
}
ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
if (length2 > length || length2 == 0) {
objResultPtr = valuePtr;
goto doneStringMap;
} else if (length2 == length) {
if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length)) {
objResultPtr = valuePtr;
} else {
objResultPtr = value3Ptr;
}
goto doneStringMap;
}
ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3);
objResultPtr = Tcl_NewUnicodeObj(ustring1, 0);
p = ustring1;
end = ustring1 + length;
for (; ustring1 < end; ustring1++) {
if ((*ustring1 == *ustring2) && (length2==1 ||
memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2)
== 0)) {
if (p != ustring1) {
Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p);
p = ustring1 + length2;
|
| ︙ | ︙ | |||
5241 5242 5243 5244 5245 5246 5247 |
}
doneStringMap:
TRACE_WITH_OBJ(("%.20s %.20s %.20s => ",
O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr);
NEXT_INST_V(1, 3, 1);
case INST_STR_FIND:
| | | | < | | | < | | > | | > | | 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 5557 |
}
doneStringMap:
TRACE_WITH_OBJ(("%.20s %.20s %.20s => ",
O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr);
NEXT_INST_V(1, 3, 1);
case INST_STR_FIND:
objResultPtr = TclStringFirst(OBJ_UNDER_TOS, OBJ_AT_TOS, 0);
TRACE(("%.20s %.20s => %d\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 => %d\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
case INST_STR_CLASS:
opnd = TclGetInt1AtPtr(pc+1);
valuePtr = OBJ_AT_TOS;
TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name,
O2S(valuePtr)));
ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
match = 1;
if (length > 0) {
int ch;
end = ustring1 + length;
for (p=ustring1 ; p<end ; ) {
p += TclUniCharToUCS4(p, &ch);
if (!tclStringClassTable[opnd].comparator(ch)) {
match = 0;
break;
}
}
}
TRACE_APPEND(("%d\n", match));
JUMP_PEEPHOLE_F(match, 2, 1);
|
| ︙ | ︙ | |||
5290 5291 5292 5293 5294 5295 5296 |
* both.
*/
if (TclHasIntRep(valuePtr, &tclStringType)
|| TclHasIntRep(value2Ptr, &tclStringType)) {
Tcl_UniChar *ustring1, *ustring2;
| | | | < | | | | | | | | | | | 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 |
* both.
*/
if (TclHasIntRep(valuePtr, &tclStringType)
|| TclHasIntRep(value2Ptr, &tclStringType)) {
Tcl_UniChar *ustring1, *ustring2;
ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
match = TclUniCharMatch(ustring1, length, ustring2, length2,
nocase);
} else if (TclIsPureByteArray(valuePtr) && !nocase) {
unsigned char *bytes1, *bytes2;
bytes1 = Tcl_GetByteArrayFromObj(valuePtr, &length);
bytes2 = Tcl_GetByteArrayFromObj(value2Ptr, &length2);
match = TclByteArrayMatch(bytes1, length, bytes2, length2, 0);
} else {
match = Tcl_StringCaseMatch(TclGetString(valuePtr),
TclGetString(value2Ptr), nocase);
}
/*
* Reuse value2Ptr object already on stack if possible. Adjustment is
* 2 due to the nocase byte
*/
TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
/*
* Peep-hole optimisation: if you're about to jump, do jump from here.
*/
JUMP_PEEPHOLE_F(match, 2, 2);
{
const char *string1, *string2;
int trim1, trim2;
case INST_STR_TRIM_LEFT:
valuePtr = OBJ_UNDER_TOS; /* String */
value2Ptr = OBJ_AT_TOS; /* TrimSet */
string2 = TclGetStringFromObj(value2Ptr, &length2);
string1 = TclGetStringFromObj(valuePtr, &length);
trim1 = TclTrimLeft(string1, length, string2, length2);
trim2 = 0;
goto createTrimmedString;
case INST_STR_TRIM_RIGHT:
valuePtr = OBJ_UNDER_TOS; /* String */
value2Ptr = OBJ_AT_TOS; /* TrimSet */
string2 = TclGetStringFromObj(value2Ptr, &length2);
string1 = TclGetStringFromObj(valuePtr, &length);
trim2 = TclTrimRight(string1, length, string2, length2);
trim1 = 0;
goto createTrimmedString;
case INST_STR_TRIM:
valuePtr = OBJ_UNDER_TOS; /* String */
value2Ptr = OBJ_AT_TOS; /* TrimSet */
string2 = TclGetStringFromObj(value2Ptr, &length2);
string1 = TclGetStringFromObj(valuePtr, &length);
trim1 = TclTrim(string1, length, string2, length2, &trim2);
createTrimmedString:
/*
* Careful here; trim set often contains non-ASCII characters so we
* take care when printing. [Bug 971cb4f1db]
*/
#ifdef TCL_COMPILE_DEBUG
|
| ︙ | ︙ | |||
5367 5368 5369 5370 5371 5372 5373 |
if (traceInstructions) {
TclPrintObject(stdout, valuePtr, 30);
printf("\n");
}
#endif
NEXT_INST_F(1, 1, 0);
} else {
| | | 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 |
if (traceInstructions) {
TclPrintObject(stdout, valuePtr, 30);
printf("\n");
}
#endif
NEXT_INST_F(1, 1, 0);
} else {
objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1-trim2);
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
TclPrintObject(stdout, objResultPtr, 30);
printf("\n");
}
#endif
NEXT_INST_F(1, 2, 1);
|
| ︙ | ︙ | |||
5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 5614 5615 |
((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) &&
(wResult * w2 != w1)) {
wResult -= 1;
}
wResult = w1 - w2*wResult;
goto wideResultOfArithmetic;
}
case INST_RSHIFT:
if (w2 < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"negative shift argument", -1));
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
DECACHE_STACK_INFO();
| > | 5878 5879 5880 5881 5882 5883 5884 5885 5886 5887 5888 5889 5890 5891 5892 |
((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) &&
(wResult * w2 != w1)) {
wResult -= 1;
}
wResult = w1 - w2*wResult;
goto wideResultOfArithmetic;
}
break;
case INST_RSHIFT:
if (w2 < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"negative shift argument", -1));
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
DECACHE_STACK_INFO();
|
| ︙ | ︙ | |||
5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 |
/*
* Handle shifts within the native long range.
*/
wResult = w1 >> ((int) w2);
goto wideResultOfArithmetic;
}
case INST_LSHIFT:
if (w2 < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"negative shift argument", -1));
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
DECACHE_STACK_INFO();
| > | 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 |
/*
* Handle shifts within the native long range.
*/
wResult = w1 >> ((int) w2);
goto wideResultOfArithmetic;
}
break;
case INST_LSHIFT:
if (w2 < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"negative shift argument", -1));
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
DECACHE_STACK_INFO();
|
| ︙ | ︙ | |||
5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 |
objResultPtr = Tcl_NewWideIntObj(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);
case INST_DIV:
if (w2 == 0) {
TRACE(("%s %s => DIVIDE BY ZERO\n",
O2S(valuePtr), O2S(value2Ptr)));
goto divideByZero;
} else if ((w1 == WIDE_MIN) && (w2 == -1)) {
| > | 6117 6118 6119 6120 6121 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 |
objResultPtr = Tcl_NewWideIntObj(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;
case INST_DIV:
if (w2 == 0) {
TRACE(("%s %s => DIVIDE BY ZERO\n",
O2S(valuePtr), O2S(value2Ptr)));
goto divideByZero;
} else if ((w1 == WIDE_MIN) && (w2 == -1)) {
|
| ︙ | ︙ | |||
5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 |
goto divideByZero;
} else if (objResultPtr == EXPONENT_OF_ZERO) {
TRACE_APPEND(("EXPONENT OF ZERO\n"));
goto exponOfZero;
} else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) {
TRACE_ERROR(interp);
goto gotError;
} else if (objResultPtr == NULL) {
TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 1, 0);
} else {
TRACE_APPEND(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
}
| > > > | 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 |
goto divideByZero;
} else if (objResultPtr == EXPONENT_OF_ZERO) {
TRACE_APPEND(("EXPONENT OF ZERO\n"));
goto exponOfZero;
} else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) {
TRACE_ERROR(interp);
goto gotError;
} else if (objResultPtr == OUT_OF_MEMORY) {
TRACE_APPEND(("OUT OF MEMORY\n"));
goto outOfMemory;
} else if (objResultPtr == NULL) {
TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 1, 0);
} else {
TRACE_APPEND(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
}
|
| ︙ | ︙ | |||
5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 |
goto gotError;
}
switch (type1) {
case TCL_NUMBER_NAN:
/* -NaN => NaN */
TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
case TCL_NUMBER_INT:
w1 = *((const Tcl_WideInt *) ptr1);
if (w1 != WIDE_MIN) {
if (Tcl_IsShared(valuePtr)) {
TclNewIntObj(objResultPtr, -w1);
TRACE_APPEND(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
| > | 6260 6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 |
goto gotError;
}
switch (type1) {
case TCL_NUMBER_NAN:
/* -NaN => NaN */
TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
break;
case TCL_NUMBER_INT:
w1 = *((const Tcl_WideInt *) ptr1);
if (w1 != WIDE_MIN) {
if (Tcl_IsShared(valuePtr)) {
TclNewIntObj(objResultPtr, -w1);
TRACE_APPEND(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
|
| ︙ | ︙ | |||
6086 6087 6088 6089 6090 6091 6092 6093 6094 6095 6096 6097 6098 6099 6100 6101 6102 6103 6104 6105 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 |
TRACE_APPEND(("numeric, new Tcl_Obj\n"));
NEXT_INST_F(1, 1, 1);
}
TclInvalidateStringRep(valuePtr);
TRACE_APPEND(("numeric, same Tcl_Obj\n"));
NEXT_INST_F(1, 0, 0);
}
/*
* End of numeric operator instructions.
* -----------------------------------------------------------------
*/
case INST_TRY_CVT_TO_BOOLEAN:
valuePtr = OBJ_AT_TOS;
if (TclHasIntRep(valuePtr, &tclBooleanType)) {
objResultPtr = TCONST(1);
} else {
int result = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK);
objResultPtr = TCONST(result);
}
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr);
NEXT_INST_F(1, 0, 1);
case INST_BREAK:
/*
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
CACHE_STACK_INFO();
*/
| > > | 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 |
TRACE_APPEND(("numeric, new Tcl_Obj\n"));
NEXT_INST_F(1, 1, 1);
}
TclInvalidateStringRep(valuePtr);
TRACE_APPEND(("numeric, same Tcl_Obj\n"));
NEXT_INST_F(1, 0, 0);
}
break;
/*
* End of numeric operator instructions.
* -----------------------------------------------------------------
*/
case INST_TRY_CVT_TO_BOOLEAN:
valuePtr = OBJ_AT_TOS;
if (TclHasIntRep(valuePtr, &tclBooleanType)) {
objResultPtr = TCONST(1);
} else {
int result = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK);
objResultPtr = TCONST(result);
}
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr);
NEXT_INST_F(1, 0, 1);
break;
case INST_BREAK:
/*
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
CACHE_STACK_INFO();
*/
|
| ︙ | ︙ | |||
6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 6137 6138 6139 6140 6141 6142 6143 6144 6145 6146 6147 6148 |
CACHE_STACK_INFO();
*/
result = TCL_CONTINUE;
cleanup = 0;
TRACE(("=> CONTINUE!\n"));
goto processExceptionReturn;
{
ForeachInfo *infoPtr;
Tcl_Obj *listPtr, **elements, *tmpPtr;
ForeachVarList *varListPtr;
int numLists, listLen, numVars;
int listTmpDepth;
size_t iterNum, iterMax, iterTmp;
int varIndex, valIndex, j;
long i;
case INST_FOREACH_START:
/*
* Initialize the data for the looping construct, pushing the
* corresponding Tcl_Objs to the stack.
*/
opnd = TclGetUInt4AtPtr(pc+1);
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 6423 6424 6425 6426 6427 6428 6429 6430 6431 6432 6433 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 6458 6459 6460 6461 6462 6463 6464 6465 6466 6467 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 6483 6484 6485 6486 6487 6488 6489 6490 6491 6492 6493 6494 6495 6496 6497 6498 6499 6500 6501 6502 6503 6504 6505 6506 6507 6508 6509 6510 6511 6512 6513 6514 6515 6516 6517 6518 6519 6520 6521 6522 6523 6524 6525 6526 6527 6528 6529 6530 6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 6543 6544 6545 6546 6547 6548 6549 6550 6551 6552 6553 6554 6555 6556 6557 6558 6559 6560 6561 6562 6563 6564 6565 6566 6567 6568 6569 6570 6571 6572 6573 6574 6575 6576 6577 6578 6579 6580 6581 6582 6583 6584 6585 6586 6587 6588 6589 6590 6591 6592 6593 6594 6595 6596 6597 6598 6599 6600 6601 6602 6603 6604 6605 |
CACHE_STACK_INFO();
*/
result = TCL_CONTINUE;
cleanup = 0;
TRACE(("=> CONTINUE!\n"));
goto processExceptionReturn;
{
ForeachInfo *infoPtr;
Var *iterVarPtr, *listVarPtr;
Tcl_Obj *oldValuePtr, *listPtr, **elements;
ForeachVarList *varListPtr;
int numLists, listTmpIndex, listLen, numVars;
size_t iterNum;
int varIndex, valIndex, continueLoop, j, iterTmpIndex;
long i;
case INST_FOREACH_START4: /* DEPRECATED */
/*
* Initialize the temporary local var that holds the count of the
* number of iterations of the loop body to -1.
*/
opnd = TclGetUInt4AtPtr(pc+1);
infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData;
iterTmpIndex = infoPtr->loopCtTemp;
iterVarPtr = LOCAL(iterTmpIndex);
oldValuePtr = iterVarPtr->value.objPtr;
if (oldValuePtr == NULL) {
TclNewIntObj(iterVarPtr->value.objPtr, -1);
Tcl_IncrRefCount(iterVarPtr->value.objPtr);
} else {
TclSetIntObj(oldValuePtr, -1);
}
TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex));
#ifndef TCL_COMPILE_DEBUG
/*
* Remark that the compiler ALWAYS sets INST_FOREACH_STEP4 immediately
* after INST_FOREACH_START4 - let us just fall through instead of
* jumping back to the top.
*/
pc += 5;
TCL_DTRACE_INST_NEXT();
#else
NEXT_INST_F(5, 0, 0);
#endif
case INST_FOREACH_STEP4: /* DEPRECATED */
/*
* "Step" a foreach loop (i.e., begin its next iteration) by assigning
* the next value list element to each loop var.
*/
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData;
numLists = infoPtr->numLists;
/*
* Increment the temp holding the loop iteration number.
*/
iterVarPtr = LOCAL(infoPtr->loopCtTemp);
valuePtr = iterVarPtr->value.objPtr;
iterNum = (size_t)valuePtr->internalRep.wideValue + 1;
TclSetIntObj(valuePtr, iterNum);
/*
* Check whether all value lists are exhausted and we should stop the
* loop.
*/
continueLoop = 0;
listTmpIndex = infoPtr->firstValueTemp;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listVarPtr = LOCAL(listTmpIndex);
listPtr = listVarPtr->value.objPtr;
if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) {
TRACE_APPEND(("ERROR converting list %ld, \"%.30s\": %s\n",
i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
if ((size_t)listLen > iterNum * numVars) {
continueLoop = 1;
}
listTmpIndex++;
}
/*
* If some var in some var list still has a remaining list element
* iterate one more time. Assign to var the next element from its
* value list. We already checked above that each list temp holds a
* valid list object (by calling Tcl_ListObjLength), but cannot rely
* on that check remaining valid: one list could have been shimmered
* as a side effect of setting a traced variable.
*/
if (continueLoop) {
listTmpIndex = infoPtr->firstValueTemp;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listVarPtr = LOCAL(listTmpIndex);
listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr);
TclListObjGetElements(interp, listPtr, &listLen, &elements);
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
if (valIndex >= listLen) {
TclNewObj(valuePtr);
} else {
valuePtr = elements[valIndex];
}
varIndex = varListPtr->varIndexes[j];
varPtr = LOCAL(varIndex);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
if (TclIsVarDirectWritable(varPtr)) {
value2Ptr = varPtr->value.objPtr;
if (valuePtr != value2Ptr) {
if (value2Ptr != NULL) {
TclDecrRefCount(value2Ptr);
}
varPtr->value.objPtr = valuePtr;
Tcl_IncrRefCount(valuePtr);
}
} else {
DECACHE_STACK_INFO();
if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL,
valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){
CACHE_STACK_INFO();
TRACE_APPEND((
"ERROR init. index temp %d: %s\n",
varIndex, O2S(Tcl_GetObjResult(interp))));
TclDecrRefCount(listPtr);
goto gotError;
}
CACHE_STACK_INFO();
}
valIndex++;
}
TclDecrRefCount(listPtr);
listTmpIndex++;
}
}
TRACE_APPEND(("%d lists, iter %" TCL_Z_MODIFIER "u, %s loop\n",
numLists, iterNum, (continueLoop? "continue" : "exit")));
/*
* Run-time peep-hole optimisation: the compiler ALWAYS follows
* INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that
* instruction and jump direct from here.
*/
pc += 5;
if (*pc == INST_JUMP_FALSE1) {
NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0);
} else {
NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0);
}
}
{
ForeachInfo *infoPtr;
Tcl_Obj *listPtr, **elements, *tmpPtr;
ForeachVarList *varListPtr;
int numLists, listLen, numVars;
int listTmpDepth;
size_t iterNum, iterMax, iterTmp;
int varIndex, valIndex, j;
long i;
case INST_FOREACH_START:
/*
* Initialize the data for the looping construct, pushing the
* corresponding Tcl_Objs to the stack.
*/
opnd = TclGetUInt4AtPtr(pc+1);
infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData;
numLists = infoPtr->numLists;
TRACE(("%u => ", opnd));
/*
* Compute the number of iterations that will be run: iterMax
*/
|
| ︙ | ︙ | |||
6210 6211 6212 6213 6214 6215 6216 |
case INST_FOREACH_STEP:
/*
* "Step" a foreach loop (i.e., begin its next iteration) by assigning
* the next value list element to each loop var.
*/
tmpPtr = OBJ_AT_TOS;
| | | 6659 6660 6661 6662 6663 6664 6665 6666 6667 6668 6669 6670 6671 6672 6673 |
case INST_FOREACH_STEP:
/*
* "Step" a foreach loop (i.e., begin its next iteration) by assigning
* the next value list element to each loop var.
*/
tmpPtr = OBJ_AT_TOS;
infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1;
numLists = infoPtr->numLists;
TRACE(("=> "));
tmpPtr = OBJ_AT_DEPTH(1);
iterNum = (size_t)tmpPtr->internalRep.twoPtrValue.ptr1;
iterMax = (size_t)tmpPtr->internalRep.twoPtrValue.ptr2;
|
| ︙ | ︙ | |||
6294 6295 6296 6297 6298 6299 6300 |
*/
pc++;
#endif
case INST_FOREACH_END:
/* THIS INSTRUCTION IS ONLY CALLED AS A BREAK TARGET */
tmpPtr = OBJ_AT_TOS;
| | | > > > > > > | 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 6753 6754 6755 6756 6757 6758 6759 6760 6761 6762 6763 6764 6765 6766 6767 6768 6769 6770 6771 6772 6773 6774 6775 6776 6777 6778 6779 6780 6781 6782 6783 6784 6785 6786 6787 6788 6789 6790 6791 6792 6793 6794 6795 6796 6797 6798 6799 6800 6801 6802 6803 6804 6805 6806 6807 6808 6809 6810 6811 6812 6813 6814 6815 6816 6817 6818 6819 6820 6821 6822 6823 6824 6825 6826 6827 6828 6829 6830 6831 6832 6833 6834 |
*/
pc++;
#endif
case INST_FOREACH_END:
/* THIS INSTRUCTION IS ONLY CALLED AS A BREAK TARGET */
tmpPtr = OBJ_AT_TOS;
infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1;
numLists = infoPtr->numLists;
TRACE(("=> loop terminated\n"));
NEXT_INST_V(1, numLists+2, 0);
case INST_LMAP_COLLECT:
/*
* This instruction is only issued by lmap. The stack is:
* - result
* - infoPtr
* - loop counters
* - valLists
* - collecting obj (unshared)
* The instruction lappends the result to the collecting obj.
*/
tmpPtr = OBJ_AT_DEPTH(1);
infoPtr = (ForeachInfo *)tmpPtr->internalRep.twoPtrValue.ptr1;
numLists = infoPtr->numLists;
TRACE_APPEND(("=> appending to list at depth %d\n", 3 + numLists));
objPtr = OBJ_AT_DEPTH(3 + numLists);
Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS);
NEXT_INST_F(1, 1, 0);
}
break;
case INST_BEGIN_CATCH4:
/*
* Record start of the catch command with exception range index equal
* to the operand. Push the current stack depth onto the special catch
* stack.
*/
*(++catchTop) = CURR_DEPTH;
TRACE(("%u => catchTop=%d, stackTop=%d\n",
TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1),
(int) CURR_DEPTH));
NEXT_INST_F(5, 0, 0);
break;
case INST_END_CATCH:
catchTop--;
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
CACHE_STACK_INFO();
result = TCL_OK;
TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1)));
NEXT_INST_F(1, 0, 0);
break;
case INST_PUSH_RESULT:
objResultPtr = Tcl_GetObjResult(interp);
TRACE_WITH_OBJ(("=> "), objResultPtr);
/*
* See the comments at INST_INVOKE_STK
*/
TclNewObj(objPtr);
Tcl_IncrRefCount(objPtr);
iPtr->objResultPtr = objPtr;
NEXT_INST_F(1, 0, -1);
break;
case INST_PUSH_RETURN_CODE:
TclNewIntObj(objResultPtr, result);
TRACE(("=> %u\n", result));
NEXT_INST_F(1, 0, 1);
break;
case INST_PUSH_RETURN_OPTIONS:
DECACHE_STACK_INFO();
objResultPtr = Tcl_GetReturnOptions(interp, result);
CACHE_STACK_INFO();
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
break;
case INST_RETURN_CODE_BRANCH: {
int code;
if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &code) != TCL_OK) {
Tcl_Panic("INST_RETURN_CODE_BRANCH: TOS not a return code!");
}
|
| ︙ | ︙ | |||
6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 |
if (Tcl_DictObjSize(interp, dictPtr, &done) != TCL_OK) {
TRACE_APPEND(("ERROR verifying dictionary nature of \"%.30s\": %s\n",
O2S(dictPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
TRACE_APPEND(("OK\n"));
NEXT_INST_F(1, 1, 0);
case INST_DICT_EXISTS: {
int found;
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = OBJ_AT_DEPTH(opnd);
| > | 6860 6861 6862 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 6874 |
if (Tcl_DictObjSize(interp, dictPtr, &done) != TCL_OK) {
TRACE_APPEND(("ERROR verifying dictionary nature of \"%.30s\": %s\n",
O2S(dictPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
TRACE_APPEND(("OK\n"));
NEXT_INST_F(1, 1, 0);
break;
case INST_DICT_EXISTS: {
int found;
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = OBJ_AT_DEPTH(opnd);
|
| ︙ | ︙ | |||
6751 6752 6753 6754 6755 6756 6757 |
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(5, 2, 1);
case INST_DICT_FIRST:
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = POP_OBJECT();
| | | | 7207 7208 7209 7210 7211 7212 7213 7214 7215 7216 7217 7218 7219 7220 7221 7222 7223 7224 7225 7226 7227 7228 7229 7230 7231 7232 |
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(5, 2, 1);
case INST_DICT_FIRST:
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
dictPtr = POP_OBJECT();
searchPtr = (Tcl_DictSearch *)ckalloc(sizeof(Tcl_DictSearch));
if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr,
&valuePtr, &done) != TCL_OK) {
/*
* dictPtr is no longer on the stack, and we're not
* moving it into the intrep of an iterator. We need
* to drop the refcount [Tcl Bug 9b352768e6].
*/
Tcl_DecrRefCount(dictPtr);
ckfree(searchPtr);
TRACE_ERROR(interp);
goto gotError;
}
{
Tcl_ObjIntRep ir;
TclNewObj(statePtr);
ir.twoPtrValue.ptr1 = searchPtr;
|
| ︙ | ︙ | |||
6793 6794 6795 6796 6797 6798 6799 |
TRACE(("%u => ", opnd));
statePtr = (*LOCAL(opnd)).value.objPtr;
{
const Tcl_ObjIntRep *irPtr;
if (statePtr &&
(irPtr = TclFetchIntRep(statePtr, &dictIteratorType))) {
| | | 7249 7250 7251 7252 7253 7254 7255 7256 7257 7258 7259 7260 7261 7262 7263 |
TRACE(("%u => ", opnd));
statePtr = (*LOCAL(opnd)).value.objPtr;
{
const Tcl_ObjIntRep *irPtr;
if (statePtr &&
(irPtr = TclFetchIntRep(statePtr, &dictIteratorType))) {
searchPtr = (Tcl_DictSearch *)irPtr->twoPtrValue.ptr1;
Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done);
} else {
Tcl_Panic("mis-issued dictNext!");
}
}
pushDictIteratorResult:
if (done) {
|
| ︙ | ︙ | |||
6825 6826 6827 6828 6829 6830 6831 |
JUMP_PEEPHOLE_F(done, 5, 0);
case INST_DICT_UPDATE_START:
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
TRACE(("%u => ", opnd));
varPtr = LOCAL(opnd);
| | | 7281 7282 7283 7284 7285 7286 7287 7288 7289 7290 7291 7292 7293 7294 7295 |
JUMP_PEEPHOLE_F(done, 5, 0);
case INST_DICT_UPDATE_START:
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
TRACE(("%u => ", opnd));
varPtr = LOCAL(opnd);
duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[opnd2].clientData;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
if (TclIsVarDirectReadable(varPtr)) {
dictPtr = varPtr->value.objPtr;
} else {
DECACHE_STACK_INFO();
|
| ︙ | ︙ | |||
6847 6848 6849 6850 6851 6852 6853 |
}
Tcl_IncrRefCount(dictPtr);
if (TclListObjGetElements(interp, OBJ_AT_TOS, &length,
&keyPtrPtr) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
| | | 7303 7304 7305 7306 7307 7308 7309 7310 7311 7312 7313 7314 7315 7316 7317 |
}
Tcl_IncrRefCount(dictPtr);
if (TclListObjGetElements(interp, OBJ_AT_TOS, &length,
&keyPtrPtr) != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
if (length != duiPtr->length) {
Tcl_Panic("dictUpdateStart argument length mismatch");
}
for (i=0 ; i<length ; i++) {
if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i],
&valuePtr) != TCL_OK) {
TRACE_ERROR(interp);
Tcl_DecrRefCount(dictPtr);
|
| ︙ | ︙ | |||
6885 6886 6887 6888 6889 6890 6891 |
NEXT_INST_F(9, 0, 0);
case INST_DICT_UPDATE_END:
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
TRACE(("%u => ", opnd));
varPtr = LOCAL(opnd);
| | | 7341 7342 7343 7344 7345 7346 7347 7348 7349 7350 7351 7352 7353 7354 7355 |
NEXT_INST_F(9, 0, 0);
case INST_DICT_UPDATE_END:
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
TRACE(("%u => ", opnd));
varPtr = LOCAL(opnd);
duiPtr = (DictUpdateInfo *)codePtr->auxDataArrayPtr[opnd2].clientData;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
if (TclIsVarDirectReadable(varPtr)) {
dictPtr = varPtr->value.objPtr;
} else {
DECACHE_STACK_INFO();
|
| ︙ | ︙ | |||
7028 7029 7030 7031 7032 7033 7034 7035 7036 7037 7038 7039 7040 7041 |
if (result != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
TRACE_APPEND(("OK\n"));
NEXT_INST_F(5, 2, 0);
}
/*
* End of dictionary-related instructions.
* -----------------------------------------------------------------
*/
case INST_CLOCK_READ:
| > | 7484 7485 7486 7487 7488 7489 7490 7491 7492 7493 7494 7495 7496 7497 7498 |
if (result != TCL_OK) {
TRACE_ERROR(interp);
goto gotError;
}
TRACE_APPEND(("OK\n"));
NEXT_INST_F(5, 2, 0);
}
break;
/*
* End of dictionary-related instructions.
* -----------------------------------------------------------------
*/
case INST_CLOCK_READ:
|
| ︙ | ︙ | |||
7065 7066 7067 7068 7069 7070 7071 7072 7073 7074 7075 7076 7077 7078 |
default:
Tcl_Panic("clockRead instruction with unknown clock#");
}
objResultPtr = Tcl_NewWideIntObj(wval);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(2, 0, 1);
}
default:
Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc);
} /* end of switch on opCode */
/*
* Block for variables needed to process exception returns.
| > | 7522 7523 7524 7525 7526 7527 7528 7529 7530 7531 7532 7533 7534 7535 7536 |
default:
Tcl_Panic("clockRead instruction with unknown clock#");
}
objResultPtr = Tcl_NewWideIntObj(wval);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(2, 0, 1);
}
break;
default:
Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc);
} /* end of switch on opCode */
/*
* Block for variables needed to process exception returns.
|
| ︙ | ︙ | |||
7172 7173 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 |
divideByZero:
Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
CACHE_STACK_INFO();
goto gotError;
/*
* Exponentiation of zero by negative number in an expression. Control
* only reaches this point by "goto exponOfZero".
*/
exponOfZero:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
| > > > > > > > | 7630 7631 7632 7633 7634 7635 7636 7637 7638 7639 7640 7641 7642 7643 7644 7645 7646 7647 7648 7649 7650 |
divideByZero:
Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
CACHE_STACK_INFO();
goto gotError;
outOfMemory:
Tcl_SetObjResult(interp, Tcl_NewStringObj("out of memory", -1));
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "OUTOFMEMORY", "out of memory", NULL);
CACHE_STACK_INFO();
goto gotError;
/*
* Exponentiation of zero by negative number in an expression. Control
* only reaches this point by "goto exponOfZero".
*/
exponOfZero:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
|
| ︙ | ︙ | |||
7207 7208 7209 7210 7211 7212 7213 |
checkForCatch:
if (iPtr->execEnvPtr->rewind) {
goto abnormalReturn;
}
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
const unsigned char *pcBeg;
| < | | | 7672 7673 7674 7675 7676 7677 7678 7679 7680 7681 7682 7683 7684 7685 7686 7687 7688 7689 7690 |
checkForCatch:
if (iPtr->execEnvPtr->rewind) {
goto abnormalReturn;
}
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
const unsigned char *pcBeg;
bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg, NULL);
DECACHE_STACK_INFO();
TclLogCommandInfo(interp, codePtr->source, bytes,
bytes ? length : 0, pcBeg, tosPtr);
CACHE_STACK_INFO();
}
iPtr->flags &= ~ERR_ALREADY_LOGGED;
/*
* Clear all expansions that may have started after the last
* INST_BEGIN_CATCH.
|
| ︙ | ︙ | |||
7320 7321 7322 7323 7324 7325 7326 | NEXT_INST_F(0, 0, 0); /* Restart the execution loop at pc. */ /* * end of infinite loop dispatching on instructions. */ /* | | | 7784 7785 7786 7787 7788 7789 7790 7791 7792 7793 7794 7795 7796 7797 7798 |
NEXT_INST_F(0, 0, 0); /* Restart the execution loop at pc. */
/*
* end of infinite loop dispatching on instructions.
*/
/*
* Done or abnormal return code. Restore the stack to state it had when
* starting to execute the ByteCode. Panic if the stack is below the
* initial level.
*/
abnormalReturn:
TCL_DTRACE_INST_LAST();
|
| ︙ | ︙ | |||
7374 7375 7376 7377 7378 7379 7380 |
* case INST_START_CMD:
*/
instStartCmdFailed:
{
const char *bytes;
| < < | < < < < < < > > > > > > > > > > | | | 7838 7839 7840 7841 7842 7843 7844 7845 7846 7847 7848 7849 7850 7851 7852 7853 7854 7855 7856 7857 7858 7859 7860 7861 7862 7863 7864 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 |
* case INST_START_CMD:
*/
instStartCmdFailed:
{
const char *bytes;
length = 0;
if (TclInterpReady(interp) == TCL_ERROR) {
goto gotError;
}
/*
* We used to switch to direct eval; for NRE-awareness we now
* compile and eval the command so that this evaluation does not
* add a new TEBC instance. Bug [2910748], bug [fa6bf38d07]
*
* TODO: recompile, search this command and eval a code starting from,
* so that this evaluation does not add a new TEBC instance without
* NRE-trampoline.
*/
codePtr->flags |= TCL_BYTECODE_RECOMPILE;
bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL, NULL);
opnd = TclGetUInt4AtPtr(pc+1);
pc += (opnd-1);
assert(bytes);
PUSH_OBJECT(Tcl_NewStringObj(bytes, length));
goto instEvalStk;
}
}
#undef codePtr
#undef iPtr
#undef bcFramePtr
|
| ︙ | ︙ | |||
7416 7417 7418 7419 7420 7421 7422 |
static int
FinalizeOONext(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | | | | 7882 7883 7884 7885 7886 7887 7888 7889 7890 7891 7892 7893 7894 7895 7896 7897 7898 7899 7900 7901 7902 7903 7904 7905 7906 7907 7908 7909 7910 7911 7912 7913 7914 7915 7916 7917 7918 7919 7920 7921 7922 7923 7924 7925 7926 7927 7928 |
static int
FinalizeOONext(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
CallContext *contextPtr = (CallContext *)data[1];
/*
* Reset the variable lookup frame.
*/
iPtr->varFramePtr = (CallFrame *)data[0];
/*
* Restore the call chain context index as we've finished the inner invoke
* and want to operate in the outer context again.
*/
contextPtr->index = PTR2INT(data[2]);
contextPtr->skip = PTR2INT(data[3]);
contextPtr->oPtr->flags &= ~FILTER_HANDLING;
return result;
}
static int
FinalizeOONextFilter(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
CallContext *contextPtr = (CallContext *)data[1];
/*
* Reset the variable lookup frame.
*/
iPtr->varFramePtr = (CallFrame *)data[0];
/*
* Restore the call chain context index as we've finished the inner invoke
* and want to operate in the outer context again.
*/
contextPtr->index = PTR2INT(data[2]);
|
| ︙ | ︙ | |||
7610 7611 7612 7613 7614 7615 7616 7617 7618 7619 7620 7621 7622 7623 |
ClientData ptr1, ptr2;
double d1, d2, dResult;
Tcl_WideInt w1, w2, wResult;
mp_int big1, big2, bigResult, bigRemainder;
Tcl_Obj *objResultPtr;
int invalid, zero;
long shift;
(void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
(void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
switch (opcode) {
case INST_MOD:
/* TODO: Attempts to re-use unshared operands on stack */
| > | 8076 8077 8078 8079 8080 8081 8082 8083 8084 8085 8086 8087 8088 8089 8090 |
ClientData ptr1, ptr2;
double d1, d2, dResult;
Tcl_WideInt w1, w2, wResult;
mp_int big1, big2, bigResult, bigRemainder;
Tcl_Obj *objResultPtr;
int invalid, zero;
long shift;
mp_err err;
(void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
(void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
switch (opcode) {
case INST_MOD:
/* TODO: Attempts to re-use unshared operands on stack */
|
| ︙ | ︙ | |||
7666 7667 7668 7669 7670 7671 7672 | wRemainder = w1 - w2*wQuotient; WIDE_RESULT(wRemainder); } Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); /* TODO: internals intrusion */ | | | > | | > > > > | | | > | | | > | > | > > > | | 8133 8134 8135 8136 8137 8138 8139 8140 8141 8142 8143 8144 8145 8146 8147 8148 8149 8150 8151 8152 8153 8154 8155 8156 8157 8158 8159 8160 8161 8162 8163 8164 8165 8166 8167 8168 8169 8170 8171 8172 8173 8174 8175 8176 8177 8178 8179 8180 8181 8182 8183 8184 8185 8186 8187 8188 8189 8190 8191 8192 8193 8194 8195 8196 8197 8198 8199 8200 8201 8202 8203 8204 8205 8206 8207 |
wRemainder = w1 - w2*wQuotient;
WIDE_RESULT(wRemainder);
}
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
/* TODO: internals intrusion */
if ((w1 > ((Tcl_WideInt) 0)) ^ !mp_isneg(&big2)) {
/*
* Arguments are opposite sign; remainder is sum.
*/
err = mp_init_i64(&big1, w1);
if (err == MP_OKAY) {
err = mp_add(&big2, &big1, &big2);
mp_clear(&big1);
}
if (err != MP_OKAY) {
return OUT_OF_MEMORY;
}
BIG_RESULT(&big2);
}
/*
* Arguments are same sign; remainder is first operand.
*/
mp_clear(&big2);
return NULL;
}
Tcl_GetBignumFromObj(NULL, valuePtr, &big1);
Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
err = mp_init_multi(&bigResult, &bigRemainder, NULL);
if (err == MP_OKAY) {
err = mp_div(&big1, &big2, &bigResult, &bigRemainder);
}
if ((err == MP_OKAY) && !mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) {
/*
* Convert to Tcl's integer division rules.
*/
if ((mp_sub_d(&bigResult, 1, &bigResult) != MP_OKAY)
|| (mp_add(&bigRemainder, &big2, &bigRemainder) != MP_OKAY)) {
return OUT_OF_MEMORY;
}
}
err = mp_copy(&bigRemainder, &bigResult);
mp_clear(&bigRemainder);
mp_clear(&big1);
mp_clear(&big2);
if (err != MP_OKAY) {
return OUT_OF_MEMORY;
}
BIG_RESULT(&bigResult);
case INST_LSHIFT:
case INST_RSHIFT: {
/*
* Reject negative shift argument.
*/
switch (type2) {
case TCL_NUMBER_INT:
invalid = (*((const Tcl_WideInt *)ptr2) < 0);
break;
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
invalid = mp_isneg(&big2);
mp_clear(&big2);
break;
default:
/* Unused, here to silence compiler warning */
invalid = 0;
}
if (invalid) {
|
| ︙ | ︙ | |||
7794 7795 7796 7797 7798 7799 7800 |
switch (type1) {
case TCL_NUMBER_INT:
zero = (*(const Tcl_WideInt *)ptr1 > 0);
break;
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
| | | 8272 8273 8274 8275 8276 8277 8278 8279 8280 8281 8282 8283 8284 8285 8286 |
switch (type1) {
case TCL_NUMBER_INT:
zero = (*(const Tcl_WideInt *)ptr1 > 0);
break;
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
zero = !mp_isneg(&big1);
mp_clear(&big1);
break;
default:
/* Unused, here to silence compiler warning. */
zero = 0;
}
if (zero) {
|
| ︙ | ︙ | |||
7826 7827 7828 7829 7830 7831 7832 | } WIDE_RESULT(w1 >> shift); } } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); | | > | | | | > > > > | > | | | | | | | | | | > > > > | 8304 8305 8306 8307 8308 8309 8310 8311 8312 8313 8314 8315 8316 8317 8318 8319 8320 8321 8322 8323 8324 8325 8326 8327 8328 8329 8330 8331 8332 8333 8334 8335 8336 8337 8338 8339 8340 8341 8342 8343 8344 8345 8346 8347 8348 8349 8350 8351 8352 8353 8354 8355 8356 8357 8358 |
}
WIDE_RESULT(w1 >> shift);
}
}
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
err = mp_init(&bigResult);
if (err == MP_OKAY) {
if (opcode == INST_LSHIFT) {
err = mp_mul_2d(&big1, shift, &bigResult);
} else {
err = mp_signed_rsh(&big1, shift, &bigResult);
}
}
if (err != MP_OKAY) {
return OUT_OF_MEMORY;
}
mp_clear(&big1);
BIG_RESULT(&bigResult);
}
case INST_BITOR:
case INST_BITXOR:
case INST_BITAND:
if ((type1 != TCL_NUMBER_INT) || (type2 != TCL_NUMBER_INT)) {
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
err = mp_init(&bigResult);
if (err == MP_OKAY) {
switch (opcode) {
case INST_BITAND:
err = mp_and(&big1, &big2, &bigResult);
break;
case INST_BITOR:
err = mp_or(&big1, &big2, &bigResult);
break;
case INST_BITXOR:
err = mp_xor(&big1, &big2, &bigResult);
break;
}
}
if (err != MP_OKAY) {
return OUT_OF_MEMORY;
}
mp_clear(&big1);
mp_clear(&big2);
BIG_RESULT(&bigResult);
}
|
| ︙ | ︙ | |||
7918 7919 7920 7921 7922 7923 7924 |
return NULL;
}
negativeExponent = (w2 < 0);
oddExponent = (int) (w2 & (Tcl_WideInt)1);
} else {
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
| | | | | 8406 8407 8408 8409 8410 8411 8412 8413 8414 8415 8416 8417 8418 8419 8420 8421 8422 |
return NULL;
}
negativeExponent = (w2 < 0);
oddExponent = (int) (w2 & (Tcl_WideInt)1);
} else {
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
negativeExponent = mp_isneg(&big2);
err = mp_mod_2d(&big2, 1, &big2);
oddExponent = (err == MP_OKAY) && !mp_iszero(&big2);
mp_clear(&big2);
}
if (type1 == TCL_NUMBER_INT) {
w1 = *((const Tcl_WideInt *)ptr1);
if (negativeExponent) {
|
| ︙ | ︙ | |||
7984 7985 7986 7987 7988 7989 7990 | return constants[1]; } WIDE_RESULT(-1); } /* * We refuse to accept exponent arguments that exceed one mp_digit | | | 8472 8473 8474 8475 8476 8477 8478 8479 8480 8481 8482 8483 8484 8485 8486 |
return constants[1];
}
WIDE_RESULT(-1);
}
/*
* We refuse to accept exponent arguments that exceed one mp_digit
* which means the max exponent value is 2**28-1 = 0x0FFFFFFF =
* 268435455, which fits into a signed 32 bit int which is within the
* range of the long int type. This means any numeric Tcl_Obj value
* not using TCL_NUMBER_INT type must hold a value larger than we
* accept.
*/
if (type2 != TCL_NUMBER_INT) {
|
| ︙ | ︙ | |||
8077 8078 8079 8080 8081 8082 8083 |
|| (value2Ptr->typePtr != &tclIntType)
|| (Tcl_WideUInt)w2 >= (1<<28)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"exponent too large", -1));
return GENERAL_ARITHMETIC_ERROR;
}
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
| | > | > > > > | 8565 8566 8567 8568 8569 8570 8571 8572 8573 8574 8575 8576 8577 8578 8579 8580 8581 8582 8583 8584 8585 |
|| (value2Ptr->typePtr != &tclIntType)
|| (Tcl_WideUInt)w2 >= (1<<28)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"exponent too large", -1));
return GENERAL_ARITHMETIC_ERROR;
}
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
err = mp_init(&bigResult);
if (err == MP_OKAY) {
err = mp_expt_u32(&big1, (unsigned int)w2, &bigResult);
}
if (err != MP_OKAY) {
return OUT_OF_MEMORY;
}
mp_clear(&big1);
BIG_RESULT(&bigResult);
}
case INST_ADD:
case INST_SUB:
case INST_MULT:
|
| ︙ | ︙ | |||
8225 8226 8227 8228 8229 8230 8231 |
WIDE_RESULT(wResult);
}
overflowBasic:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
| | > | | | | | | | | | | | | | > | > | | | | | | | > | | > | | > > | > | > > > > | > > > | > > > | 8718 8719 8720 8721 8722 8723 8724 8725 8726 8727 8728 8729 8730 8731 8732 8733 8734 8735 8736 8737 8738 8739 8740 8741 8742 8743 8744 8745 8746 8747 8748 8749 8750 8751 8752 8753 8754 8755 8756 8757 8758 8759 8760 8761 8762 8763 8764 8765 8766 8767 8768 8769 8770 8771 8772 8773 8774 8775 8776 8777 8778 8779 8780 8781 8782 8783 8784 8785 8786 8787 8788 8789 8790 8791 8792 8793 8794 8795 8796 8797 8798 8799 8800 8801 8802 8803 8804 8805 8806 8807 8808 8809 8810 8811 8812 8813 8814 8815 8816 8817 8818 8819 8820 8821 8822 8823 8824 8825 8826 8827 8828 8829 8830 |
WIDE_RESULT(wResult);
}
overflowBasic:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
err = mp_init(&bigResult);
if (err == MP_OKAY) {
switch (opcode) {
case INST_ADD:
err = mp_add(&big1, &big2, &bigResult);
break;
case INST_SUB:
err = mp_sub(&big1, &big2, &bigResult);
break;
case INST_MULT:
err = mp_mul(&big1, &big2, &bigResult);
break;
case INST_DIV:
if (mp_iszero(&big2)) {
mp_clear(&big1);
mp_clear(&big2);
mp_clear(&bigResult);
return DIVIDED_BY_ZERO;
}
err = mp_init(&bigRemainder);
if (err == MP_OKAY) {
err = mp_div(&big1, &big2, &bigResult, &bigRemainder);
}
/* TODO: internals intrusion */
if (!mp_iszero(&bigRemainder)
&& (bigRemainder.sign != big2.sign)) {
/*
* Convert to Tcl's integer division rules.
*/
err = mp_sub_d(&bigResult, 1, &bigResult);
if (err == MP_OKAY) {
err = mp_add(&bigRemainder, &big2, &bigRemainder);
}
}
mp_clear(&bigRemainder);
break;
}
}
mp_clear(&big1);
mp_clear(&big2);
BIG_RESULT(&bigResult);
}
Tcl_Panic("unexpected opcode");
return NULL;
}
static Tcl_Obj *
ExecuteExtendedUnaryMathOp(
int opcode, /* What operation to perform. */
Tcl_Obj *valuePtr) /* The operand on the stack. */
{
ClientData ptr;
int type;
Tcl_WideInt w;
mp_int big;
Tcl_Obj *objResultPtr;
mp_err err = MP_OKAY;
(void) GetNumberFromObj(NULL, valuePtr, &ptr, &type);
switch (opcode) {
case INST_BITNOT:
if (type == TCL_NUMBER_INT) {
w = *((const Tcl_WideInt *) ptr);
WIDE_RESULT(~w);
}
Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
/* ~a = - a - 1 */
err = mp_neg(&big, &big);
if (err == MP_OKAY) {
err = mp_sub_d(&big, 1, &big);
}
if (err != MP_OKAY) {
return OUT_OF_MEMORY;
}
BIG_RESULT(&big);
case INST_UMINUS:
switch (type) {
case TCL_NUMBER_DOUBLE:
DOUBLE_RESULT(-(*((const double *) ptr)));
case TCL_NUMBER_INT:
w = *((const Tcl_WideInt *) ptr);
if (w != WIDE_MIN) {
WIDE_RESULT(-w);
}
err = mp_init_i64(&big, w);
if (err != MP_OKAY) {
return OUT_OF_MEMORY;
}
break;
default:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
}
err = mp_neg(&big, &big);
if (err != MP_OKAY) {
return OUT_OF_MEMORY;
}
BIG_RESULT(&big);
}
Tcl_Panic("unexpected opcode");
return NULL;
}
#undef WIDE_RESULT
|
| ︙ | ︙ | |||
8393 8394 8395 8396 8397 8398 8399 |
if (d2 > (double)WIDE_MAX) {
return MP_LT;
}
w2 = (Tcl_WideInt) d2;
goto wideCompare;
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
| | > | 8904 8905 8906 8907 8908 8909 8910 8911 8912 8913 8914 8915 8916 8917 8918 8919 8920 8921 8922 8923 8924 8925 8926 |
if (d2 > (double)WIDE_MAX) {
return MP_LT;
}
w2 = (Tcl_WideInt) d2;
goto wideCompare;
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
if (mp_isneg(&big2)) {
compare = MP_GT;
} else {
compare = MP_LT;
}
mp_clear(&big2);
return compare;
}
break;
case TCL_NUMBER_DOUBLE:
d1 = *((const double *)ptr1);
switch (type2) {
case TCL_NUMBER_DOUBLE:
d2 = *((const double *)ptr2);
doubleCompare:
|
| ︙ | ︙ | |||
8430 8431 8432 8433 8434 8435 8436 |
goto wideCompare;
case TCL_NUMBER_BIG:
if (TclIsInfinite(d1)) {
return (d1 > 0.0) ? MP_GT : MP_LT;
}
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
if ((d1 < (double)WIDE_MAX) && (d1 > (double)WIDE_MIN)) {
| | > | 8942 8943 8944 8945 8946 8947 8948 8949 8950 8951 8952 8953 8954 8955 8956 8957 8958 8959 8960 8961 8962 8963 8964 8965 8966 8967 8968 8969 8970 8971 8972 8973 |
goto wideCompare;
case TCL_NUMBER_BIG:
if (TclIsInfinite(d1)) {
return (d1 > 0.0) ? MP_GT : MP_LT;
}
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
if ((d1 < (double)WIDE_MAX) && (d1 > (double)WIDE_MIN)) {
if (mp_isneg(&big2)) {
compare = MP_GT;
} else {
compare = MP_LT;
}
mp_clear(&big2);
return compare;
}
if (DBL_MANT_DIG > CHAR_BIT*sizeof(long)
&& modf(d1, &tmp) != 0.0) {
d2 = TclBignumToDouble(&big2);
mp_clear(&big2);
goto doubleCompare;
}
Tcl_InitBignumFromDouble(NULL, d1, &big1);
goto bigCompare;
}
break;
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
switch (type2) {
case TCL_NUMBER_INT:
compare = mp_cmp_d(&big1, 0);
mp_clear(&big1);
|
| ︙ | ︙ | |||
8483 8484 8485 8486 8487 8488 8489 8490 8491 |
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
bigCompare:
compare = mp_cmp(&big1, &big2);
mp_clear(&big1);
mp_clear(&big2);
return compare;
}
default:
Tcl_Panic("unexpected number type");
| > < > | 8996 8997 8998 8999 9000 9001 9002 9003 9004 9005 9006 9007 9008 9009 9010 9011 9012 9013 9014 |
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
bigCompare:
compare = mp_cmp(&big1, &big2);
mp_clear(&big1);
mp_clear(&big2);
return compare;
}
break;
default:
Tcl_Panic("unexpected number type");
}
return TCL_ERROR;
}
#ifdef TCL_COMPILE_DEBUG
/*
*----------------------------------------------------------------------
*
* PrintByteCodeInfo --
|
| ︙ | ︙ | |||
8516 8517 8518 8519 8520 8521 8522 |
PrintByteCodeInfo(
ByteCode *codePtr) /* The bytecode whose summary is printed to
* stdout. */
{
Proc *procPtr = codePtr->procPtr;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
| | | > | 9030 9031 9032 9033 9034 9035 9036 9037 9038 9039 9040 9041 9042 9043 9044 9045 9046 9047 |
PrintByteCodeInfo(
ByteCode *codePtr) /* The bytecode whose summary is printed to
* stdout. */
{
Proc *procPtr = codePtr->procPtr;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_Z_MODIFIER "u, epoch %u, interp 0x%p (epoch %u)\n",
codePtr, (size_t)codePtr->refCount, codePtr->compileEpoch, iPtr,
iPtr->compileEpoch);
fprintf(stdout, " Source: ");
TclPrintSource(stdout, codePtr->source, 60);
fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
codePtr->numCommands, codePtr->numSrcBytes,
codePtr->numCodeBytes, codePtr->numLitObjects,
codePtr->numAuxDataItems, codePtr->maxStackDepth,
|
| ︙ | ︙ | |||
8544 8545 8546 8547 8548 8549 8550 |
(unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
(unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)),
(unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)),
codePtr->numCmdLocBytes);
#endif /* TCL_COMPILE_STATS */
if (procPtr != NULL) {
fprintf(stdout,
| | | 9059 9060 9061 9062 9063 9064 9065 9066 9067 9068 9069 9070 9071 9072 9073 |
(unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
(unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)),
(unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)),
codePtr->numCmdLocBytes);
#endif /* TCL_COMPILE_STATS */
if (procPtr != NULL) {
fprintf(stdout,
" Proc 0x%p, refCt %d, args %d, compiled locals %d\n",
procPtr, procPtr->refCount, procPtr->numArgs,
procPtr->numCompiledLocals);
}
}
#endif /* TCL_COMPILE_DEBUG */
/*
|
| ︙ | ︙ | |||
8596 8597 8598 8599 8600 8601 8602 |
unsigned char opCode = *pc;
if (((size_t) pc < codeStart) || ((size_t) pc > codeEnd)) {
fprintf(stderr, "\nBad instruction pc 0x%p in TclNRExecuteByteCode\n",
pc);
Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc");
}
| | | | 9111 9112 9113 9114 9115 9116 9117 9118 9119 9120 9121 9122 9123 9124 9125 9126 9127 9128 9129 9130 9131 9132 |
unsigned char opCode = *pc;
if (((size_t) pc < codeStart) || ((size_t) pc > codeEnd)) {
fprintf(stderr, "\nBad instruction pc 0x%p in TclNRExecuteByteCode\n",
pc);
Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc");
}
if ((unsigned) opCode > LAST_INST_OPCODE) {
fprintf(stderr, "\nBad opcode %d at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode\n",
(unsigned) opCode, relativePc);
Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode");
}
if (checkStack &&
((stackTop < 0) || (stackTop > stackUpperBound))) {
int numChars;
const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL);
fprintf(stderr, "\nBad stack top %d at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode (min 0, max %i)",
stackTop, relativePc, stackUpperBound);
if (cmd != NULL) {
Tcl_Obj *message;
|
| ︙ | ︙ | |||
8654 8655 8656 8657 8658 8659 8660 |
* when the illegal type was found. */
Tcl_Obj *opndPtr) /* Points to the operand holding the value
* with the illegal type. */
{
ClientData ptr;
int type;
const unsigned char opcode = *pc;
| | | | > > > > > > > > | > | < | 9169 9170 9171 9172 9173 9174 9175 9176 9177 9178 9179 9180 9181 9182 9183 9184 9185 9186 9187 9188 9189 9190 9191 9192 9193 9194 9195 9196 9197 9198 9199 9200 9201 9202 9203 9204 9205 9206 9207 9208 9209 9210 9211 9212 |
* when the illegal type was found. */
Tcl_Obj *opndPtr) /* Points to the operand holding the value
* with the illegal type. */
{
ClientData ptr;
int type;
const unsigned char opcode = *pc;
const char *description, *op = "unknown";
if (opcode == INST_EXPON) {
op = "**";
} else if (opcode <= INST_LNOT) {
op = operatorStrings[opcode - INST_LOR];
}
if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) {
int numBytes;
const char *bytes = TclGetStringFromObj(opndPtr, &numBytes);
if (numBytes == 0) {
description = "empty string";
} else if (TclCheckBadOctal(NULL, bytes)) {
description = "invalid octal number";
} else {
description = "non-numeric string";
}
} else if (type == TCL_NUMBER_NAN) {
description = "non-numeric floating-point value";
} else if (type == TCL_NUMBER_DOUBLE) {
description = "floating-point value";
} else {
/* TODO: No caller needs this. Eliminate? */
description = "(big) integer";
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't use %s as operand of \"%s\"", description, op));
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL);
}
/*
*----------------------------------------------------------------------
*
* TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSourceFromFrame --
|
| ︙ | ︙ | |||
8752 8753 8754 8755 8756 8757 8758 | /* * We now have the command. We can get the srcOffset back and from * there find the list of word locations for this command. */ ExtCmdLoc *eclPtr; ECL *locPtr = NULL; | | < | | 9275 9276 9277 9278 9279 9280 9281 9282 9283 9284 9285 9286 9287 9288 9289 9290 9291 9292 9293 9294 9295 9296 9297 9298 9299 |
/*
* We now have the command. We can get the srcOffset back and from
* there find the list of word locations for this command.
*/
ExtCmdLoc *eclPtr;
ECL *locPtr = NULL;
int srcOffset, i;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
Tcl_HashEntry *hePtr =
Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
if (!hePtr) {
return;
}
srcOffset = cfPtr->cmd - codePtr->source;
eclPtr = (ExtCmdLoc *)Tcl_GetHashValue(hePtr);
for (i=0; i < eclPtr->nuloc; i++) {
if (eclPtr->loc[i].srcOffset == srcOffset) {
locPtr = eclPtr->loc+i;
break;
}
}
|
| ︙ | ︙ | |||
8799 8800 8801 8802 8803 8804 8805 |
GetSrcInfoForPc(
const unsigned char *pc, /* The program counter value for which to
* return the closest command's source info.
* This points within a bytecode instruction
* in codePtr's code. */
ByteCode *codePtr, /* The bytecode sequence in which to look up
* the command source for the pc. */
| | | | | | | 9321 9322 9323 9324 9325 9326 9327 9328 9329 9330 9331 9332 9333 9334 9335 9336 9337 9338 9339 9340 9341 9342 9343 9344 9345 9346 9347 9348 9349 9350 9351 9352 9353 9354 9355 9356 |
GetSrcInfoForPc(
const unsigned char *pc, /* The program counter value for which to
* return the closest command's source info.
* This points within a bytecode instruction
* in codePtr's code. */
ByteCode *codePtr, /* The bytecode sequence in which to look up
* the command source for the pc. */
int *lengthPtr, /* If non-NULL, the location where the length
* of the command's source should be stored.
* If NULL, no length is stored. */
const unsigned char **pcBeg,/* If non-NULL, the bytecode location
* where the current instruction starts.
* If NULL; no pointer is stored. */
int *cmdIdxPtr) /* If non-NULL, the location where the index
* of the command containing the pc should
* be stored. */
{
int pcOffset = (pc - codePtr->codeStart);
int numCmds = codePtr->numCommands;
unsigned char *codeDeltaNext, *codeLengthNext;
unsigned char *srcDeltaNext, *srcLengthNext;
int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */
int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */
int bestSrcLength = -1; /* Initialized to avoid compiler warning. */
int bestCmdIdx = -1;
/* The pc must point within the bytecode */
assert ((pcOffset >= 0) && (pcOffset < codePtr->numCodeBytes));
/*
* Decode the code and source offset and length for each command. The
* closest enclosing command is the last one whose code started before
* pcOffset.
*/
|
| ︙ | ︙ | |||
8963 8964 8965 8966 8967 8968 8969 |
* point or a catch range. */
ByteCode *codePtr) /* Points to the ByteCode in which to search
* for the enclosing ExceptionRange. */
{
ExceptionRange *rangeArrayPtr;
int numRanges = codePtr->numExceptRanges;
ExceptionRange *rangePtr;
| | | | 9485 9486 9487 9488 9489 9490 9491 9492 9493 9494 9495 9496 9497 9498 9499 9500 |
* point or a catch range. */
ByteCode *codePtr) /* Points to the ByteCode in which to search
* for the enclosing ExceptionRange. */
{
ExceptionRange *rangeArrayPtr;
int numRanges = codePtr->numExceptRanges;
ExceptionRange *rangePtr;
int pcOffset = pc - codePtr->codeStart;
int start;
if (numRanges == 0) {
return NULL;
}
/*
* This exploits peculiarities of our compiler: nested ranges are always
|
| ︙ | ︙ | |||
9142 9143 9144 9145 9146 9147 9148 |
ByteCodeStats *statsPtr = &iPtr->stats;
double totalCodeBytes, currentCodeBytes;
double totalLiteralBytes, currentLiteralBytes;
double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;
double strBytesSharedMultX, strBytesSharedOnce;
double numInstructions, currentHeaderBytes;
size_t numCurrentByteCodes, numByteCodeLits;
| | > | 9664 9665 9666 9667 9668 9669 9670 9671 9672 9673 9674 9675 9676 9677 9678 9679 9680 |
ByteCodeStats *statsPtr = &iPtr->stats;
double totalCodeBytes, currentCodeBytes;
double totalLiteralBytes, currentLiteralBytes;
double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;
double strBytesSharedMultX, strBytesSharedOnce;
double numInstructions, currentHeaderBytes;
size_t numCurrentByteCodes, numByteCodeLits;
size_t refCountSum, literalMgmtBytes, sum;
size_t numSharedMultX, numSharedOnce, minSizeDecade, maxSizeDecade, i;
int decadeHigh, length;
char *litTableStats;
LiteralEntry *entryPtr;
Tcl_Obj *objPtr;
#define Percent(a,b) ((a) * 100.0 / (b))
objPtr = Tcl_NewObj();
|
| ︙ | ︙ | |||
9185 9186 9187 9188 9189 9190 9191 |
/*
* Summary statistics, total and current source and ByteCode sizes.
*/
Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
Tcl_AppendPrintfToObj(objPtr,
| | | | 9708 9709 9710 9711 9712 9713 9714 9715 9716 9717 9718 9719 9720 9721 9722 9723 |
/*
* Summary statistics, total and current source and ByteCode sizes.
*/
Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
Tcl_AppendPrintfToObj(objPtr,
"Compilation and execution statistics for interpreter %#" TCL_Z_MODIFIER "x\n",
(size_t)iPtr);
Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%" TCL_Z_MODIFIER "u\n",
statsPtr->numExecutions);
Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%" TCL_Z_MODIFIER "u\n",
statsPtr->numCompilations);
Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile\t%.1f\n",
statsPtr->numExecutions / (float)statsPtr->numCompilations);
|
| ︙ | ︙ | |||
9233 9234 9235 9236 9237 9238 9239 |
statsPtr->currentSrcBytes);
Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n",
currentCodeBytes);
Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n",
statsPtr->currentByteCodeBytes);
Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n",
currentLiteralBytes);
| | | | | | | 9756 9757 9758 9759 9760 9761 9762 9763 9764 9765 9766 9767 9768 9769 9770 9771 9772 9773 9774 |
statsPtr->currentSrcBytes);
Tcl_AppendPrintfToObj(objPtr, " Code bytes\t\t\t%.6g\n",
currentCodeBytes);
Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes\t\t%.6g\n",
statsPtr->currentByteCodeBytes);
Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n",
currentLiteralBytes);
Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
(unsigned long) sizeof(LiteralTable),
(unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)),
(unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)),
(unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)),
statsPtr->currentLitStringBytes);
Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n",
currentCodeBytes / statsPtr->currentSrcBytes);
Tcl_AppendPrintfToObj(objPtr, " Code + source bytes\t\t%.6g (%0.1f mean code/src)\n",
(currentCodeBytes + statsPtr->currentSrcBytes),
(currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);
|
| ︙ | ︙ | |||
9308 9309 9310 9311 9312 9313 9314 |
Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%" TCL_Z_MODIFIER "u\n",
tclObjsAlloced);
Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%" TCL_Z_MODIFIER "u\n",
(tclObjsAlloced - tclObjsFreed));
Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%" TCL_Z_MODIFIER "u\n",
statsPtr->numLiteralsCreated);
| | | 9831 9832 9833 9834 9835 9836 9837 9838 9839 9840 9841 9842 9843 9844 9845 |
Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%" TCL_Z_MODIFIER "u\n",
tclObjsAlloced);
Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%" TCL_Z_MODIFIER "u\n",
(tclObjsAlloced - tclObjsFreed));
Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%" TCL_Z_MODIFIER "u\n",
statsPtr->numLiteralsCreated);
Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%d (%0.1f%% of current objects)\n",
globalTablePtr->numEntries,
Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed));
Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of current literals)\n",
numByteCodeLits,
Percent(numByteCodeLits, globalTablePtr->numEntries));
Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%" TCL_Z_MODIFIER "u\n",
numSharedMultX);
|
| ︙ | ︙ | |||
9400 9401 9402 9403 9404 9405 9406 |
break;
}
}
sum = 0;
for (i = 0; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->literalCount[i];
| | | | 9923 9924 9925 9926 9927 9928 9929 9930 9931 9932 9933 9934 9935 9936 9937 9938 9939 9940 9941 9942 9943 9944 |
break;
}
}
sum = 0;
for (i = 0; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->literalCount[i];
Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n",
decadeHigh, Percent(sum, statsPtr->numLiteralsCreated));
}
litTableStats = TclLiteralStats(globalTablePtr);
Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n",
litTableStats);
ckfree(litTableStats);
/*
* Source and ByteCode size distributions.
*/
Tcl_AppendPrintfToObj(objPtr, "\nSource sizes:\n");
Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n");
|
| ︙ | ︙ | |||
9432 9433 9434 9435 9436 9437 9438 |
break;
}
}
sum = 0;
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->srcCount[i];
| | | 9955 9956 9957 9958 9959 9960 9961 9962 9963 9964 9965 9966 9967 9968 9969 |
break;
}
}
sum = 0;
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->srcCount[i];
Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n",
decadeHigh, Percent(sum, statsPtr->numCompilations));
}
Tcl_AppendPrintfToObj(objPtr, "\nByteCode sizes:\n");
Tcl_AppendPrintfToObj(objPtr, "\t Up to size\t\tPercentage\n");
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
|
| ︙ | ︙ | |||
9455 9456 9457 9458 9459 9460 9461 |
break;
}
}
sum = 0;
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->byteCodeCount[i];
| | | 9978 9979 9980 9981 9982 9983 9984 9985 9986 9987 9988 9989 9990 9991 9992 |
break;
}
}
sum = 0;
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->byteCodeCount[i];
Tcl_AppendPrintfToObj(objPtr, "\t%10d\t\t%8.0f%%\n",
decadeHigh, Percent(sum, statsPtr->numCompilations));
}
Tcl_AppendPrintfToObj(objPtr, "\nByteCode longevity (excludes Current ByteCodes):\n");
Tcl_AppendPrintfToObj(objPtr, "\t Up to ms\t\tPercentage\n");
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
|
| ︙ | ︙ | |||
9487 9488 9489 9490 9491 9492 9493 |
}
/*
* Instruction counts.
*/
Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n");
| | | | 10010 10011 10012 10013 10014 10015 10016 10017 10018 10019 10020 10021 10022 10023 10024 10025 10026 10027 10028 10029 10030 10031 10032 10033 10034 10035 10036 10037 |
}
/*
* Instruction counts.
*/
Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n");
for (i = 0; i <= LAST_INST_OPCODE; i++) {
Tcl_AppendPrintfToObj(objPtr, "%20s %8" TCL_Z_MODIFIER "u ",
tclInstructionTable[i].name, statsPtr->instructionCount[i]);
if (statsPtr->instructionCount[i]) {
Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n",
Percent(statsPtr->instructionCount[i], numInstructions));
} else {
Tcl_AppendPrintfToObj(objPtr, "0\n");
}
}
#ifdef TCL_MEM_DEBUG
Tcl_AppendPrintfToObj(objPtr, "\nHeap Statistics:\n");
TclDumpMemoryInfo((ClientData) objPtr, 1);
#endif
Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
if (objc == 1) {
Tcl_SetObjResult(interp, objPtr);
} else {
Tcl_Channel outChan;
|
| ︙ | ︙ |
Changes to generic/tclFCmd.c.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | * See the user documentation. * *--------------------------------------------------------------------------- */ int TclFileRenameCmd( | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
* See the user documentation.
*
*---------------------------------------------------------------------------
*/
int
TclFileRenameCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interp for error reporting or recursive
* calls in the case of a tricky rename. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
{
return FileCopyRename(interp, objc, objv, 0);
}
|
| ︙ | ︙ | |||
72 73 74 75 76 77 78 | * See the user documentation. * *--------------------------------------------------------------------------- */ int TclFileCopyCmd( | | | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 |
* See the user documentation.
*
*---------------------------------------------------------------------------
*/
int
TclFileCopyCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Used for error reporting or recursive calls
* in the case of a tricky copy. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
{
return FileCopyRename(interp, objc, objv, 1);
}
|
| ︙ | ︙ | |||
210 211 212 213 214 215 216 | * See the user documentation. * *---------------------------------------------------------------------- */ int TclFileMakeDirsCmd( | | | 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
TclFileMakeDirsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Used for error reporting. */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
{
Tcl_Obj *errfile = NULL;
int result, i, j, pobjc;
Tcl_Obj *split = NULL;
|
| ︙ | ︙ | |||
334 335 336 337 338 339 340 | * See the user documentation. * *---------------------------------------------------------------------- */ int TclFileDeleteCmd( | | | 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
TclFileDeleteCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Used for error reporting */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
{
int i, force, result;
Tcl_Obj *errfile;
Tcl_Obj *errorBuffer = NULL;
|
| ︙ | ︙ | |||
942 943 944 945 946 947 948 | * May set file attributes for the file name. * *---------------------------------------------------------------------- */ int TclFileAttrsCmd( | | | 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 |
* May set file attributes for the file name.
*
*----------------------------------------------------------------------
*/
int
TclFileAttrsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* The interpreter for error reporting. */
int objc, /* Number of command line arguments. */
Tcl_Obj *const objv[]) /* The command line objects. */
{
int result;
const char *const *attributeStrings;
const char **attributeStringsAllocated = NULL;
|
| ︙ | ︙ | |||
1158 1159 1160 1161 1162 1163 1164 | * May create a new link. * *---------------------------------------------------------------------- */ int TclFileLinkCmd( | | | 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 |
* May create a new link.
*
*----------------------------------------------------------------------
*/
int
TclFileLinkCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *contents;
int index;
|
| ︙ | ︙ | |||
1309 1310 1311 1312 1313 1314 1315 | * None. * *---------------------------------------------------------------------- */ int TclFileReadLinkCmd( | | | 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 |
* None.
*
*----------------------------------------------------------------------
*/
int
TclFileReadLinkCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *contents;
if (objc != 2) {
|
| ︙ | ︙ | |||
1360 1361 1362 1363 1364 1365 1366 | * to a variable, so reentrancy is a potential issue. * *--------------------------------------------------------------------------- */ int TclFileTemporaryCmd( | | | 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 |
* to a variable, so reentrancy is a potential issue.
*
*---------------------------------------------------------------------------
*/
int
TclFileTemporaryCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *nameVarObj = NULL; /* Variable to store the name of the temporary
* file in. */
Tcl_Obj *nameObj = NULL; /* Object that will contain the filename. */
|
| ︙ | ︙ | |||
1385 1386 1387 1388 1389 1390 1391 |
}
if (objc > 1) {
nameVarObj = objv[1];
TclNewObj(nameObj);
}
if (objc > 2) {
| | | 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 |
}
if (objc > 1) {
nameVarObj = objv[1];
TclNewObj(nameObj);
}
if (objc > 2) {
int length;
Tcl_Obj *templateObj = objv[2];
const char *string = TclGetStringFromObj(templateObj, &length);
/*
* Treat an empty string as if it wasn't there.
*/
|
| ︙ | ︙ | |||
1519 1520 1521 1522 1523 1524 1525 | * Creates a temporary directory. * *--------------------------------------------------------------------------- */ int TclFileTempDirCmd( | | | 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 |
* Creates a temporary directory.
*
*---------------------------------------------------------------------------
*/
int
TclFileTempDirCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *dirNameObj; /* Object that will contain the directory
* name. */
Tcl_Obj *baseDirObj = NULL, *nameBaseObj = NULL;
|
| ︙ | ︙ |
Changes to generic/tclFileName.c.
| ︙ | ︙ | |||
382 383 384 385 386 387 388 |
TclpGetNativePathType(
Tcl_Obj *pathPtr, /* Native path of interest */
int *driveNameLengthPtr, /* Returns length of drive, if non-NULL and
* path was absolute */
Tcl_Obj **driveNameRef)
{
Tcl_PathType type = TCL_PATH_ABSOLUTE;
| > | | 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 |
TclpGetNativePathType(
Tcl_Obj *pathPtr, /* Native path of interest */
int *driveNameLengthPtr, /* Returns length of drive, if non-NULL and
* path was absolute */
Tcl_Obj **driveNameRef)
{
Tcl_PathType type = TCL_PATH_ABSOLUTE;
int pathLen;
const char *path = TclGetStringFromObj(pathPtr, &pathLen);
if (path[0] == '~') {
/*
* This case is common to all platforms. Paths that begin with ~ are
* absolute.
*/
|
| ︙ | ︙ | |||
499 500 501 502 503 504 505 |
/*
* Perform platform specific splitting.
*/
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
| | | | 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 |
/*
* Perform platform specific splitting.
*/
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
resultPtr = SplitUnixPath(Tcl_GetString(pathPtr));
break;
case TCL_PLATFORM_WINDOWS:
resultPtr = SplitWinPath(Tcl_GetString(pathPtr));
break;
}
/*
* Compute the number of elements in the result.
*/
|
| ︙ | ︙ | |||
532 533 534 535 536 537 538 | * Results: * Returns a standard Tcl result. The interpreter result contains a list * of path components. *argvPtr will be filled in with the address of an * array whose elements point to the elements of path, in order. * *argcPtr will get filled in with the number of valid elements in the * array. A single block of memory is dynamically allocated to hold both * the argv array and a copy of the path elements. The caller must | | < | | | | 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 |
* Results:
* Returns a standard Tcl result. The interpreter result contains a list
* of path components. *argvPtr will be filled in with the address of an
* array whose elements point to the elements of path, in order.
* *argcPtr will get filled in with the number of valid elements in the
* array. A single block of memory is dynamically allocated to hold both
* the argv array and a copy of the path elements. The caller must
* eventually free this memory by calling ckfree() on *argvPtr. Note:
* *argvPtr and *argcPtr are only modified if the procedure returns
* normally.
*
* Side effects:
* Allocates memory.
*
*----------------------------------------------------------------------
*/
void
Tcl_SplitPath(
const char *path, /* Pointer to string containing a path. */
int *argcPtr, /* Pointer to location to fill in with the
* number of elements in the path. */
const char ***argvPtr) /* Pointer to place to store pointer to array
* of pointers to path elements. */
{
Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */
Tcl_Obj *tmpPtr, *eltPtr;
int i, size, len;
char *p;
const char *str;
/*
* Perform the splitting, using objectified, vfs-aware code.
*/
tmpPtr = Tcl_NewStringObj(path, -1);
Tcl_IncrRefCount(tmpPtr);
resultPtr = Tcl_FSSplitPath(tmpPtr, argcPtr);
Tcl_IncrRefCount(resultPtr);
Tcl_DecrRefCount(tmpPtr);
/*
* Calculate space required for the result.
*/
size = 1;
for (i = 0; i < *argcPtr; i++) {
Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
TclGetStringFromObj(eltPtr, &len);
size += len + 1;
}
/*
* Allocate a buffer large enough to hold the contents of all of the list
* plus the argv pointers and the terminating NULL pointer.
*/
*argvPtr = (const char **)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];
|
| ︙ | ︙ | |||
638 639 640 641 642 643 644 |
*----------------------------------------------------------------------
*/
static Tcl_Obj *
SplitUnixPath(
const char *path) /* Pointer to string containing a path. */
{
| | | 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 |
*----------------------------------------------------------------------
*/
static Tcl_Obj *
SplitUnixPath(
const char *path) /* Pointer to string containing a path. */
{
int length;
const char *origPath = path, *elementStart;
Tcl_Obj *result = Tcl_NewObj();
/*
* Deal with the root directory as a special case.
*/
|
| ︙ | ︙ | |||
727 728 729 730 731 732 733 |
*----------------------------------------------------------------------
*/
static Tcl_Obj *
SplitWinPath(
const char *path) /* Pointer to string containing a path. */
{
| | | 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 |
*----------------------------------------------------------------------
*/
static Tcl_Obj *
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_NewObj();
Tcl_DStringInit(&buf);
p = ExtractWinRoot(path, &buf, 0, &type);
|
| ︙ | ︙ | |||
817 818 819 820 821 822 823 |
Tcl_Obj *pair[2];
pair[0] = pathPtr;
pair[1] = objv[0];
return TclJoinPath(2, pair, 0);
} else {
int elemc = objc + 1;
| | | | 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 |
Tcl_Obj *pair[2];
pair[0] = pathPtr;
pair[1] = objv[0];
return TclJoinPath(2, pair, 0);
} else {
int elemc = objc + 1;
Tcl_Obj *ret, **elemv = (Tcl_Obj**)ckalloc(elemc*sizeof(Tcl_Obj *));
elemv[0] = pathPtr;
memcpy(elemv+1, objv, objc*sizeof(Tcl_Obj *));
ret = TclJoinPath(elemc, elemv, 0);
ckfree(elemv);
return ret;
}
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
848 849 850 851 852 853 854 |
*/
void
TclpNativeJoinPath(
Tcl_Obj *prefix,
const char *joining)
{
| < | | 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 |
*/
void
TclpNativeJoinPath(
Tcl_Obj *prefix,
const char *joining)
{
int length, needsSep;
char *dest;
const char *p;
const char *start;
start = TclGetStringFromObj(prefix, &length);
/*
|
| ︙ | ︙ | |||
882 883 884 885 886 887 888 |
case TCL_PLATFORM_UNIX:
/*
* Append a separator if needed.
*/
if (length > 0 && (start[length-1] != '/')) {
Tcl_AppendToObj(prefix, "/", 1);
| | | | | | | | 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 |
case TCL_PLATFORM_UNIX:
/*
* Append a separator if needed.
*/
if (length > 0 && (start[length-1] != '/')) {
Tcl_AppendToObj(prefix, "/", 1);
TclGetStringFromObj(prefix, &length);
}
needsSep = 0;
/*
* Append the element, eliminating duplicate and trailing slashes.
*/
Tcl_SetObjLength(prefix, length + (int) strlen(p));
dest = Tcl_GetString(prefix) + length;
for (; *p != '\0'; p++) {
if (*p == '/') {
while (p[1] == '/') {
p++;
}
if (p[1] != '\0' && needsSep) {
*dest++ = '/';
}
} else {
*dest++ = *p;
needsSep = 1;
}
}
length = dest - Tcl_GetString(prefix);
Tcl_SetObjLength(prefix, length);
break;
case TCL_PLATFORM_WINDOWS:
/*
* Check to see if we need to append a separator.
*/
if ((length > 0) &&
(start[length-1] != '/') && (start[length-1] != ':')) {
Tcl_AppendToObj(prefix, "/", 1);
TclGetStringFromObj(prefix, &length);
}
needsSep = 0;
/*
* Append the element, eliminating duplicate and trailing slashes.
*/
Tcl_SetObjLength(prefix, length + (int) strlen(p));
dest = Tcl_GetString(prefix) + length;
for (; *p != '\0'; p++) {
if ((*p == '/') || (*p == '\\')) {
while ((p[1] == '/') || (p[1] == '\\')) {
p++;
}
if ((p[1] != '\0') && needsSep) {
*dest++ = '/';
}
} else {
*dest++ = *p;
needsSep = 1;
}
}
length = dest - Tcl_GetString(prefix);
Tcl_SetObjLength(prefix, length);
break;
}
return;
}
/*
|
| ︙ | ︙ | |||
973 974 975 976 977 978 979 |
char *
Tcl_JoinPath(
int argc,
const char *const *argv,
Tcl_DString *resultPtr) /* Pointer to previously initialized DString */
{
| | < | 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 |
char *
Tcl_JoinPath(
int argc,
const char *const *argv,
Tcl_DString *resultPtr) /* Pointer to previously initialized DString */
{
int i, len;
Tcl_Obj *listObj = Tcl_NewObj();
Tcl_Obj *resultObj;
const char *resultStr;
/*
* Build the list of paths.
*/
|
| ︙ | ︙ | |||
1070 1071 1072 1073 1074 1075 1076 |
/*
* Convert forward slashes to backslashes in Windows paths because some
* system interfaces don't accept forward slashes.
*/
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
| | | 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 |
/*
* Convert forward slashes to backslashes in Windows paths because some
* system interfaces don't accept forward slashes.
*/
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
char *p;
for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
if (*p == '/') {
*p = '\\';
}
}
}
|
| ︙ | ︙ | |||
1215 1216 1217 1218 1219 1220 1221 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GlobObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int index, i, globFlags, length, join, dir, result;
char *string;
const char *separators;
|
| ︙ | ︙ | |||
1247 1248 1249 1250 1251 1252 1253 |
globFlags = 0;
join = 0;
dir = PATH_NONE;
typePtr = NULL;
for (i = 1; i < objc; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&index) != TCL_OK) {
| | | 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 |
globFlags = 0;
join = 0;
dir = PATH_NONE;
typePtr = NULL;
for (i = 1; i < objc; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&index) != TCL_OK) {
string = TclGetStringFromObj(objv[i], &length);
if (string[0] == '-') {
/*
* It looks like the command contains an option so signal an
* error.
*/
return TCL_ERROR;
|
| ︙ | ︙ | |||
1342 1343 1344 1345 1346 1347 1348 |
"\"-tails\" must be used with either "
"\"-directory\" or \"-path\"", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
"BADOPTIONCOMBINATION", NULL);
return TCL_ERROR;
}
| | | | 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 |
"\"-tails\" must be used with either "
"\"-directory\" or \"-path\"", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
"BADOPTIONCOMBINATION", NULL);
return TCL_ERROR;
}
separators = NULL;
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
separators = "/";
break;
case TCL_PLATFORM_WINDOWS:
separators = "/\\:";
break;
}
if (dir == PATH_GENERAL) {
int pathlength;
const char *last;
const char *first = TclGetStringFromObj(pathOrDir,&pathlength);
/*
* Find the last path separator in the path
*/
|
| ︙ | ︙ | |||
1405 1406 1407 1408 1409 1410 1411 | /* * We must ensure that we haven't cut off too much, and turned * a valid path like '/' or 'C:/' into an incorrect path like * '' or 'C:'. The way we do this is to add a separator if * there are none presently in the prefix. */ | | | 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 |
/*
* We must ensure that we haven't cut off too much, and turned
* a valid path like '/' or 'C:/' into an incorrect path like
* '' or 'C:'. The way we do this is to add a separator if
* there are none presently in the prefix.
*/
if (strpbrk(Tcl_GetString(pathOrDir), "\\/") == NULL) {
Tcl_AppendToObj(pathOrDir, last-1, 1);
}
}
/*
* Need to quote 'prefix'.
*/
|
| ︙ | ︙ | |||
1447 1448 1449 1450 1451 1452 1453 |
* platform.
*/
Tcl_ListObjLength(interp, typePtr, &length);
if (length <= 0) {
goto skipTypes;
}
| | | | 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 |
* platform.
*/
Tcl_ListObjLength(interp, typePtr, &length);
if (length <= 0) {
goto skipTypes;
}
globTypes = (Tcl_GlobTypeData *)TclStackAlloc(interp, sizeof(Tcl_GlobTypeData));
globTypes->type = 0;
globTypes->perm = 0;
globTypes->macType = NULL;
globTypes->macCreator = NULL;
while (--length >= 0) {
int len;
const char *str;
Tcl_ListObjIndex(interp, typePtr, length, &look);
str = TclGetStringFromObj(look, &len);
if (strcmp("readonly", str) == 0) {
globTypes->perm |= TCL_GLOB_PERM_RONLY;
} else if (strcmp("hidden", str) == 0) {
|
| ︙ | ︙ | |||
1512 1513 1514 1515 1516 1517 1518 |
goto badMacTypesArg;
}
globTypes->macType = look;
Tcl_IncrRefCount(look);
} else {
Tcl_Obj *item;
| < | | | | | | | 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 |
goto badMacTypesArg;
}
globTypes->macType = look;
Tcl_IncrRefCount(look);
} else {
Tcl_Obj *item;
if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK)
&& (len == 3)) {
Tcl_ListObjIndex(interp, look, 0, &item);
if (!strcmp("macintosh", Tcl_GetString(item))) {
Tcl_ListObjIndex(interp, look, 1, &item);
if (!strcmp("type", Tcl_GetString(item))) {
Tcl_ListObjIndex(interp, look, 2, &item);
if (globTypes->macType != NULL) {
goto badMacTypesArg;
}
globTypes->macType = item;
Tcl_IncrRefCount(item);
continue;
} else if (!strcmp("creator", Tcl_GetString(item))) {
Tcl_ListObjIndex(interp, look, 2, &item);
if (globTypes->macCreator != NULL) {
goto badMacTypesArg;
}
globTypes->macCreator = item;
Tcl_IncrRefCount(item);
continue;
}
}
}
/*
* Error cases. We reset the 'join' flag to zero, since we
* haven't yet made use of it.
*/
badTypesArg:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad argument to \"-types\": %s",
Tcl_GetString(look)));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL);
result = TCL_ERROR;
join = 0;
goto endOfGlob;
badMacTypesArg:
Tcl_SetObjResult(interp, Tcl_NewStringObj(
|
| ︙ | ︙ | |||
1611 1612 1613 1614 1615 1616 1617 |
Tcl_DStringFree(&str);
goto endOfGlob;
}
}
Tcl_DStringFree(&str);
} else {
for (i = 0; i < objc; i++) {
| | | 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 |
Tcl_DStringFree(&str);
goto endOfGlob;
}
}
Tcl_DStringFree(&str);
} else {
for (i = 0; i < objc; i++) {
string = Tcl_GetString(objv[i]);
if (TclGlob(interp, string, pathOrDir, globFlags,
globTypes) != TCL_OK) {
result = TCL_ERROR;
goto endOfGlob;
}
}
}
|
| ︙ | ︙ | |||
1643 1644 1645 1646 1647 1648 1649 |
if (join) {
Tcl_AppendToObj(errorMsg, Tcl_DStringValue(&prefix), -1);
} else {
const char *sep = "";
for (i = 0; i < objc; i++) {
Tcl_AppendPrintfToObj(errorMsg, "%s%s",
| | | 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 |
if (join) {
Tcl_AppendToObj(errorMsg, Tcl_DStringValue(&prefix), -1);
} else {
const char *sep = "";
for (i = 0; i < objc; i++) {
Tcl_AppendPrintfToObj(errorMsg, "%s%s",
sep, Tcl_GetString(objv[i]));
sep = " ";
}
}
Tcl_AppendToObj(errorMsg, "\"", -1);
Tcl_SetObjResult(interp, errorMsg);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "NOMATCH",
NULL);
|
| ︙ | ︙ | |||
1679 1680 1681 1682 1683 1684 1685 | } /* *---------------------------------------------------------------------- * * TclGlob -- * | < | | | 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 | } /* *---------------------------------------------------------------------- * * TclGlob -- * * Sets the separator string based on the platform, performs tilde * substitution, and calls DoGlob. * * The interpreter's result, on entry to this function, must be a valid * Tcl list (e.g. it could be empty), since we will lappend any new * results to that list. If it is not a valid list, this function will * fail to do anything very meaningful. * * Note that if globFlags contains 'TCL_GLOBMODE_TAILS' then pathPrefix |
| ︙ | ︙ | |||
1704 1705 1706 1707 1708 1709 1710 | * * Side effects: * The 'pattern' is written to. * *---------------------------------------------------------------------- */ | < | | 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 |
*
* Side effects:
* The 'pattern' is written to.
*
*----------------------------------------------------------------------
*/
int
TclGlob(
Tcl_Interp *interp, /* Interpreter for returning error message or
* appending list of matching file names. */
char *pattern, /* Glob pattern to match. Must not refer to a
* static string. */
Tcl_Obj *pathPrefix, /* Path prefix to glob pattern, if non-null,
* which is considered literally. */
int globFlags, /* Stores or'ed combination of flags */
Tcl_GlobTypeData *types) /* Struct containing acceptable types. May be
* NULL. */
{
const char *separators;
const char *head;
char *tail, *start;
int result;
Tcl_Obj *filenamesObj, *savedResultObj;
separators = NULL;
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
separators = "/";
break;
case TCL_PLATFORM_WINDOWS:
separators = "/\\:";
break;
|
| ︙ | ︙ | |||
1846 1847 1848 1849 1850 1851 1852 |
Tcl_Obj *cwd = Tcl_FSGetCwd(interp);
if (cwd == NULL) {
Tcl_DecrRefCount(temp);
return TCL_ERROR;
}
| | | 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 |
Tcl_Obj *cwd = Tcl_FSGetCwd(interp);
if (cwd == NULL) {
Tcl_DecrRefCount(temp);
return TCL_ERROR;
}
pathPrefix = Tcl_NewStringObj(Tcl_GetString(cwd), 3);
Tcl_DecrRefCount(cwd);
if (tail[0] == '/') {
tail++;
} else {
tail += 2;
}
Tcl_IncrRefCount(pathPrefix);
|
| ︙ | ︙ | |||
1980 1981 1982 1983 1984 1985 1986 |
*
* We do it by rewriting the result list in-place.
*/
if (globFlags & TCL_GLOBMODE_TAILS) {
int objc, i;
Tcl_Obj **objv;
| | | 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 |
*
* We do it by rewriting the result list in-place.
*/
if (globFlags & TCL_GLOBMODE_TAILS) {
int objc, i;
Tcl_Obj **objv;
int prefixLen;
const char *pre;
/*
* If this length has never been set, set it here.
*/
if (pathPrefix == NULL) {
|
| ︙ | ︙ | |||
2008 2009 2010 2011 2012 2013 2014 |
|| (pre[1] != ':')) {
prefixLen++;
}
}
Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv);
for (i = 0; i< objc; i++) {
| | | 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 |
|| (pre[1] != ':')) {
prefixLen++;
}
}
Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv);
for (i = 0; i< objc; i++) {
int len;
const char *oldStr = TclGetStringFromObj(objv[i], &len);
Tcl_Obj *elem;
if (len == prefixLen) {
if ((pattern[0] == '\0')
|| (strchr(separators, pattern[0]) == NULL)) {
TclNewLiteralStringObj(elem, ".");
|
| ︙ | ︙ | |||
2057 2058 2059 2060 2061 2062 2063 | /* *---------------------------------------------------------------------- * * SkipToChar -- * * This function traverses a glob pattern looking for the next unquoted | | | | 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 |
/*
*----------------------------------------------------------------------
*
* SkipToChar --
*
* This function traverses a glob pattern looking for the next unquoted
* occurrence of the specified character at the same braces nesting level.
*
* Results:
* Updates stringPtr to point to the matching character, or to the end of
* the string if nothing matched. The return value is 1 if a match was
* found at the top level, otherwise it is 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
SkipToChar(
char **stringPtr, /* Pointer string to check. */
int match) /* Character to find. */
{
int quoted, level;
char *p;
quoted = 0;
level = 0;
for (p = *stringPtr; *p != '\0'; p++) {
if (quoted) {
quoted = 0;
|
| ︙ | ︙ | |||
2340 2341 2342 2343 2344 2345 2346 |
Tcl_Obj **subdirv;
result = Tcl_ListObjGetElements(interp, subdirsPtr,
&subdirc, &subdirv);
for (i=0; result==TCL_OK && i<subdirc; i++) {
Tcl_Obj *copy = NULL;
| | | | 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 |
Tcl_Obj **subdirv;
result = Tcl_ListObjGetElements(interp, subdirsPtr,
&subdirc, &subdirv);
for (i=0; result==TCL_OK && i<subdirc; i++) {
Tcl_Obj *copy = NULL;
if (pathPtr == NULL && Tcl_GetString(subdirv[i])[0] == '~') {
Tcl_ListObjLength(NULL, matchesObj, &repair);
copy = subdirv[i];
subdirv[i] = Tcl_NewStringObj("./", 2);
Tcl_AppendObjToObj(subdirv[i], copy);
Tcl_IncrRefCount(subdirv[i]);
}
result = DoGlob(interp, matchesObj, separators, subdirv[i],
1, p+1, types);
if (copy) {
int end;
Tcl_DecrRefCount(subdirv[i]);
subdirv[i] = copy;
Tcl_ListObjLength(NULL, matchesObj, &end);
while (repair < end) {
const char *bytes;
int numBytes;
Tcl_Obj *fixme, *newObj;
Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme);
bytes = TclGetStringFromObj(fixme, &numBytes);
newObj = Tcl_NewStringObj(bytes+2, numBytes-2);
Tcl_ListObjReplace(NULL, matchesObj, repair, 1,
1, &newObj);
|
| ︙ | ︙ | |||
2380 2381 2382 2383 2384 2385 2386 |
}
/*
* We reach here with no pattern char in current section
*/
if (*p == '\0') {
| | | 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 |
}
/*
* We reach here with no pattern char in current section
*/
if (*p == '\0') {
int length;
Tcl_DString append;
/*
* This is the code path reached by a command like 'glob foo'.
*
* There are no more wildcards in the pattern and no more unprocessed
* characters in the pattern, so now we can construct the path, and
|
| ︙ | ︙ | |||
2444 2445 2446 2447 2448 2449 2450 |
} else {
joinedPtr = Tcl_DuplicateObj(pathPtr);
if (strchr(separators, Tcl_DStringValue(&append)[0]) == NULL) {
/*
* The current prefix must end in a separator.
*/
| | | 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 |
} else {
joinedPtr = Tcl_DuplicateObj(pathPtr);
if (strchr(separators, Tcl_DStringValue(&append)[0]) == NULL) {
/*
* The current prefix must end in a separator.
*/
int len;
const char *joined = TclGetStringFromObj(joinedPtr,&len);
if (strchr(separators, joined[len-1]) == NULL) {
Tcl_AppendToObj(joinedPtr, "/", 1);
}
}
Tcl_AppendToObj(joinedPtr, Tcl_DStringValue(&append),
|
| ︙ | ︙ | |||
2481 2482 2483 2484 2485 2486 2487 | * The current prefix must end in a separator, unless this is a * volume-relative path. In particular globbing in Windows shares, * when not using -dir or -path, e.g. 'glob [file join * //machine/share/subdir *]' requires adding a separator here. * This behaviour is not currently tested for in the test suite. */ | | | 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 |
* The current prefix must end in a separator, unless this is a
* volume-relative path. In particular globbing in Windows shares,
* when not using -dir or -path, e.g. 'glob [file join
* //machine/share/subdir *]' requires adding a separator here.
* This behaviour is not currently tested for in the test suite.
*/
int len;
const char *joined = TclGetStringFromObj(joinedPtr,&len);
if (strchr(separators, joined[len-1]) == NULL) {
if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) {
Tcl_AppendToObj(joinedPtr, "/", 1);
}
}
|
| ︙ | ︙ | |||
2511 2512 2513 2514 2515 2516 2517 | * * This procedure allocates a Tcl_StatBuf on the heap. It exists so that * extensions may be used unchanged on systems where largefile support is * optional. * * Results: * A pointer to a Tcl_StatBuf which may be deallocated by being passed to | | | | 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 |
*
* This procedure allocates a Tcl_StatBuf on the heap. It exists so that
* extensions may be used unchanged on systems where largefile support is
* optional.
*
* Results:
* A pointer to a Tcl_StatBuf which may be deallocated by being passed to
* ckfree().
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
Tcl_StatBuf *
Tcl_AllocStatBuf(void)
{
return (Tcl_StatBuf *)ckalloc(sizeof(Tcl_StatBuf));
}
/*
*---------------------------------------------------------------------------
*
* Access functions for Tcl_StatBuf --
*
|
| ︙ | ︙ | |||
2627 2628 2629 2630 2631 2632 2633 |
Tcl_WideUInt
Tcl_GetBlocksFromStat(
const Tcl_StatBuf *statPtr)
{
#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
return (Tcl_WideUInt) statPtr->st_blocks;
#else
| | > < > > > > > < > | 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_WideUInt
Tcl_GetBlocksFromStat(
const Tcl_StatBuf *statPtr)
{
#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
return (Tcl_WideUInt) statPtr->st_blocks;
#else
unsigned blksize = Tcl_GetBlockSizeFromStat(statPtr);
return ((Tcl_WideUInt) statPtr->st_size + blksize - 1) / blksize;
#endif
}
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
unsigned
Tcl_GetBlockSizeFromStat(
const Tcl_StatBuf *statPtr)
{
return statPtr->st_blksize;
}
#else
unsigned
Tcl_GetBlockSizeFromStat(
TCL_UNUSED(const Tcl_StatBuf *))
{
/*
* Not a great guess, but will do...
*/
return GUESSED_BLOCK_SIZE;
}
#endif
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclFileSystem.h.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 | MODULE_SCOPE int TclFSNormalizeToUniquePath(Tcl_Interp *interp, Tcl_Obj *pathPtr, int startAt); MODULE_SCOPE Tcl_Obj * TclFSMakePathRelative(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_Obj *cwdPtr); MODULE_SCOPE int TclFSEnsureEpochOk(Tcl_Obj *pathPtr, const Tcl_Filesystem **fsPtrPtr); MODULE_SCOPE void TclFSSetPathDetails(Tcl_Obj *pathPtr, | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | MODULE_SCOPE int TclFSNormalizeToUniquePath(Tcl_Interp *interp, Tcl_Obj *pathPtr, int startAt); MODULE_SCOPE Tcl_Obj * TclFSMakePathRelative(Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_Obj *cwdPtr); MODULE_SCOPE int TclFSEnsureEpochOk(Tcl_Obj *pathPtr, const Tcl_Filesystem **fsPtrPtr); MODULE_SCOPE void TclFSSetPathDetails(Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr, ClientData clientData); MODULE_SCOPE Tcl_Obj * TclFSNormalizeAbsolutePath(Tcl_Interp *interp, Tcl_Obj *pathPtr); MODULE_SCOPE size_t TclFSEpoch(void); /* * Private shared variables for use by tclIOUtil.c and tclPathObj.c */ |
| ︙ | ︙ |
Changes to generic/tclGet.c.
| ︙ | ︙ | |||
138 139 140 141 142 143 144 |
obj.typePtr = NULL;
code = TclSetBooleanFromAny(interp, &obj);
if (obj.refCount > 1) {
Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
if (code == TCL_OK) {
| | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 |
obj.typePtr = NULL;
code = TclSetBooleanFromAny(interp, &obj);
if (obj.refCount > 1) {
Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
if (code == TCL_OK) {
TclGetBooleanFromObj(NULL, &obj, boolPtr);
}
return code;
}
/*
* Local Variables:
* mode: c
|
| ︙ | ︙ |
Changes to generic/tclGetDate.y.
| ︙ | ︙ | |||
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 |
* doesn't like that, and complains. Tell it to shut up.
*/
#ifdef _MSC_VER
#pragma warning( disable : 4102 )
#endif /* _MSC_VER */
/*
* yyparse will accept a 'struct DateInfo' as its parameter; that's where the
* parsed fields will be returned.
*/
typedef struct DateInfo {
Tcl_Obj* messages; /* Error messages */
const char* separatrix; /* String separating messages */
time_t dateYear;
time_t dateMonth;
time_t dateDay;
int dateHaveDate;
time_t dateHour;
time_t dateMinutes;
time_t dateSeconds;
| > > > > > > > > | | 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 |
* doesn't like that, and complains. Tell it to shut up.
*/
#ifdef _MSC_VER
#pragma warning( disable : 4102 )
#endif /* _MSC_VER */
/*
* Meridian: am, pm, or 24-hour style.
*/
typedef enum _MERIDIAN {
MERam, MERpm, MER24
} MERIDIAN;
/*
* yyparse will accept a 'struct DateInfo' as its parameter; that's where the
* parsed fields will be returned.
*/
typedef struct DateInfo {
Tcl_Obj* messages; /* Error messages */
const char* separatrix; /* String separating messages */
time_t dateYear;
time_t dateMonth;
time_t dateDay;
int dateHaveDate;
time_t dateHour;
time_t dateMinutes;
time_t dateSeconds;
MERIDIAN dateMeridian;
int dateHaveTime;
time_t dateTimezone;
int dateDSTmode;
int dateHaveZone;
time_t dateRelMonth;
|
| ︙ | ︙ | |||
85 86 87 88 89 90 91 |
const char *dateStart;
const char *dateInput;
time_t *dateRelPointer;
int dateDigitCount;
} DateInfo;
| | | | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 |
const char *dateStart;
const char *dateInput;
time_t *dateRelPointer;
int dateDigitCount;
} DateInfo;
#define YYMALLOC ckalloc
#define YYFREE(x) (ckfree((void*) (x)))
#define yyDSTmode (info->dateDSTmode)
#define yyDayOrdinal (info->dateDayOrdinal)
#define yyDayNumber (info->dateDayNumber)
#define yyMonthOrdinal (info->dateMonthOrdinal)
#define yyHaveDate (info->dateHaveDate)
#define yyHaveDay (info->dateHaveDay)
|
| ︙ | ︙ | |||
146 147 148 149 150 151 152 |
* Daylight-savings mode: on, off, or not yet known.
*/
typedef enum _DSTMODE {
DSTon, DSToff, DSTmaybe
} DSTMODE;
| < < < < < < < < | 154 155 156 157 158 159 160 161 162 163 164 165 166 167 |
* Daylight-savings mode: on, off, or not yet known.
*/
typedef enum _DSTMODE {
DSTon, DSToff, DSTmaybe
} DSTMODE;
%}
%union {
time_t Number;
enum _MERIDIAN Meridian;
}
|
| ︙ | ︙ | |||
761 762 763 764 765 766 767 |
}
static int
LookupWord(
YYSTYPE* yylvalPtr,
char *buff)
{
| | | | | 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 |
}
static int
LookupWord(
YYSTYPE* yylvalPtr,
char *buff)
{
char *p;
char *q;
const TABLE *tp;
int i, abbrev;
/*
* Make it lowercase.
*/
Tcl_UtfToLower(buff);
|
| ︙ | ︙ | |||
886 887 888 889 890 891 892 |
static int
TclDatelex(
YYSTYPE* yylvalPtr,
YYLTYPE* location,
DateInfo *info)
{
| | | | | 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 |
static int
TclDatelex(
YYSTYPE* yylvalPtr,
YYLTYPE* location,
DateInfo *info)
{
char c;
char *p;
char buff[20];
int Count;
location->first_column = yyInput - info->dateStart;
for ( ; ; ) {
while (TclIsSpaceProcM(*yyInput)) {
yyInput++;
}
if (isdigit(UCHAR(c = *yyInput))) { /* INTL: digit */
/*
* Convert the string into a number; count the number of digits.
*/
|
| ︙ | ︙ | |||
956 957 958 959 960 961 962 |
}
} while (Count > 0);
}
}
int
TclClockOldscanObjCmd(
| | | 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 |
}
} while (Count > 0);
}
}
int
TclClockOldscanObjCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Count of paraneters */
Tcl_Obj *const *objv) /* Parameters */
{
Tcl_Obj *result, *resultElement;
int yr, mo, da;
DateInfo dateInfo;
|
| ︙ | ︙ | |||
1060 1061 1062 1063 1064 1065 1066 |
return TCL_ERROR;
}
result = Tcl_NewObj();
resultElement = Tcl_NewObj();
if (yyHaveDate) {
Tcl_ListObjAppendElement(interp, resultElement,
| | | | | | | | | | | | | | | 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 |
return TCL_ERROR;
}
result = Tcl_NewObj();
resultElement = Tcl_NewObj();
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());
}
resultElement = Tcl_NewObj();
if (yyHaveZone) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) -yyTimezone));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj(1 - yyDSTmode));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
resultElement = Tcl_NewObj();
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);
resultElement = Tcl_NewObj();
if (yyHaveDay && !yyHaveDate) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyDayOrdinal));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyDayNumber));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
resultElement = Tcl_NewObj();
if (yyHaveOrdinalMonth) {
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyMonthOrdinal));
Tcl_ListObjAppendElement(interp, resultElement,
Tcl_NewIntObj((int) yyMonth));
}
Tcl_ListObjAppendElement(interp, result, resultElement);
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
|
| ︙ | ︙ |
Changes to generic/tclHash.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" /* * When there are this many entries per bucket, on average, rebuild the hash * table to make it larger. */ #define REBUILD_MULTIPLIER 3 /* * The following macro takes a preliminary integer hash value and produces an * index into a hash tables bucket list. The idea is to make it so that * preliminary values that are arbitrarily similar will end up in different * buckets. The hash function was taken from a random-number generator. */ #define RANDOM_INDEX(tablePtr, i) \ | > > > > > > > | | 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 |
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
/*
* Prevent macros from clashing with function definitions.
*/
#undef Tcl_FindHashEntry
#undef Tcl_CreateHashEntry
/*
* When there are this many entries per bucket, on average, rebuild the hash
* table to make it larger.
*/
#define REBUILD_MULTIPLIER 3
/*
* The following macro takes a preliminary integer hash value and produces an
* index into a hash tables bucket list. The idea is to make it so that
* preliminary values that are arbitrarily similar will end up in different
* buckets. The hash function was taken from a random-number generator.
*/
#define RANDOM_INDEX(tablePtr, i) \
((((i)*1103515245L) >> (tablePtr)->downShift) & (tablePtr)->mask)
/*
* Prototypes for the array hash key methods.
*/
static Tcl_HashEntry * AllocArrayEntry(Tcl_HashTable *tablePtr, void *keyPtr);
static int CompareArrayKeys(void *keyPtr, Tcl_HashEntry *hPtr);
|
| ︙ | ︙ | |||
102 103 104 105 106 107 108 | * Tcl_CreateHashEntry. * *---------------------------------------------------------------------- */ void Tcl_InitHashTable( | | | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 |
* Tcl_CreateHashEntry.
*
*----------------------------------------------------------------------
*/
void
Tcl_InitHashTable(
Tcl_HashTable *tablePtr,
/* Pointer to table record, which is supplied
* by the caller. */
int keyType) /* Type of keys to use in table:
* TCL_STRING_KEYS, TCL_ONE_WORD_KEYS, or an
* integer >= 2. */
{
/*
|
| ︙ | ︙ | |||
140 141 142 143 144 145 146 | * Tcl_CreateHashEntry. * *---------------------------------------------------------------------- */ void Tcl_InitCustomHashTable( | | | 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 |
* Tcl_CreateHashEntry.
*
*----------------------------------------------------------------------
*/
void
Tcl_InitCustomHashTable(
Tcl_HashTable *tablePtr,
/* Pointer to table record, which is supplied
* by the caller. */
int keyType, /* Type of keys to use in table:
* TCL_STRING_KEYS, TCL_ONE_WORD_KEYS,
* TCL_CUSTOM_TYPE_KEYS, TCL_CUSTOM_PTR_KEYS,
* or an integer >= 2. */
const Tcl_HashKeyType *typePtr) /* Pointer to structure which defines the
|
| ︙ | ︙ | |||
189 190 191 192 193 194 195 |
*/
}
}
/*
*----------------------------------------------------------------------
*
| | > > > > > > > > | > > > > > > > > > > > | > | | | | | 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 |
*/
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_FindHashEntry --
*
* Given a hash table find the entry with a matching key.
*
* Results:
* The return value is a token for the matching entry in the hash table,
* or NULL if there was no matching entry.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_HashEntry *
Tcl_FindHashEntry(
Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
const void *key) /* Key to use to find matching entry. */
{
return (*((tablePtr)->findProc))(tablePtr, (const char *)key);
}
static Tcl_HashEntry *
FindHashEntry(
Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
const char *key) /* Key to use to find matching entry. */
{
return CreateHashEntry(tablePtr, key, NULL);
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateHashEntry --
*
* Given a hash table with string keys, and a string key, find the entry
* with a matching key. If there is no matching entry, then create a new
* entry that does match.
*
* Results:
* The return value is a pointer to the matching entry. If this is a
* newly-created entry, then *newPtr will be set to a non-zero value;
* otherwise *newPtr will be set to 0. If this is a new entry the value
* stored in the entry will initially be 0.
*
* Side effects:
* A new entry may be added to the hash table.
*
*----------------------------------------------------------------------
*/
Tcl_HashEntry *
Tcl_CreateHashEntry(
Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
const void *key, /* Key to use to find or create matching
* entry. */
int *newPtr) /* Store info here telling whether a new entry
* was created. */
{
return (*((tablePtr)->createProc))(tablePtr, (const char *)key, newPtr);
}
static Tcl_HashEntry *
CreateHashEntry(
Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */
const char *key, /* Key to use to find or create matching
* entry. */
int *newPtr) /* Store info here telling whether a new entry
* was created. */
{
Tcl_HashEntry *hPtr;
const Tcl_HashKeyType *typePtr;
unsigned int hash;
int index;
if (tablePtr->keyType == TCL_STRING_KEYS) {
typePtr = &tclStringHashKeyType;
} else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
typePtr = &tclOneWordHashKeyType;
} else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
|| tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
typePtr = tablePtr->typePtr;
} else {
typePtr = &tclArrayHashKeyType;
}
if (typePtr->hashKeyProc) {
hash = typePtr->hashKeyProc(tablePtr, (void *) key);
if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
index = RANDOM_INDEX(tablePtr, hash);
} else {
index = hash & tablePtr->mask;
}
} else {
hash = PTR2UINT(key);
index = RANDOM_INDEX(tablePtr, hash);
}
/*
* Search all of the entries in the appropriate bucket.
*/
if (typePtr->compareKeysProc) {
Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc;
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
if (hash != PTR2UINT(hPtr->hash)) {
continue;
}
/* if keys pointers or values are equal */
if ((key == hPtr->key.oneWordValue)
|| compareKeysProc((void *) key, hPtr)
) {
if (newPtr) {
*newPtr = 0;
}
return hPtr;
}
}
} else {
for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
hPtr = hPtr->nextPtr) {
if (hash != PTR2UINT(hPtr->hash)) {
continue;
}
if (key == hPtr->key.oneWordValue) {
if (newPtr) {
*newPtr = 0;
}
return hPtr;
|
| ︙ | ︙ | |||
317 318 319 320 321 322 323 |
* Entry not found. Add a new one to the bucket.
*/
*newPtr = 1;
if (typePtr->allocEntryProc) {
hPtr = typePtr->allocEntryProc(tablePtr, (void *) key);
} else {
| | | | | 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 |
* Entry not found. Add a new one to the bucket.
*/
*newPtr = 1;
if (typePtr->allocEntryProc) {
hPtr = typePtr->allocEntryProc(tablePtr, (void *) key);
} else {
hPtr = (Tcl_HashEntry *)ckalloc(sizeof(Tcl_HashEntry));
hPtr->key.oneWordValue = (char *) key;
hPtr->clientData = 0;
}
hPtr->tablePtr = tablePtr;
hPtr->hash = UINT2PTR(hash);
hPtr->nextPtr = tablePtr->buckets[index];
tablePtr->buckets[index] = hPtr;
tablePtr->numEntries++;
/*
* If the table has exceeded a decent size, rebuild it with many more
* buckets.
|
| ︙ | ︙ | |||
361 362 363 364 365 366 367 |
*----------------------------------------------------------------------
*/
void
Tcl_DeleteHashEntry(
Tcl_HashEntry *entryPtr)
{
| | | | | | 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 |
*----------------------------------------------------------------------
*/
void
Tcl_DeleteHashEntry(
Tcl_HashEntry *entryPtr)
{
Tcl_HashEntry *prevPtr;
const Tcl_HashKeyType *typePtr;
Tcl_HashTable *tablePtr;
Tcl_HashEntry **bucketPtr;
int index;
tablePtr = entryPtr->tablePtr;
if (tablePtr->keyType == TCL_STRING_KEYS) {
typePtr = &tclStringHashKeyType;
} else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
typePtr = &tclOneWordHashKeyType;
} else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
|| tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
typePtr = tablePtr->typePtr;
} else {
typePtr = &tclArrayHashKeyType;
}
if (typePtr->hashKeyProc == NULL
|| typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
index = RANDOM_INDEX(tablePtr, PTR2INT(entryPtr->hash));
} else {
index = PTR2UINT(entryPtr->hash) & tablePtr->mask;
}
bucketPtr = &tablePtr->buckets[index];
if (*bucketPtr == entryPtr) {
*bucketPtr = entryPtr->nextPtr;
} else {
|
| ︙ | ︙ | |||
407 408 409 410 411 412 413 |
}
}
tablePtr->numEntries--;
if (typePtr->freeEntryProc) {
typePtr->freeEntryProc(entryPtr);
} else {
| | | 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 |
}
}
tablePtr->numEntries--;
if (typePtr->freeEntryProc) {
typePtr->freeEntryProc(entryPtr);
} else {
ckfree(entryPtr);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteHashTable --
|
| ︙ | ︙ | |||
430 431 432 433 434 435 436 | * The hash table is no longer useable. * *---------------------------------------------------------------------- */ void Tcl_DeleteHashTable( | | | | | 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 |
* The hash table is no longer useable.
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteHashTable(
Tcl_HashTable *tablePtr) /* Table to delete. */
{
Tcl_HashEntry *hPtr, *nextPtr;
const Tcl_HashKeyType *typePtr;
int i;
if (tablePtr->keyType == TCL_STRING_KEYS) {
typePtr = &tclStringHashKeyType;
} else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
typePtr = &tclOneWordHashKeyType;
} else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
|| tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
|
| ︙ | ︙ | |||
458 459 460 461 462 463 464 |
for (i = 0; i < tablePtr->numBuckets; i++) {
hPtr = tablePtr->buckets[i];
while (hPtr != NULL) {
nextPtr = hPtr->nextPtr;
if (typePtr->freeEntryProc) {
typePtr->freeEntryProc(hPtr);
} else {
| | | | 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 |
for (i = 0; i < tablePtr->numBuckets; i++) {
hPtr = tablePtr->buckets[i];
while (hPtr != NULL) {
nextPtr = hPtr->nextPtr;
if (typePtr->freeEntryProc) {
typePtr->freeEntryProc(hPtr);
} else {
ckfree(hPtr);
}
hPtr = nextPtr;
}
}
/*
* Free up the bucket array, if it was dynamically allocated.
*/
if (tablePtr->buckets != tablePtr->staticBuckets) {
if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
TclpSysFree((char *) tablePtr->buckets);
} else {
ckfree(tablePtr->buckets);
}
}
/*
* Arrange for panics if the table is used again without
* re-initialization.
*/
|
| ︙ | ︙ | |||
538 539 540 541 542 543 544 | * None. * *---------------------------------------------------------------------- */ Tcl_HashEntry * Tcl_NextHashEntry( | | | 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_HashEntry *
Tcl_NextHashEntry(
Tcl_HashSearch *searchPtr)
/* Place to store information about progress
* through the table. Must have been
* initialized by calling
* Tcl_FirstHashEntry. */
{
Tcl_HashEntry *hPtr;
Tcl_HashTable *tablePtr = searchPtr->tablePtr;
|
| ︙ | ︙ | |||
583 584 585 586 587 588 589 |
*/
char *
Tcl_HashStats(
Tcl_HashTable *tablePtr) /* Table for which to produce stats. */
{
#define NUM_COUNTERS 10
| | | | 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 |
*/
char *
Tcl_HashStats(
Tcl_HashTable *tablePtr) /* Table for which to produce stats. */
{
#define NUM_COUNTERS 10
int count[NUM_COUNTERS], overflow, i, j;
double average, tmp;
Tcl_HashEntry *hPtr;
char *result, *p;
/*
* Compute a histogram of bucket usage.
*/
for (i = 0; i < NUM_COUNTERS; i++) {
|
| ︙ | ︙ | |||
617 618 619 620 621 622 623 |
}
}
/*
* Print out the histogram and a few other pieces of information.
*/
| | | | | | 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 |
}
}
/*
* Print out the histogram and a few other pieces of information.
*/
result = (char *)ckalloc((NUM_COUNTERS * 60) + 300);
sprintf(result, "%d entries in table, %d buckets\n",
tablePtr->numEntries, tablePtr->numBuckets);
p = result + strlen(result);
for (i = 0; i < NUM_COUNTERS; i++) {
sprintf(p, "number of buckets with %d entries: %d\n",
i, count[i]);
p += strlen(p);
}
sprintf(p, "number of buckets with %d or more entries: %d\n",
NUM_COUNTERS, overflow);
p += strlen(p);
sprintf(p, "average search distance for entry: %.1f", average);
return result;
}
/*
|
| ︙ | ︙ | |||
652 653 654 655 656 657 658 |
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
AllocArrayEntry(
Tcl_HashTable *tablePtr, /* Hash table. */
| | | | | | | 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 |
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
AllocArrayEntry(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key to store in the hash table entry. */
{
int *array = (int *) keyPtr;
int *iPtr1, *iPtr2;
Tcl_HashEntry *hPtr;
int count;
unsigned int size;
count = tablePtr->keyType;
size = sizeof(Tcl_HashEntry) + (count*sizeof(int)) - sizeof(hPtr->key);
if (size < sizeof(Tcl_HashEntry)) {
size = sizeof(Tcl_HashEntry);
}
hPtr = (Tcl_HashEntry *)ckalloc(size);
for (iPtr1 = array, iPtr2 = hPtr->key.words;
count > 0; count--, iPtr1++, iPtr2++) {
*iPtr2 = *iPtr1;
}
hPtr->clientData = 0;
return hPtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
696 697 698 699 700 701 702 | * None. * *---------------------------------------------------------------------- */ static int CompareArrayKeys( | | | | | 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 |
* None.
*
*----------------------------------------------------------------------
*/
static int
CompareArrayKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
const int *iPtr1 = (const int *) keyPtr;
const int *iPtr2 = (const int *) hPtr->key.words;
Tcl_HashTable *tablePtr = hPtr->tablePtr;
int count;
for (count = tablePtr->keyType; ; count--, iPtr1++, iPtr2++) {
if (count == 0) {
return 1;
}
|
| ︙ | ︙ | |||
736 737 738 739 740 741 742 |
*
*----------------------------------------------------------------------
*/
static TCL_HASH_TYPE
HashArrayKey(
Tcl_HashTable *tablePtr, /* Hash table. */
| | | | | 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 |
*
*----------------------------------------------------------------------
*/
static TCL_HASH_TYPE
HashArrayKey(
Tcl_HashTable *tablePtr, /* Hash table. */
void *keyPtr) /* Key from which to compute hash value. */
{
const int *array = (const int *) keyPtr;
TCL_HASH_TYPE result;
int count;
for (result = 0, count = tablePtr->keyType; count > 0;
count--, array++) {
result += *array;
}
return result;
|
| ︙ | ︙ | |||
767 768 769 770 771 772 773 | * None. * *---------------------------------------------------------------------- */ static Tcl_HashEntry * AllocStringEntry( | | | | > | | 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 |
* None.
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
AllocStringEntry(
TCL_UNUSED(Tcl_HashTable *),
void *keyPtr) /* Key to store in the hash table entry. */
{
const char *string = (const char *) keyPtr;
Tcl_HashEntry *hPtr;
size_t size, allocsize;
allocsize = size = strlen(string) + 1;
if (size < sizeof(hPtr->key)) {
allocsize = sizeof(hPtr->key);
}
hPtr = (Tcl_HashEntry *)ckalloc(offsetof(Tcl_HashEntry, key) + allocsize);
memset(hPtr, 0, sizeof(Tcl_HashEntry) + allocsize - sizeof(hPtr->key));
memcpy(hPtr->key.string, string, size);
hPtr->clientData = 0;
return hPtr;
}
/*
*----------------------------------------------------------------------
*
* CompareStringKeys --
|
| ︙ | ︙ | |||
803 804 805 806 807 808 809 | * None. * *---------------------------------------------------------------------- */ static int CompareStringKeys( | | > > > | | 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 |
* None.
*
*----------------------------------------------------------------------
*/
static int
CompareStringKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
const char *p1 = (const char *) keyPtr;
const char *p2 = (const char *) hPtr->key.string;
return !strcmp(p1, p2);
}
/*
*----------------------------------------------------------------------
*
* HashStringKey --
*
|
| ︙ | ︙ | |||
828 829 830 831 832 833 834 | * None. * *---------------------------------------------------------------------- */ static TCL_HASH_TYPE HashStringKey( | | | | | | | 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 |
* None.
*
*----------------------------------------------------------------------
*/
static TCL_HASH_TYPE
HashStringKey(
TCL_UNUSED(Tcl_HashTable *),
void *keyPtr) /* Key from which to compute hash value. */
{
const char *string = (const char *)keyPtr;
TCL_HASH_TYPE result;
char c;
/*
* I tried a zillion different hash functions and asked many other people
* for advice. Many people had their own favorite functions, all
* different, but no-one had much idea why they were good ones. I chose
* the one below (multiply by 9 and add new character) because of the
* following reasons:
|
| ︙ | ︙ | |||
892 893 894 895 896 897 898 | * * Side effects: * Generates a panic. * *---------------------------------------------------------------------- */ | < | | | 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 |
*
* Side effects:
* Generates a panic.
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
BogusFind(
TCL_UNUSED(Tcl_HashTable *),
TCL_UNUSED(const char *))
{
Tcl_Panic("called %s on deleted table", "Tcl_FindHashEntry");
return NULL;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
919 920 921 922 923 924 925 | * * Side effects: * Generates a panic. * *---------------------------------------------------------------------- */ | < | | | < < | 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 |
*
* Side effects:
* Generates a panic.
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
BogusCreate(
TCL_UNUSED(Tcl_HashTable *),
TCL_UNUSED(const char *),
TCL_UNUSED(int *))
{
Tcl_Panic("called %s on deleted table", "Tcl_CreateHashEntry");
return NULL;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
952 953 954 955 956 957 958 | * Memory gets reallocated and entries get re-hashed to new buckets. * *---------------------------------------------------------------------- */ static void RebuildTable( | | | | | | | 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 |
* Memory gets reallocated and entries get re-hashed to new buckets.
*
*----------------------------------------------------------------------
*/
static void
RebuildTable(
Tcl_HashTable *tablePtr) /* Table to enlarge. */
{
int count, index, oldSize = tablePtr->numBuckets;
Tcl_HashEntry **oldBuckets = tablePtr->buckets;
Tcl_HashEntry **oldChainPtr, **newChainPtr;
Tcl_HashEntry *hPtr;
const Tcl_HashKeyType *typePtr;
/* Avoid outgrowing capability of the memory allocators */
if (oldSize > (int)(UINT_MAX / (4 * sizeof(Tcl_HashEntry *)))) {
tablePtr->rebuildSize = INT_MAX;
return;
}
if (tablePtr->keyType == TCL_STRING_KEYS) {
typePtr = &tclStringHashKeyType;
} else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
|
| ︙ | ︙ | |||
984 985 986 987 988 989 990 |
/*
* Allocate and initialize the new bucket array, and set up hashing
* constants for new array size.
*/
tablePtr->numBuckets *= 4;
if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
| | | | < | < | | | | 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 |
/*
* Allocate and initialize the new bucket array, and set up hashing
* constants for new array size.
*/
tablePtr->numBuckets *= 4;
if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
tablePtr->buckets = (Tcl_HashEntry **) TclpSysAlloc(
tablePtr->numBuckets * sizeof(Tcl_HashEntry *), 0);
} else {
tablePtr->buckets =
(Tcl_HashEntry **)ckalloc(tablePtr->numBuckets * sizeof(Tcl_HashEntry *));
}
for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets;
count > 0; count--, newChainPtr++) {
*newChainPtr = NULL;
}
tablePtr->rebuildSize *= 4;
tablePtr->downShift -= 2;
tablePtr->mask = (tablePtr->mask << 2) + 3;
/*
* Rehash all of the existing entries into the new bucket array.
*/
for (oldChainPtr = oldBuckets; oldSize > 0; oldSize--, oldChainPtr++) {
for (hPtr = *oldChainPtr; hPtr != NULL; hPtr = *oldChainPtr) {
*oldChainPtr = hPtr->nextPtr;
if (typePtr->hashKeyProc == NULL
|| typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) {
index = RANDOM_INDEX(tablePtr, PTR2INT(hPtr->hash));
} else {
index = PTR2UINT(hPtr->hash) & tablePtr->mask;
}
hPtr->nextPtr = tablePtr->buckets[index];
tablePtr->buckets[index] = hPtr;
}
}
/*
* Free up the old bucket array, if it was dynamically allocated.
*/
if (oldBuckets != tablePtr->staticBuckets) {
if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
TclpSysFree((char *) oldBuckets);
} else {
ckfree(oldBuckets);
}
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclHistory.c.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
* be executed. */
const char *cmd, /* Command to record. */
int flags) /* Additional flags. TCL_NO_EVAL means only
* record: don't execute command.
* TCL_EVAL_GLOBAL means use Tcl_GlobalEval
* instead of Tcl_Eval. */
{
| | > > > > > > > | 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 |
* be executed. */
const char *cmd, /* Command to record. */
int flags) /* Additional flags. TCL_NO_EVAL means only
* record: don't execute command.
* TCL_EVAL_GLOBAL means use Tcl_GlobalEval
* instead of Tcl_Eval. */
{
Tcl_Obj *cmdPtr;
int result;
if (cmd[0]) {
/*
* Call Tcl_RecordAndEvalObj to do the actual work.
*/
cmdPtr = Tcl_NewStringObj(cmd, -1);
Tcl_IncrRefCount(cmdPtr);
result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags);
/*
* Move the interpreter's object result to the string result, then
* reset the object result.
*/
(void) Tcl_GetStringResult(interp);
/*
* Discard the Tcl object created to hold the command.
*/
Tcl_DecrRefCount(cmdPtr);
} else {
/*
|
| ︙ | ︙ | |||
119 120 121 122 123 124 125 |
* TCL_EVAL_GLOBAL means evaluate the script
* in global variable context instead of the
* current procedure. */
{
int result, call = 1;
Tcl_CmdInfo info;
HistoryObjs *histObjsPtr =
| | | | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 |
* TCL_EVAL_GLOBAL means evaluate the script
* in global variable context instead of the
* current procedure. */
{
int result, call = 1;
Tcl_CmdInfo info;
HistoryObjs *histObjsPtr =
(HistoryObjs *)Tcl_GetAssocData(interp, HISTORY_OBJS_KEY, NULL);
/*
* Create the references to the [::history add] command if necessary.
*/
if (histObjsPtr == NULL) {
histObjsPtr = (HistoryObjs *)ckalloc(sizeof(HistoryObjs));
TclNewLiteralStringObj(histObjsPtr->historyObj, "::history");
TclNewLiteralStringObj(histObjsPtr->addObj, "add");
Tcl_IncrRefCount(histObjsPtr->historyObj);
Tcl_IncrRefCount(histObjsPtr->addObj);
Tcl_SetAssocData(interp, HISTORY_OBJS_KEY, DeleteHistoryObjs,
histObjsPtr);
}
|
| ︙ | ︙ | |||
200 201 202 203 204 205 206 |
*
*----------------------------------------------------------------------
*/
static void
DeleteHistoryObjs(
ClientData clientData,
| | | | | 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 |
*
*----------------------------------------------------------------------
*/
static void
DeleteHistoryObjs(
ClientData clientData,
TCL_UNUSED(Tcl_Interp *))
{
HistoryObjs *histObjsPtr = (HistoryObjs *)clientData;
TclDecrRefCount(histObjsPtr->historyObj);
TclDecrRefCount(histObjsPtr->addObj);
ckfree(histObjsPtr);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclIO.c.
| ︙ | ︙ | |||
187 188 189 190 191 192 193 | Tcl_Interp *interp); static void DeleteScriptRecord(Tcl_Interp *interp, Channel *chanPtr, int mask); static int DetachChannel(Tcl_Interp *interp, Tcl_Channel chan); static void DiscardInputQueued(ChannelState *statePtr, int discardSavedBuffers); static void DiscardOutputQueued(ChannelState *chanPtr); | | | | | < < | 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 | Tcl_Interp *interp); static void DeleteScriptRecord(Tcl_Interp *interp, Channel *chanPtr, int mask); static int DetachChannel(Tcl_Interp *interp, Tcl_Channel chan); static void DiscardInputQueued(ChannelState *statePtr, int discardSavedBuffers); static void DiscardOutputQueued(ChannelState *chanPtr); static int DoRead(Channel *chanPtr, char *dst, int bytesToRead, int allowShortReads); static int DoReadChars(Channel *chan, Tcl_Obj *objPtr, int toRead, int appendFlag); static int FilterInputBytes(Channel *chanPtr, GetsState *statePtr); static int FlushChannel(Tcl_Interp *interp, Channel *chanPtr, int calledFromAsyncFlush); static int TclGetsObjBinary(Tcl_Channel chan, Tcl_Obj *objPtr); static Tcl_Encoding GetBinaryEncoding(void); static Tcl_ExitProc FreeBinaryEncoding; static Tcl_HashTable * GetChannelTable(Tcl_Interp *interp); static int GetInput(Channel *chanPtr); static void PeekAhead(Channel *chanPtr, char **dstEndPtr, GetsState *gsPtr); static int ReadBytes(ChannelState *statePtr, Tcl_Obj *objPtr, int charsLeft); static int ReadChars(ChannelState *statePtr, Tcl_Obj *objPtr, int charsLeft, int *factorPtr); static void RecycleBuffer(ChannelState *statePtr, |
| ︙ | ︙ | |||
235 236 237 238 239 240 241 | /* * Simplifying helper macros. All may use their argument(s) multiple times. * The ANSI C "prototypes" for the macros are listed below, together with a * short description of what the macro does. * * -------------------------------------------------------------------------- | | | 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 | /* * Simplifying helper macros. All may use their argument(s) multiple times. * The ANSI C "prototypes" for the macros are listed below, together with a * short description of what the macro does. * * -------------------------------------------------------------------------- * int BytesLeft(ChannelBuffer *bufPtr) * * Returns the number of bytes of data remaining in the buffer. * * int SpaceLeft(ChannelBuffer *bufPtr) * * Returns the number of bytes of space remaining at the end of the * buffer. |
| ︙ | ︙ | |||
273 274 275 276 277 278 279 | * char *RemovePoint(ChannelBuffer *bufPtr) * * Returns a pointer to where characters should be removed from the * buffer. * -------------------------------------------------------------------------- */ | | | | 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 | * char *RemovePoint(ChannelBuffer *bufPtr) * * Returns a pointer to where characters should be removed from the * buffer. * -------------------------------------------------------------------------- */ #define BytesLeft(bufPtr) ((bufPtr)->nextAdded - (bufPtr)->nextRemoved) #define SpaceLeft(bufPtr) ((bufPtr)->bufLength - (bufPtr)->nextAdded) #define IsBufferReady(bufPtr) ((bufPtr)->nextAdded > (bufPtr)->nextRemoved) #define IsBufferEmpty(bufPtr) ((bufPtr)->nextAdded == (bufPtr)->nextRemoved) #define IsBufferFull(bufPtr) ((bufPtr) && (bufPtr)->nextAdded >= (bufPtr)->bufLength) |
| ︙ | ︙ | |||
346 347 348 349 350 351 352 |
Tcl_StoreIntRep((objPtr), &chanObjType, &ir); \
} while (0)
#define ChanGetIntRep(objPtr, resPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &chanObjType); \
| | | 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 |
Tcl_StoreIntRep((objPtr), &chanObjType, &ir); \
} while (0)
#define ChanGetIntRep(objPtr, resPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &chanObjType); \
(resPtr) = irPtr ? (ResolvedChanName *)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
#define BUSY_STATE(st, fl) \
((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \
(((st)->csPtrW) && ((fl) & TCL_WRITABLE)))
#define MAX_CHANNEL_BUFFER_SIZE (1024*1024)
|
| ︙ | ︙ | |||
372 373 374 375 376 377 378 |
*/
static inline int
ChanClose(
Channel *chanPtr,
Tcl_Interp *interp)
{
| > | < < < | < < < < < < | | 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 |
*/
static inline int
ChanClose(
Channel *chanPtr,
Tcl_Interp *interp)
{
#ifndef TCL_NO_DEPRECATED
if ((chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) && (chanPtr->typePtr->closeProc != NULL)) {
return chanPtr->typePtr->closeProc(chanPtr->instanceData, interp);
}
#endif
return chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, 0);
}
/*
*---------------------------------------------------------------------------
*
* ChanRead --
*
|
| ︙ | ︙ | |||
436 437 438 439 440 441 442 |
*/
if (GotFlag(chanPtr->state, CHANNEL_EOF)) {
chanPtr->state->inputEncodingFlags |= TCL_ENCODING_START;
}
ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF);
chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END;
| | | < < < < < < < < < > > > > > > > > > < | > | | > | > | > | > | | | 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 |
*/
if (GotFlag(chanPtr->state, CHANNEL_EOF)) {
chanPtr->state->inputEncodingFlags |= TCL_ENCODING_START;
}
ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF);
chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END;
if (WillRead(chanPtr) < 0) {
return -1;
}
bytesRead = chanPtr->typePtr->inputProc(chanPtr->instanceData,
dst, dstSize, &result);
/*
* Stop any flag leakage through stacked channel levels.
*/
if (GotFlag(chanPtr->state, CHANNEL_EOF)) {
chanPtr->state->inputEncodingFlags |= TCL_ENCODING_START;
}
ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF);
chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END;
if (bytesRead > 0) {
/*
* If we get a short read, signal up that we may be BLOCKED. We should
* avoid calling the driver because on some platforms we will block in
* the low level reading code even though the channel is set into
* nonblocking mode.
*/
if (bytesRead < dstSize) {
SetFlag(chanPtr->state, CHANNEL_BLOCKED);
}
} else if (bytesRead == 0) {
SetFlag(chanPtr->state, CHANNEL_EOF);
chanPtr->state->inputEncodingFlags |= TCL_ENCODING_END;
} else if (bytesRead < 0) {
if ((result == EWOULDBLOCK) || (result == EAGAIN)) {
SetFlag(chanPtr->state, CHANNEL_BLOCKED);
result = EAGAIN;
}
Tcl_SetErrno(result);
}
return bytesRead;
}
static inline Tcl_WideInt
ChanSeek(
Channel *chanPtr,
Tcl_WideInt offset,
int mode,
int *errnoPtr)
{
/*
* Note that we prefer the wideSeekProc if that field is available in the
* type and non-NULL.
*/
if (Tcl_ChannelWideSeekProc(chanPtr->typePtr) == NULL) {
#ifndef TCL_NO_DEPRECATED
if (offset<LONG_MIN || offset>LONG_MAX) {
*errnoPtr = EOVERFLOW;
return -1;
}
return Tcl_ChannelSeekProc(chanPtr->typePtr)(chanPtr->instanceData,
offset, mode, errnoPtr);
#else
*errnoPtr = EINVAL;
return -1;
#endif
}
return Tcl_ChannelWideSeekProc(chanPtr->typePtr)(chanPtr->instanceData,
offset, mode, errnoPtr);
}
static inline void
ChanThreadAction(
Channel *chanPtr,
int action)
{
|
| ︙ | ︙ | |||
581 582 583 584 585 586 587 | * * Side effects: * Depends on encoding and memory subsystems. * *------------------------------------------------------------------------- */ | < | 575 576 577 578 579 580 581 582 583 584 585 586 587 588 |
*
* Side effects:
* Depends on encoding and memory subsystems.
*
*-------------------------------------------------------------------------
*/
void
TclFinalizeIOSubsystem(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Channel *chanPtr = NULL; /* Iterates over open channels. */
ChannelState *statePtr; /* State of channel stack */
int active = 1; /* Flag == 1 while there's still work to do */
|
| ︙ | ︙ | |||
669 670 671 672 673 674 675 | * Decrement the refcount which was earlier artificially * bumped up to keep the channel from being closed. */ statePtr->refCount--; } | | | 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 |
* Decrement the refcount which was earlier artificially
* bumped up to keep the channel from being closed.
*/
statePtr->refCount--;
}
if (statePtr->refCount <= 0) {
/*
* Close it only if the refcount indicates that the channel is
* not referenced from any interpreter. If it is, that
* interpreter will close the channel when it gets destroyed.
*/
(void) Tcl_Close(NULL, (Tcl_Channel) chanPtr);
|
| ︙ | ︙ | |||
856 857 858 859 860 861 862 |
* channel will be closed. */
ClientData clientData) /* Arbitrary data to pass to the close
* callback. */
{
ChannelState *statePtr = ((Channel *) chan)->state;
CloseCallback *cbPtr;
| | | 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 |
* channel will be closed. */
ClientData clientData) /* Arbitrary data to pass to the close
* callback. */
{
ChannelState *statePtr = ((Channel *) chan)->state;
CloseCallback *cbPtr;
cbPtr = (CloseCallback *)ckalloc(sizeof(CloseCallback));
cbPtr->proc = proc;
cbPtr->clientData = clientData;
cbPtr->nextPtr = statePtr->closeCbPtr;
statePtr->closeCbPtr = cbPtr;
}
|
| ︙ | ︙ | |||
902 903 904 905 906 907 908 |
cbPtr != NULL; cbPtr = cbPtr->nextPtr) {
if ((cbPtr->proc == proc) && (cbPtr->clientData == clientData)) {
if (cbPrevPtr == NULL) {
statePtr->closeCbPtr = cbPtr->nextPtr;
} else {
cbPrevPtr->nextPtr = cbPtr->nextPtr;
}
| | | 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 |
cbPtr != NULL; cbPtr = cbPtr->nextPtr) {
if ((cbPtr->proc == proc) && (cbPtr->clientData == clientData)) {
if (cbPrevPtr == NULL) {
statePtr->closeCbPtr = cbPtr->nextPtr;
} else {
cbPrevPtr->nextPtr = cbPtr->nextPtr;
}
ckfree(cbPtr);
break;
}
cbPrevPtr = cbPtr;
}
}
/*
|
| ︙ | ︙ | |||
935 936 937 938 939 940 941 |
static Tcl_HashTable *
GetChannelTable(
Tcl_Interp *interp)
{
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_Channel stdinChan, stdoutChan, stderrChan;
| | | | 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 |
static Tcl_HashTable *
GetChannelTable(
Tcl_Interp *interp)
{
Tcl_HashTable *hTblPtr; /* Hash table of channels. */
Tcl_Channel stdinChan, stdoutChan, stderrChan;
hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == NULL) {
hTblPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS);
Tcl_SetAssocData(interp, "tclIO",
(Tcl_InterpDeleteProc *) DeleteChannelTable, hTblPtr);
/*
* If the interpreter is trusted (not "safe"), insert channels for
* stdin, stdout and stderr (possibly creating them in the process).
|
| ︙ | ︙ | |||
1005 1006 1007 1008 1009 1010 1011 |
* to the interpreter being deleted. */
/*
* Delete all the registered channels - this will close channels whose
* refcount reaches zero.
*/
| | | | | 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 |
* to the interpreter being deleted. */
/*
* Delete all the registered channels - this will close channels whose
* refcount reaches zero.
*/
hTblPtr = (Tcl_HashTable *)clientData;
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != NULL;
hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch)) {
chanPtr = (Channel *)Tcl_GetHashValue(hPtr);
statePtr = chanPtr->state;
/*
* Remove any fileevents registered in this interpreter.
*/
for (sPtr = statePtr->scriptRecordPtr, prevPtr = NULL;
sPtr != NULL; sPtr = nextPtr) {
nextPtr = sPtr->nextPtr;
if (sPtr->interp == interp) {
if (prevPtr == NULL) {
statePtr->scriptRecordPtr = nextPtr;
} else {
prevPtr->nextPtr = nextPtr;
}
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, sPtr);
TclDecrRefCount(sPtr->scriptPtr);
ckfree(sPtr);
} else {
prevPtr = sPtr;
}
}
/*
* Cannot call Tcl_UnregisterChannel because that procedure calls
|
| ︙ | ︙ | |||
1052 1053 1054 1055 1056 1057 1058 |
if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
(void) Tcl_Close(interp, (Tcl_Channel) chanPtr);
}
}
}
Tcl_DeleteHashTable(hTblPtr);
| | | 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 |
if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
(void) Tcl_Close(interp, (Tcl_Channel) chanPtr);
}
}
}
Tcl_DeleteHashTable(hTblPtr);
ckfree(hTblPtr);
}
/*
*----------------------------------------------------------------------
*
* CheckForStdChannelsBeingClosed --
*
|
| ︙ | ︙ | |||
1087 1088 1089 1090 1091 1092 1093 |
{
ChannelState *statePtr = ((Channel *) chan)->state;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->stdinInitialized == 1
&& tsdPtr->stdinChannel != NULL
&& statePtr == ((Channel *)tsdPtr->stdinChannel)->state) {
| | | | | 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 |
{
ChannelState *statePtr = ((Channel *) chan)->state;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->stdinInitialized == 1
&& tsdPtr->stdinChannel != NULL
&& statePtr == ((Channel *)tsdPtr->stdinChannel)->state) {
if (statePtr->refCount < 2) {
statePtr->refCount = 0;
tsdPtr->stdinChannel = NULL;
return;
}
} else if (tsdPtr->stdoutInitialized == 1
&& tsdPtr->stdoutChannel != NULL
&& statePtr == ((Channel *)tsdPtr->stdoutChannel)->state) {
if (statePtr->refCount < 2) {
statePtr->refCount = 0;
tsdPtr->stdoutChannel = NULL;
return;
}
} else if (tsdPtr->stderrInitialized == 1
&& tsdPtr->stderrChannel != NULL
&& statePtr == ((Channel *)tsdPtr->stderrChannel)->state) {
if (statePtr->refCount < 2) {
statePtr->refCount = 0;
tsdPtr->stderrChannel = NULL;
return;
}
}
}
|
| ︙ | ︙ | |||
1265 1266 1267 1268 1269 1270 1271 |
CheckForStdChannelsBeingClosed(chan);
/*
* If the refCount reached zero, close the actual channel.
*/
| | | 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 |
CheckForStdChannelsBeingClosed(chan);
/*
* If the refCount reached zero, close the actual channel.
*/
if (statePtr->refCount <= 0) {
Tcl_Preserve(statePtr);
if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
/*
* We don't want to re-enter Tcl_Close().
*/
if (!GotFlag(statePtr, CHANNEL_CLOSED)) {
|
| ︙ | ︙ | |||
1375 1376 1377 1378 1379 1380 1381 |
* necessary during (un)stack operation.
*/
chanPtr = ((Channel *) chan)->state->bottomChanPtr;
statePtr = chanPtr->state;
if (interp != NULL) {
| | | 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 |
* necessary during (un)stack operation.
*/
chanPtr = ((Channel *) chan)->state->bottomChanPtr;
statePtr = chanPtr->state;
if (interp != NULL) {
hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == NULL) {
return TCL_ERROR;
}
hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName);
if (hPtr == NULL) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1478 1479 1480 1481 1482 1483 1484 |
/*
* Always return bottom-most channel in the stack. This one lives the
* longest - other channels may go away unnoticed. The other APIs
* compensate where necessary to retrieve the topmost channel again.
*/
| | | 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 |
/*
* Always return bottom-most channel in the stack. This one lives the
* longest - other channels may go away unnoticed. The other APIs
* compensate where necessary to retrieve the topmost channel again.
*/
chanPtr = (Channel *)Tcl_GetHashValue(hPtr);
chanPtr = chanPtr->state->bottomChanPtr;
if (modePtr != NULL) {
*modePtr = chanPtr->state->flags & (TCL_READABLE|TCL_WRITABLE);
}
return (Tcl_Channel) chanPtr;
}
|
| ︙ | ︙ | |||
1517 1518 1519 1520 1521 1522 1523 |
* channel. */
Tcl_Obj *objPtr,
Tcl_Channel *channelPtr,
int *modePtr, /* Where to store the mode in which the
* channel was opened? Will contain an ORed
* combination of TCL_READABLE and
* TCL_WRITABLE, if non-NULL. */
| | | | | | | | 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 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 |
* channel. */
Tcl_Obj *objPtr,
Tcl_Channel *channelPtr,
int *modePtr, /* Where to store the mode in which the
* channel was opened? Will contain an ORed
* combination of TCL_READABLE and
* TCL_WRITABLE, if non-NULL. */
TCL_UNUSED(int) /*flags*/)
{
ChannelState *statePtr;
ResolvedChanName *resPtr = NULL;
Tcl_Channel chan;
if (interp == NULL) {
return TCL_ERROR;
}
ChanGetIntRep(objPtr, resPtr);
if (resPtr) {
/*
* Confirm validity of saved lookup results.
*/
statePtr = resPtr->statePtr;
if ((resPtr->interp == interp) /* Same interp context */
/* No epoch change in channel since lookup */
&& (resPtr->epoch == statePtr->epoch)) {
/*
* Have a valid saved lookup. Jump to end to return it.
*/
goto valid;
}
}
chan = Tcl_GetChannel(interp, TclGetString(objPtr), NULL);
if (chan == NULL) {
if (resPtr) {
Tcl_StoreIntRep(objPtr, &chanObjType, NULL);
}
return TCL_ERROR;
}
if (resPtr && resPtr->refCount == 1) {
/*
* Re-use the ResolvedCmdName struct.
*/
Tcl_Release((ClientData) resPtr->statePtr);
} else {
resPtr = (ResolvedChanName *) ckalloc(sizeof(ResolvedChanName));
resPtr->refCount = 0;
ChanSetIntRep(objPtr, resPtr); /* Overwrites, if needed */
}
statePtr = ((Channel *)chan)->state;
resPtr->statePtr = statePtr;
Tcl_Preserve((ClientData) statePtr);
resPtr->interp = interp;
resPtr->epoch = statePtr->epoch;
valid:
*channelPtr = (Tcl_Channel) statePtr->bottomChanPtr;
if (modePtr != NULL) {
|
| ︙ | ︙ | |||
1624 1625 1626 1627 1628 1629 1630 |
* If this assertion fails on some system, then it can be removed only if
* the user recompiles code with older channel drivers in the new system
* as well.
*/
assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc *));
assert(typePtr->typeName != NULL);
| > > > > > > > > | | > > | > | | | | | 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 |
* If this assertion fails on some system, then it can be removed only if
* the user recompiles code with older channel drivers in the new system
* as well.
*/
assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc *));
assert(typePtr->typeName != NULL);
#ifndef TCL_NO_DEPRECATED
if (((NULL == typePtr->closeProc) || (TCL_CLOSE2PROC == typePtr->closeProc)) && (typePtr->close2Proc == NULL)) {
Tcl_Panic("channel type %s must define closeProc or close2Proc", typePtr->typeName);
}
#else
if (Tcl_ChannelVersion(typePtr) < TCL_CHANNEL_VERSION_5) {
Tcl_Panic("channel type %s must be version TCL_CHANNEL_VERSION_5", typePtr->typeName);
}
if (typePtr->close2Proc == NULL) {
Tcl_Panic("channel type %s must define close2Proc", typePtr->typeName);
}
#endif
if ((TCL_READABLE & mask) && (NULL == typePtr->inputProc)) {
Tcl_Panic("channel type %s must define inputProc when used for reader channel", typePtr->typeName);
}
if ((TCL_WRITABLE & mask) && (NULL == typePtr->outputProc)) {
Tcl_Panic("channel type %s must define outputProc when used for writer channel", typePtr->typeName);
}
if (NULL == typePtr->watchProc) {
Tcl_Panic("channel type %s must define watchProc", typePtr->typeName);
}
#ifndef TCL_NO_DEPRECATED
if ((NULL != typePtr->wideSeekProc) && (NULL == typePtr->seekProc)) {
Tcl_Panic("channel type %s must define seekProc if defining wideSeekProc", typePtr->typeName);
}
#endif
/*
* JH: We could subsequently memset these to 0 to avoid the numerous
* assignments to 0/NULL below.
*/
chanPtr = (Channel *)ckalloc(sizeof(Channel));
statePtr = (ChannelState *)ckalloc(sizeof(ChannelState));
chanPtr->state = statePtr;
chanPtr->instanceData = instanceData;
chanPtr->typePtr = typePtr;
/*
* Set all the bits that are part of the stack-independent state
* information for the channel.
*/
if (chanName != NULL) {
unsigned len = strlen(chanName) + 1;
/*
* Make sure we allocate at least 7 bytes, so it fits for "stdout"
* later.
*/
tmp = (char *)ckalloc((len < 7) ? 7 : len);
strcpy(tmp, chanName);
} else {
tmp = (char *)ckalloc(7);
tmp[0] = '\0';
}
statePtr->channelName = tmp;
statePtr->flags = mask;
/*
* Set the channel to system default encoding.
|
| ︙ | ︙ | |||
1941 1942 1943 1944 1945 1946 1947 |
prevChanPtr->inQueueHead = statePtr->inQueueHead;
prevChanPtr->inQueueTail = statePtr->inQueueTail;
statePtr->inQueueHead = NULL;
statePtr->inQueueTail = NULL;
}
| | | 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 |
prevChanPtr->inQueueHead = statePtr->inQueueHead;
prevChanPtr->inQueueTail = statePtr->inQueueTail;
statePtr->inQueueHead = NULL;
statePtr->inQueueTail = NULL;
}
chanPtr = (Channel *)ckalloc(sizeof(Channel));
/*
* Save some of the current state into the new structure, reinitialize the
* parts which will stay with the transformation.
*
* Remarks:
*/
|
| ︙ | ︙ | |||
2003 2004 2005 2006 2007 2008 2009 |
if (chanPtr->refCount == 0) {
Tcl_Panic("Channel released more than preserved");
}
if (--chanPtr->refCount) {
return;
}
if (chanPtr->typePtr == NULL) {
| | | | | 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 |
if (chanPtr->refCount == 0) {
Tcl_Panic("Channel released more than preserved");
}
if (--chanPtr->refCount) {
return;
}
if (chanPtr->typePtr == NULL) {
ckfree(chanPtr);
}
}
static void
ChannelFree(
Channel *chanPtr)
{
if (chanPtr->refCount == 0) {
ckfree(chanPtr);
return;
}
chanPtr->typePtr = NULL;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2183 2184 2185 2186 2187 2188 2189 |
}
} else {
/*
* This channel does not cover another one. Simply do a close, if
* necessary.
*/
| | | 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 |
}
} else {
/*
* This channel does not cover another one. Simply do a close, if
* necessary.
*/
if (statePtr->refCount <= 0) {
if (Tcl_Close(interp, chan) != TCL_OK) {
/*
* TIP #219, Tcl Channel Reflection API.
* "TclChanCaughtErrorBypass" is not required here, it was
* done already by "Tcl_Close".
*/
|
| ︙ | ︙ | |||
2470 2471 2472 2473 2474 2475 2476 |
AllocChannelBuffer(
int length) /* Desired length of channel buffer. */
{
ChannelBuffer *bufPtr;
int n;
n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING;
| | | | | | 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 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 |
AllocChannelBuffer(
int length) /* Desired length of channel buffer. */
{
ChannelBuffer *bufPtr;
int n;
n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING;
bufPtr = (ChannelBuffer *)ckalloc(n);
bufPtr->nextAdded = BUFFER_PADDING;
bufPtr->nextRemoved = BUFFER_PADDING;
bufPtr->bufLength = length + BUFFER_PADDING;
bufPtr->nextPtr = NULL;
bufPtr->refCount = 1;
return bufPtr;
}
static void
PreserveChannelBuffer(
ChannelBuffer *bufPtr)
{
if (bufPtr->refCount == 0) {
Tcl_Panic("Reuse of ChannelBuffer! %p", bufPtr);
}
bufPtr->refCount++;
}
static void
ReleaseChannelBuffer(
ChannelBuffer *bufPtr)
{
if (--bufPtr->refCount) {
return;
}
ckfree(bufPtr);
}
static int
IsShared(
ChannelBuffer *bufPtr)
{
return bufPtr->refCount > 1;
}
/*
*----------------------------------------------------------------------
*
* RecycleBuffer --
*
|
| ︙ | ︙ | |||
2876 2877 2878 2879 2880 2881 2882 |
*/
DiscardOutputQueued(statePtr);
ReleaseChannelBuffer(bufPtr);
break;
} else {
/*
| | | | 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 |
*/
DiscardOutputQueued(statePtr);
ReleaseChannelBuffer(bufPtr);
break;
} else {
/*
* TODO: Consider detecting and reacting to short writes on
* blocking channels. Ought not happen. See iocmd-24.2.
*/
wroteSome = 1;
}
bufPtr->nextRemoved += written;
/*
|
| ︙ | ︙ | |||
2923 2924 2925 2926 2927 2928 2929 | * able to write something. Either we did write something * and wroteSome should be set, or there was nothing left to * write in this call, and we've completed the BG flush. * These are the two cases above. If we get here, that means * there is some kind failure in the writable event machinery. * * The tls extension indeed suffers from flaws in its channel | | | | 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 |
* able to write something. Either we did write something
* and wroteSome should be set, or there was nothing left to
* write in this call, and we've completed the BG flush.
* These are the two cases above. If we get here, that means
* there is some kind failure in the writable event machinery.
*
* The tls extension indeed suffers from flaws in its channel
* event mgmt. See https://core.tcl-lang.org/tcl/info/c31ca233ca.
* Until that patch is broadly distributed, disable the
* assertion checking here, so that programs using Tcl and
* tls can be debugged.
assert(!calledFromAsyncFlush);
*/
}
}
/*
* If the channel is flagged as closed, delete it when the refCount drops
* to zero, the output queue is empty and there is no output in the
* current output buffer.
*/
if (GotFlag(statePtr, CHANNEL_CLOSED) && (statePtr->refCount <= 0) &&
(statePtr->outQueueHead == NULL) &&
((statePtr->curOutPtr == NULL) ||
IsBufferEmpty(statePtr->curOutPtr))) {
errorCode = CloseChannel(interp, chanPtr, errorCode);
goto done;
}
|
| ︙ | ︙ | |||
3075 3076 3077 3078 3079 3080 3081 |
/*
* Some resources can be cleared only if the bottom channel in a stack is
* closed. All the other channels in the stack are not allowed to remove.
*/
if (chanPtr == statePtr->bottomChanPtr) {
if (statePtr->channelName != NULL) {
| | | 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 |
/*
* Some resources can be cleared only if the bottom channel in a stack is
* closed. All the other channels in the stack are not allowed to remove.
*/
if (chanPtr == statePtr->bottomChanPtr) {
if (statePtr->channelName != NULL) {
ckfree(statePtr->channelName);
statePtr->channelName = NULL;
}
Tcl_FreeEncoding(statePtr->encoding);
}
/*
|
| ︙ | ︙ | |||
3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 |
statePtr->nextCSPtr = NULL;
/*
* TIP #218, Channel Thread Actions
*/
ChanThreadAction((Channel *) chan, TCL_CHANNEL_THREAD_REMOVE);
}
void
Tcl_CutChannel(
Tcl_Channel chan) /* The channel being added. Must not be
* referenced in any interpreter. */
{
| > > > | 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 |
statePtr->nextCSPtr = NULL;
/*
* TIP #218, Channel Thread Actions
*/
ChanThreadAction((Channel *) chan, TCL_CHANNEL_THREAD_REMOVE);
/* Channel is not managed by any thread */
statePtr->managingThread = NULL;
}
void
Tcl_CutChannel(
Tcl_Channel chan) /* The channel being added. Must not be
* referenced in any interpreter. */
{
|
| ︙ | ︙ | |||
3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 |
* TIP #218, Channel Thread Actions
* For all transformations and the base channel.
*/
for (; chanPtr != NULL ; chanPtr = chanPtr->upChanPtr) {
ChanThreadAction(chanPtr, TCL_CHANNEL_THREAD_REMOVE);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SpliceChannel --
* SpliceChannel --
| > > > | 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 |
* TIP #218, Channel Thread Actions
* For all transformations and the base channel.
*/
for (; chanPtr != NULL ; chanPtr = chanPtr->upChanPtr) {
ChanThreadAction(chanPtr, TCL_CHANNEL_THREAD_REMOVE);
}
/* Channel is not managed by any thread */
statePtr->managingThread = NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SpliceChannel --
* SpliceChannel --
|
| ︙ | ︙ | |||
3369 3370 3371 3372 3373 3374 3375 | * However, it may continue to exist for a while longer if it has a * background flush scheduled. The device itself is eventually closed and * the channel record removed, in CloseChannel, above. * *---------------------------------------------------------------------- */ | < | | 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 |
* However, it may continue to exist for a while longer if it has a
* background flush scheduled. The device itself is eventually closed and
* the channel record removed, in CloseChannel, above.
*
*----------------------------------------------------------------------
*/
int
Tcl_Close(
Tcl_Interp *interp, /* Interpreter for errors. */
Tcl_Channel chan) /* The channel being closed. Must not be
* referenced in any interpreter. */
{
CloseCallback *cbPtr; /* Iterate over close callbacks for this
* channel. */
Channel *chanPtr; /* The real IO channel. */
ChannelState *statePtr; /* State of real IO channel. */
int result = 0; /* Of calling FlushChannel. */
int flushcode;
int stickyError;
if (chan == NULL) {
return TCL_OK;
}
|
| ︙ | ︙ | |||
3406 3407 3408 3409 3410 3411 3412 |
* This operation should occur at the top of a channel stack.
*/
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
| | | 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 |
* This operation should occur at the top of a channel stack.
*/
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
if (statePtr->refCount > 0) {
Tcl_Panic("called Tcl_Close on channel with refCount > 0");
}
if (GotFlag(statePtr, CHANNEL_INCLOSE)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"illegal recursive call to close through close-handler"
|
| ︙ | ︙ | |||
3471 3472 3473 3474 3475 3476 3477 |
* Invoke the registered close callbacks and delete their records.
*/
while (statePtr->closeCbPtr != NULL) {
cbPtr = statePtr->closeCbPtr;
statePtr->closeCbPtr = cbPtr->nextPtr;
cbPtr->proc(cbPtr->clientData);
| | > | > | < > > > > | > > > | 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 |
* Invoke the registered close callbacks and delete their records.
*/
while (statePtr->closeCbPtr != NULL) {
cbPtr = statePtr->closeCbPtr;
statePtr->closeCbPtr = cbPtr->nextPtr;
cbPtr->proc(cbPtr->clientData);
ckfree(cbPtr);
}
ResetFlag(statePtr, CHANNEL_INCLOSE);
/*
* If this channel supports it, close the read side, since we don't need
* it anymore and this will help avoid deadlocks on some channel types.
*/
#ifndef TCL_NO_DEPRECATED
if ((chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) || (chanPtr->typePtr->closeProc == NULL)) {
/* If this half-close gives a EINVAL or ENOTCONN, just continue the full close */
result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, TCL_CLOSE_READ);
if ((result == EINVAL) || result == ENOTCONN) {
result = 0;
}
}
#else
result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, TCL_CLOSE_READ);
if ((result == EINVAL) || result == ENOTCONN) {
result = 0;
}
#endif
/*
* The call to FlushChannel will flush any queued output and invoke the
* close function of the channel driver, or it will set up the channel to
* be flushed and closed asynchronously.
*/
|
| ︙ | ︙ | |||
3529 3530 3531 3532 3533 3534 3535 |
}
/*
* Bug 97069ea11a: set error message if a flush code is set and no error
* message set up to now.
*/
| | > > > > | | | | | < < < < < > > > > > > > > > > | | 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 |
}
/*
* Bug 97069ea11a: set error message if a flush code is set and no error
* message set up to now.
*/
if (flushcode != 0) {
/* flushcode has precedence, if available */
result = flushcode;
}
if ((result != 0) && (result != TCL_ERROR) && (interp != NULL)
&& 0 == Tcl_GetCharLength(Tcl_GetObjResult(interp))) {
Tcl_SetErrno(result);
Tcl_SetObjResult(interp,
Tcl_NewStringObj(Tcl_PosixError(interp), -1));
}
if (result != 0) {
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CloseEx --
*
* Closes one side of a channel, read or write, close all.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Closes one direction of the channel, or do a full close.
*
* NOTE:
* Tcl_CloseEx closes the specified direction of the channel as far as
* the user is concerned. If flags = 0, this is equivalent to Tcl_Close.
*
*----------------------------------------------------------------------
*/
int
Tcl_CloseEx(
Tcl_Interp *interp, /* Interpreter for errors. */
Tcl_Channel chan, /* The channel being closed. May still be used
* by some interpreter. */
int flags) /* Flags telling us which side to close. */
{
Channel *chanPtr; /* The real IO channel. */
ChannelState *statePtr; /* State of real IO channel. */
if (chan == NULL) {
return TCL_OK;
}
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
if ((flags & (TCL_READABLE | TCL_WRITABLE)) == 0) {
return Tcl_Close(interp, chan);
}
if ((flags & (TCL_READABLE | TCL_WRITABLE)) == (TCL_READABLE | TCL_WRITABLE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"double-close of channels not supported by %ss",
chanPtr->typePtr->typeName));
return TCL_ERROR;
}
/*
* Does the channel support half-close anyway? Error if not.
*/
if (!chanPtr->typePtr->close2Proc) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"half-close of channels not supported by %ss",
chanPtr->typePtr->typeName));
return TCL_ERROR;
}
/*
* Is the channel unstacked ? If not we fail.
*/
|
| ︙ | ︙ | |||
3825 3826 3827 3828 3829 3830 3831 |
/*
* Finally do what is asked of us. Close and free the channel driver state
* for the chosen side of the channel. This may leave a TIP #219 error
* message in the interp.
*/
| | | 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 |
/*
* Finally do what is asked of us. Close and free the channel driver state
* for the chosen side of the channel. This may leave a TIP #219 error
* message in the interp.
*/
result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, NULL, flags);
/*
* If we are being called synchronously, report either any latent error on
* the channel or the current error.
*/
if (statePtr->unreportedError != 0) {
|
| ︙ | ︙ | |||
3941 3942 3943 3944 3945 3946 3947 |
/*
* Remove all the channel handler records attached to the channel itself.
*/
for (chPtr = statePtr->chPtr; chPtr != NULL; chPtr = chNext) {
chNext = chPtr->nextPtr;
| | | 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 |
/*
* Remove all the channel handler records attached to the channel itself.
*/
for (chPtr = statePtr->chPtr; chPtr != NULL; chPtr = chNext) {
chNext = chPtr->nextPtr;
ckfree(chPtr);
}
statePtr->chPtr = NULL;
/*
* Cancel any pending copy operation.
*/
|
| ︙ | ︙ | |||
3968 3969 3970 3971 3972 3973 3974 |
/*
* Remove any EventScript records for this channel.
*/
for (ePtr = statePtr->scriptRecordPtr; ePtr != NULL; ePtr = eNextPtr) {
eNextPtr = ePtr->nextPtr;
TclDecrRefCount(ePtr->scriptPtr);
| | | | | | | | | | | | | | | < | | | | | | | | | | | 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 |
/*
* Remove any EventScript records for this channel.
*/
for (ePtr = statePtr->scriptRecordPtr; ePtr != NULL; ePtr = eNextPtr) {
eNextPtr = ePtr->nextPtr;
TclDecrRefCount(ePtr->scriptPtr);
ckfree(ePtr);
}
statePtr->scriptRecordPtr = NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Write --
*
* Puts a sequence of bytes into an output buffer, may queue the buffer
* for output if it gets full, and also remembers whether the current
* buffer is ready e.g. if it contains a newline and we are in line
* buffering mode. Compensates stacking, i.e. will redirect the data from
* the specified channel to the topmost channel in a stack.
*
* No encoding conversions are applied to the bytes being read.
*
* Results:
* The number of bytes written or -1 in case of error. If -1,
* Tcl_GetErrno will return the error code.
*
* Side effects:
* May buffer up output and may cause output to be produced on the
* channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_Write(
Tcl_Channel chan, /* The channel to buffer output for. */
const char *src, /* Data to queue in output buffer. */
int srcLen) /* Length of data in bytes, or < 0 for
* strlen(). */
{
/*
* Always use the topmost channel of the stack
*/
Channel *chanPtr;
ChannelState *statePtr; /* State info for channel */
statePtr = ((Channel *) chan)->state;
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
return -1;
}
if (srcLen < 0) {
srcLen = strlen(src);
}
if (WriteBytes(chanPtr, src, srcLen) < 0) {
return -1;
}
return srcLen;
}
/*
*----------------------------------------------------------------------
*
* Tcl_WriteRaw --
*
* Puts a sequence of bytes into an output buffer, may queue the buffer
* for output if it gets full, and also remembers whether the current
* buffer is ready e.g. if it contains a newline and we are in line
* buffering mode. Writes directly to the driver of the channel, does not
* compensate for stacking.
*
* No encoding conversions are applied to the bytes being read.
*
* Results:
* The number of bytes written or -1 in case of error. If -1,
* Tcl_GetErrno will return the error code.
*
* Side effects:
* May buffer up output and may cause output to be produced on the
* channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_WriteRaw(
Tcl_Channel chan, /* The channel to buffer output for. */
const char *src, /* Data to queue in output buffer. */
int srcLen) /* Length of data in bytes, or < 0 for
* strlen(). */
{
Channel *chanPtr = ((Channel *) chan);
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
int errorCode, written;
if (CheckChannelErrors(statePtr, TCL_WRITABLE | CHANNEL_RAW_MODE) != 0) {
return -1;
}
if (srcLen < 0) {
srcLen = strlen(src);
}
/*
* Go immediately to the driver, do all the error handling by ourselves.
* The code was stolen from 'FlushChannel'.
*/
written = ChanWrite(chanPtr, src, srcLen, &errorCode);
if (written < 0) {
Tcl_SetErrno(errorCode);
}
return written;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_WriteChars --
*
* Takes a sequence of UTF-8 characters and converts them for output
* using the channel's current encoding, may queue the buffer for output
* if it gets full, and also remembers whether the current buffer is
* ready e.g. if it contains a newline and we are in line buffering
* mode. Compensates stacking, i.e. will redirect the data from the
* specified channel to the topmost channel in a stack.
*
* Results:
* The number of bytes written or -1 in case of error. If -1,
* Tcl_GetErrno will return the error code.
*
* Side effects:
* May buffer up output and may cause output to be produced on the
* channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_WriteChars(
Tcl_Channel chan, /* The channel to buffer output for. */
const char *src, /* UTF-8 characters to queue in output
* buffer. */
int len) /* Length of string in bytes, or < 0 for
* strlen(). */
{
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state; /* State info for channel */
int result;
Tcl_Obj *objPtr;
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
return -1;
}
chanPtr = statePtr->topChanPtr;
if (len < 0) {
len = strlen(src);
}
if (statePtr->encoding) {
return WriteChars(chanPtr, src, len);
}
/*
* Inefficient way to convert UTF-8 to byte-array, but the code
* parallels the way it is done for objects. Special case for 1-byte
* (used by eg [puts] for the \n) could be extended to more efficient
* translation of the src string.
*/
if ((len == 1) && (UCHAR(*src) < 0xC0)) {
return WriteBytes(chanPtr, src, len);
}
objPtr = Tcl_NewStringObj(src, len);
src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len);
result = WriteBytes(chanPtr, src, len);
TclDecrRefCount(objPtr);
return result;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
4177 4178 4179 4180 4181 4182 4183 | * Side effects: * May buffer up output and may cause output to be produced on the * channel. * *---------------------------------------------------------------------- */ | | | | | > > | > | | | | | | | > > | > | | | | | 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 |
* Side effects:
* May buffer up output and may cause output to be produced on the
* channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_WriteObj(
Tcl_Channel chan, /* The channel to buffer output for. */
Tcl_Obj *objPtr) /* The object to write. */
{
/*
* Always use the topmost channel of the stack
*/
Channel *chanPtr;
ChannelState *statePtr; /* State info for channel */
const char *src;
int srcLen;
statePtr = ((Channel *) chan)->state;
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_WRITABLE) != 0) {
return -1;
}
if (statePtr->encoding == NULL) {
src = (char *) Tcl_GetByteArrayFromObj(objPtr, &srcLen);
return WriteBytes(chanPtr, src, srcLen);
} else {
src = TclGetStringFromObj(objPtr, &srcLen);
return WriteChars(chanPtr, src, srcLen);
}
}
static void
WillWrite(
Channel *chanPtr)
{
int inputBuffered;
if (((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL)
#ifndef TCL_NO_DEPRECATED
|| (Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL)
#endif
) && ((inputBuffered = Tcl_InputBuffered((Tcl_Channel) chanPtr)) > 0)){
int ignore;
DiscardInputQueued(chanPtr->state, 0);
ChanSeek(chanPtr, -inputBuffered, SEEK_CUR, &ignore);
}
}
static int
WillRead(
Channel *chanPtr)
{
if (chanPtr->typePtr == NULL) {
/*
* Prevent read attempts on a closed channel.
*/
DiscardInputQueued(chanPtr->state, 0);
Tcl_SetErrno(EINVAL);
return -1;
}
if (((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL)
#ifndef TCL_NO_DEPRECATED
|| (Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL)
#endif
) && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) {
/*
* CAVEAT - The assumption here is that FlushChannel() will push out
* the bytes of any writes that are in progress. Since this is a
* seekable channel, we assume it is not one that can block and force
* bg flushing. Channels we know that can do that - sockets, pipes -
* are not seekable. If the assumption is wrong, more drastic measures
* may be required here like temporarily setting the channel into
* blocking mode.
*/
if (FlushChannel(NULL, chanPtr, 0) != 0) {
return -1;
}
}
return 0;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4298 4299 4300 4301 4302 4303 4304 |
* Write the terminated escape sequence even if srcLen is 0.
*/
endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0);
if (GotFlag(statePtr, CHANNEL_LINEBUFFERED)
|| (statePtr->outputTranslation != TCL_TRANSLATE_LF)) {
| | | 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 |
* Write the terminated escape sequence even if srcLen is 0.
*/
endEncoding = ((statePtr->outputEncodingFlags & TCL_ENCODING_END) != 0);
if (GotFlag(statePtr, CHANNEL_LINEBUFFERED)
|| (statePtr->outputTranslation != TCL_TRANSLATE_LF)) {
nextNewLine = (char *)memchr(src, '\n', srcLen);
}
while (srcLen + saved + endEncoding > 0) {
ChannelBuffer *bufPtr;
char *dst, safe[BUFFER_PADDING];
int result, srcRead, dstLen, dstWrote, srcLimit = srcLen;
|
| ︙ | ︙ | |||
4336 4337 4338 4339 4340 4341 4342 | result = Tcl_UtfToExternal(NULL, encoding, src, srcLimit, statePtr->outputEncodingFlags, &statePtr->outputEncodingState, dst, dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); /* | | | | | | 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 |
result = Tcl_UtfToExternal(NULL, encoding, src, srcLimit,
statePtr->outputEncodingFlags,
&statePtr->outputEncodingState, dst,
dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL);
/*
* See chan-io-1.[89]. Tcl Bug 506297.
*/
statePtr->outputEncodingFlags &= ~TCL_ENCODING_START;
if ((result != TCL_OK) && (srcRead + dstWrote == 0)) {
/*
* We're reading from invalid/incomplete UTF-8.
*/
ReleaseChannelBuffer(bufPtr);
if (total == 0) {
Tcl_SetErrno(EINVAL);
return -1;
}
break;
|
| ︙ | ︙ | |||
4396 4397 4398 4399 4400 4401 4402 | bufPtr->nextAdded += dstWrote; src++; srcLen--; total += dstWrote; dst += dstWrote; dstLen -= dstWrote; | | | | 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 |
bufPtr->nextAdded += dstWrote;
src++;
srcLen--;
total += dstWrote;
dst += dstWrote;
dstLen -= dstWrote;
nextNewLine = (char *)memchr(src, '\n', srcLen);
needNlFlush = 1;
}
if (IsBufferOverflowing(bufPtr)) {
/*
* When translating from UTF-8 to external encoding, we allowed
* the translation to produce a character that crossed the end of
* the output buffer, so that we would get a completely full
* buffer before flushing it. The extra bytes will be moved to the
* beginning of the next buffer.
*/
saved = -SpaceLeft(bufPtr);
memcpy(safe, dst + dstLen, saved);
bufPtr->nextAdded = bufPtr->bufLength;
}
if ((srcLen + saved == 0) && (result == TCL_OK)) {
endEncoding = 0;
}
|
| ︙ | ︙ | |||
4473 4474 4475 4476 4477 4478 4479 | * Side effects: * May flush output on the channel. May cause input to be consumed from * the channel. * *--------------------------------------------------------------------------- */ | | | | | 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 |
* Side effects:
* May flush output on the channel. May cause input to be consumed from
* the channel.
*
*---------------------------------------------------------------------------
*/
int
Tcl_Gets(
Tcl_Channel chan, /* Channel from which to read. */
Tcl_DString *lineRead) /* The line read will be appended to this
* DString as UTF-8 characters. The caller
* must have initialized it and is responsible
* for managing the storage. */
{
Tcl_Obj *objPtr;
int charsStored;
TclNewObj(objPtr);
charsStored = Tcl_GetsObj(chan, objPtr);
if (charsStored > 0) {
TclDStringAppendObj(lineRead, objPtr);
}
TclDecrRefCount(objPtr);
return charsStored;
}
/*
|
| ︙ | ︙ | |||
4516 4517 4518 4519 4520 4521 4522 | * * On reading EOF, leave channel pointing at EOF char. On reading EOL, * leave channel pointing after EOL, but don't return EOL in dst buffer. * *--------------------------------------------------------------------------- */ | | | < | | | 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 |
*
* On reading EOF, leave channel pointing at EOF char. On reading EOL,
* leave channel pointing after EOL, but don't return EOL in dst buffer.
*
*---------------------------------------------------------------------------
*/
int
Tcl_GetsObj(
Tcl_Channel chan, /* Channel from which to read. */
Tcl_Obj *objPtr) /* The line read will be appended to this
* object as UTF-8 characters. */
{
GetsState gs;
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
ChannelBuffer *bufPtr;
int inEofChar, skip, copiedTotal, oldLength, oldFlags, oldRemoved;
Tcl_Encoding encoding;
char *dst, *dstEnd, *eol, *eof;
Tcl_EncodingState oldState;
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
return -1;
}
/*
* If we're sitting ready to read the eofchar, there's no need to
* do it.
*/
if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) {
SetFlag(statePtr, CHANNEL_EOF);
assert(statePtr->inputEncodingFlags & TCL_ENCODING_END);
assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR));
/* TODO: Do we need this? */
UpdateInterest(chanPtr);
return -1;
}
/*
* A binary version of Tcl_GetsObj. This could also handle encodings that
* are ascii-7 pure (iso8859, utf-8, ...) with a final encoding conversion
* done on objPtr.
*/
|
| ︙ | ︙ | |||
4579 4580 4581 4582 4583 4584 4585 |
encoding = statePtr->encoding;
/*
* Preserved so we can restore the channel's state in case we don't find a
* newline in the available input.
*/
| | | 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 |
encoding = statePtr->encoding;
/*
* Preserved so we can restore the channel's state in case we don't find a
* newline in the available input.
*/
TclGetStringFromObj(objPtr, &oldLength);
oldFlags = statePtr->inputEncodingFlags;
oldState = statePtr->inputEncodingState;
oldRemoved = BUFFER_PADDING;
if (bufPtr != NULL) {
oldRemoved = bufPtr->nextRemoved;
}
|
| ︙ | ︙ | |||
4676 4677 4678 4679 4680 4681 4682 |
/*
* If a CR is at the end of the buffer, then check for a
* LF at the begining of the next buffer, unless EOF char
* was found already.
*/
if (eol >= dstEnd) {
| | | 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 |
/*
* If a CR is at the end of the buffer, then check for a
* LF at the begining of the next buffer, unless EOF char
* was found already.
*/
if (eol >= dstEnd) {
int offset;
if (eol != eof) {
offset = eol - objPtr->bytes;
dst = dstEnd;
if (FilterInputBytes(chanPtr, &gs) != 0) {
goto restore;
}
|
| ︙ | ︙ | |||
4710 4711 4712 4713 4714 4715 4716 |
if (GotFlag(statePtr, INPUT_SAW_CR)) {
ResetFlag(statePtr, INPUT_SAW_CR);
if ((eol < dstEnd) && (*eol == '\n')) {
/*
* Skip the raw bytes that make up the '\n'.
*/
| < > | | | 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 |
if (GotFlag(statePtr, INPUT_SAW_CR)) {
ResetFlag(statePtr, INPUT_SAW_CR);
if ((eol < dstEnd) && (*eol == '\n')) {
/*
* Skip the raw bytes that make up the '\n'.
*/
int rawRead;
char tmp[TCL_UTF_MAX];
bufPtr = gs.bufPtr;
Tcl_ExternalToUtf(NULL, gs.encoding, RemovePoint(bufPtr),
gs.rawRead, statePtr->inputEncodingFlags
| TCL_ENCODING_NO_TERMINATE, &gs.state, tmp,
sizeof(tmp), &rawRead, NULL, NULL);
bufPtr->nextRemoved += rawRead;
gs.rawRead -= rawRead;
gs.bytesWrote--;
gs.charsWrote--;
memmove(dst, dst + 1, (size_t) (dstEnd - dst));
dstEnd--;
}
}
for (eol = dst; eol < dstEnd; eol++) {
if (*eol == '\r') {
eol++;
if (eol == dstEnd) {
|
| ︙ | ︙ | |||
4943 4944 4945 4946 4947 4948 4949 |
Tcl_Obj *objPtr) /* The line read will be appended to this
* object as UTF-8 characters. */
{
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
ChannelBuffer *bufPtr;
| | | < | | 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 |
Tcl_Obj *objPtr) /* The line read will be appended to this
* object as UTF-8 characters. */
{
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
ChannelBuffer *bufPtr;
int inEofChar, skip, copiedTotal, oldLength, oldFlags, oldRemoved;
int rawLen, byteLen, eolChar;
unsigned char *dst, *dstEnd, *eol, *eof, *byteArray;
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = statePtr->topChanPtr;
TclChannelPreserve((Tcl_Channel)chanPtr);
bufPtr = statePtr->inQueueHead;
/*
* Preserved so we can restore the channel's state in case we don't find a
* newline in the available input.
*/
byteArray = Tcl_GetByteArrayFromObj(objPtr, &byteLen);
oldFlags = statePtr->inputEncodingFlags;
oldRemoved = BUFFER_PADDING;
oldLength = byteLen;
if (bufPtr != NULL) {
oldRemoved = bufPtr->nextRemoved;
}
|
| ︙ | ︙ | |||
5197 5198 5199 5200 5201 5202 5203 | * None. * *--------------------------------------------------------------------------- */ static void FreeBinaryEncoding( | | | | 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 |
* None.
*
*---------------------------------------------------------------------------
*/
static void
FreeBinaryEncoding(
TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->binaryEncoding != NULL) {
Tcl_FreeEncoding(tsdPtr->binaryEncoding);
tsdPtr->binaryEncoding = NULL;
}
}
static Tcl_Encoding
GetBinaryEncoding(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->binaryEncoding == NULL) {
tsdPtr->binaryEncoding = Tcl_GetEncoding(NULL, "iso8859-1");
Tcl_CreateThreadExitHandler(FreeBinaryEncoding, NULL);
}
|
| ︙ | ︙ | |||
5405 5406 5407 5408 5409 5410 5411 |
if (nextPtr == NULL) {
nextPtr = AllocChannelBuffer(statePtr->bufSize);
bufPtr->nextPtr = nextPtr;
statePtr->inQueueTail = nextPtr;
}
extra = rawLen - gsPtr->rawRead;
memcpy(nextPtr->buf + (BUFFER_PADDING - extra),
| | | 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 5445 5446 5447 5448 |
if (nextPtr == NULL) {
nextPtr = AllocChannelBuffer(statePtr->bufSize);
bufPtr->nextPtr = nextPtr;
statePtr->inQueueTail = nextPtr;
}
extra = rawLen - gsPtr->rawRead;
memcpy(nextPtr->buf + (BUFFER_PADDING - extra),
raw + gsPtr->rawRead, (size_t) extra);
nextPtr->nextRemoved -= extra;
bufPtr->nextAdded -= extra;
}
}
gsPtr->bufPtr = bufPtr;
return 0;
|
| ︙ | ︙ | |||
5585 5586 5587 5588 5589 5590 5591 | * * Side effects: * May cause input to be buffered. * *---------------------------------------------------------------------- */ | | | | | 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 |
*
* Side effects:
* May cause input to be buffered.
*
*----------------------------------------------------------------------
*/
int
Tcl_Read(
Tcl_Channel chan, /* The channel from which to read. */
char *dst, /* Where to store input read. */
int bytesToRead) /* Maximum number of bytes to read. */
{
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
/*
* This operation should occur at the top of a channel stack.
*/
chanPtr = statePtr->topChanPtr;
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
return -1;
}
return DoRead(chanPtr, dst, bytesToRead, 0);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
5630 5631 5632 5633 5634 5635 5636 | * * Side effects: * May cause input to be buffered. * *---------------------------------------------------------------------- */ | | | | | | | | | 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 |
*
* Side effects:
* May cause input to be buffered.
*
*----------------------------------------------------------------------
*/
int
Tcl_ReadRaw(
Tcl_Channel chan, /* The channel from which to read. */
char *readBuf, /* Where to store input read. */
int bytesToRead) /* Maximum number of bytes to read. */
{
Channel *chanPtr = (Channel *) chan;
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
int copied = 0;
assert(bytesToRead > 0);
if (CheckChannelErrors(statePtr, TCL_READABLE | CHANNEL_RAW_MODE) != 0) {
return -1;
}
/*
* First read bytes from the push-back buffers.
*/
while (chanPtr->inQueueHead && bytesToRead > 0) {
ChannelBuffer *bufPtr = chanPtr->inQueueHead;
int bytesInBuffer = BytesLeft(bufPtr);
int toCopy = (bytesInBuffer < bytesToRead) ? bytesInBuffer
: bytesToRead;
/*
* Copy the current chunk into the read buffer.
*/
memcpy(readBuf, RemovePoint(bufPtr), toCopy);
bufPtr->nextRemoved += toCopy;
copied += toCopy;
readBuf += toCopy;
bytesToRead -= toCopy;
|
| ︙ | ︙ | |||
5697 5698 5699 5700 5701 5702 5703 |
/*
* This test not needed.
*/
if (bytesToRead > 0) {
int nread = ChanRead(chanPtr, readBuf, bytesToRead);
| | > > > > > > < < < < < < | 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 |
/*
* This test not needed.
*/
if (bytesToRead > 0) {
int nread = ChanRead(chanPtr, readBuf, bytesToRead);
if (nread > 0) {
/*
* Successful read (short is OK) - add to bytes copied.
*/
copied += nread;
} else if (nread < 0) {
/*
* An error signaled. If CHANNEL_BLOCKED, then the error is not
* real, but an indication of blocked state. In that case, retain
* the flag and let caller receive the short read of copied bytes
* from the pushback. HOWEVER, if copied==0 bytes from pushback
* then repeat signalling the blocked state as an error to caller
* so there is no false report of an EOF. When !CHANNEL_BLOCKED,
* the error is real and passes on to caller.
*/
if (!GotFlag(statePtr, CHANNEL_BLOCKED) || copied == 0) {
copied = -1;
}
} else {
/*
* nread == 0. Driver is at EOF. Let that state filter up.
*/
}
}
return copied;
|
| ︙ | ︙ | |||
5748 5749 5750 5751 5752 5753 5754 | * * Side effects: * May cause input to be buffered. * *--------------------------------------------------------------------------- */ | | | | 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 |
*
* Side effects:
* May cause input to be buffered.
*
*---------------------------------------------------------------------------
*/
int
Tcl_ReadChars(
Tcl_Channel chan, /* The channel to read. */
Tcl_Obj *objPtr, /* Input data is stored in this object. */
int toRead, /* Maximum number of characters to store, or
* -1 to read all available data (up to EOF or
* when channel blocks). */
int appendFlag) /* If non-zero, data read from the channel
* will be appended to the object. Otherwise,
* the data will replace the existing contents
* of the object. */
{
|
| ︙ | ︙ | |||
5808 5809 5810 5811 5812 5813 5814 |
*---------------------------------------------------------------------------
*/
static int
DoReadChars(
Channel *chanPtr, /* The channel to read. */
Tcl_Obj *objPtr, /* Input data is stored in this object. */
| | | > > > > | 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 5851 5852 5853 5854 5855 5856 5857 5858 5859 5860 5861 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 |
*---------------------------------------------------------------------------
*/
static int
DoReadChars(
Channel *chanPtr, /* The channel to read. */
Tcl_Obj *objPtr, /* Input data is stored in this object. */
int toRead, /* Maximum number of characters to store, or
* -1 to read all available data (up to EOF or
* when channel blocks). */
int appendFlag) /* If non-zero, data read from the channel
* will be appended to the object. Otherwise,
* the data will replace the existing contents
* of the object. */
{
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
ChannelBuffer *bufPtr;
int copied, copiedNow, result;
Tcl_Encoding encoding = statePtr->encoding;
int binaryMode;
#define UTF_EXPANSION_FACTOR 1024
int factor = UTF_EXPANSION_FACTOR;
binaryMode = (encoding == NULL)
&& (statePtr->inputTranslation == TCL_TRANSLATE_LF)
&& (statePtr->inEofChar == '\0');
if (appendFlag) {
if (binaryMode && (NULL == TclGetBytesFromObj(NULL, objPtr, NULL))) {
binaryMode = 0;
}
} else {
if (binaryMode) {
Tcl_SetByteArrayLength(objPtr, 0);
} else {
Tcl_SetObjLength(objPtr, 0);
/*
* We're going to access objPtr->bytes directly, so we must ensure
|
| ︙ | ︙ | |||
5894 5895 5896 5897 5898 5899 5900 |
*/
if (GotFlag(statePtr, CHANNEL_EOF)) {
statePtr->inputEncodingFlags |= TCL_ENCODING_START;
}
ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF);
statePtr->inputEncodingFlags &= ~TCL_ENCODING_END;
| | | 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 |
*/
if (GotFlag(statePtr, CHANNEL_EOF)) {
statePtr->inputEncodingFlags |= TCL_ENCODING_START;
}
ResetFlag(statePtr, CHANNEL_BLOCKED|CHANNEL_EOF);
statePtr->inputEncodingFlags &= ~TCL_ENCODING_END;
for (copied = 0; (unsigned) toRead > 0; ) {
copiedNow = -1;
if (statePtr->inQueueHead != NULL) {
if (binaryMode) {
copiedNow = ReadBytes(statePtr, objPtr, toRead);
} else {
copiedNow = ReadChars(statePtr, objPtr, toRead, &factor);
}
|
| ︙ | ︙ | |||
6012 6013 6014 6015 6016 6017 6018 |
ReadBytes(
ChannelState *statePtr, /* State of the channel to read. */
Tcl_Obj *objPtr, /* Input data is appended to this ByteArray
* object. Its length is how much space has
* been allocated to hold data, not how many
* bytes of data have been stored in the
* object. */
| | | 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 |
ReadBytes(
ChannelState *statePtr, /* State of the channel to read. */
Tcl_Obj *objPtr, /* Input data is appended to this ByteArray
* object. Its length is how much space has
* been allocated to hold data, not how many
* bytes of data have been stored in the
* object. */
int bytesToRead) /* Maximum number of bytes to store, or < 0 to
* get all available bytes. Bytes are obtained
* from the first buffer in the queue - even
* if this number is larger than the number of
* bytes available in the first buffer, only
* the bytes from the first buffer are
* returned. */
{
|
| ︙ | ︙ | |||
6089 6090 6091 6092 6093 6094 6095 |
Tcl_Encoding encoding = statePtr->encoding? statePtr->encoding
: GetBinaryEncoding();
Tcl_EncodingState savedState = statePtr->inputEncodingState;
ChannelBuffer *bufPtr = statePtr->inQueueHead;
int savedIEFlags = statePtr->inputEncodingFlags;
int savedFlags = statePtr->flags;
char *dst, *src = RemovePoint(bufPtr);
| < | | 6122 6123 6124 6125 6126 6127 6128 6129 6130 6131 6132 6133 6134 6135 6136 |
Tcl_Encoding encoding = statePtr->encoding? statePtr->encoding
: GetBinaryEncoding();
Tcl_EncodingState savedState = statePtr->inputEncodingState;
ChannelBuffer *bufPtr = statePtr->inQueueHead;
int savedIEFlags = statePtr->inputEncodingFlags;
int savedFlags = statePtr->flags;
char *dst, *src = RemovePoint(bufPtr);
int numBytes, srcLen = BytesLeft(bufPtr);
/*
* One src byte can yield at most one character. So when the number of
* src bytes we plan to read is less than the limit on character count to
* be read, clearly we will remain within that limit, and we can use the
* value of "srcLen" as a tighter limit for sizing receiving buffers.
*/
|
| ︙ | ︙ | |||
6113 6114 6115 6116 6117 6118 6119 |
int factor = *factorPtr;
int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR;
(void) TclGetStringFromObj(objPtr, &numBytes);
Tcl_AppendToObj(objPtr, NULL, dstLimit);
if (toRead == srcLen) {
| | | 6145 6146 6147 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 |
int factor = *factorPtr;
int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR;
(void) TclGetStringFromObj(objPtr, &numBytes);
Tcl_AppendToObj(objPtr, NULL, dstLimit);
if (toRead == srcLen) {
unsigned int size;
dst = TclGetStringStorage(objPtr, &size) + numBytes;
dstLimit = size - numBytes;
} else {
dst = TclGetString(objPtr) + numBytes;
}
|
| ︙ | ︙ | |||
6265 6266 6267 6268 6269 6270 6271 |
/*
* We decoded only the bare CR, and we cannot read a translated
* char from that alone. We have to know what's next. So why do
* we only have the one decoded char?
*/
if (code != TCL_OK) {
| < > | | 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 |
/*
* We decoded only the bare CR, and we cannot read a translated
* char from that alone. We have to know what's next. So why do
* we only have the one decoded char?
*/
if (code != TCL_OK) {
int read, decoded, count;
char buffer[TCL_UTF_MAX + 1];
/*
* Didn't get everything the buffer could offer
*/
statePtr->flags = savedFlags;
statePtr->inputEncodingFlags = savedIEFlags;
statePtr->inputEncodingState = savedState;
assert(bufPtr->nextPtr == NULL
|| BytesLeft(bufPtr->nextPtr) == 0 || 0 ==
(statePtr->inputEncodingFlags & TCL_ENCODING_END));
Tcl_ExternalToUtf(NULL, encoding, src, srcLen,
(statePtr->inputEncodingFlags | TCL_ENCODING_NO_TERMINATE),
&statePtr->inputEncodingState, buffer, sizeof(buffer),
&read, &decoded, &count);
if (count == 2) {
if (buffer[1] == '\n') {
/* \r\n translate to \n */
dst[0] = '\n';
bufPtr->nextRemoved += read;
|
| ︙ | ︙ | |||
6352 6353 6354 6355 6356 6357 6358 |
continue;
}
if (dstWrote == 0) {
ChannelBuffer *nextPtr;
/*
| | | | | 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 6399 6400 6401 6402 6403 6404 6405 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 |
continue;
}
if (dstWrote == 0) {
ChannelBuffer *nextPtr;
/*
* We were not able to read any chars.
*/
assert(numChars == 0);
/*
* There is one situation where this is the correct final result.
* If the src buffer contains only a single \n byte, and we are in
* TCL_TRANSLATE_AUTO mode, and when the translation pass was made
* the INPUT_SAW_CR flag was set on the channel. In that case, the
* correct behavior is to consume that \n and produce the empty
* string.
*/
if (dstRead == 1 && dst[0] == '\n') {
assert(statePtr->inputTranslation == TCL_TRANSLATE_AUTO);
goto consume;
}
/*
* Otherwise, reading zero characters indicates there's something
* incomplete at the end of the src buffer. Maybe there were not
* enough src bytes to decode into a char. Maybe a lone \r could
* not be translated (crlf mode). Need to combine any unused src
* bytes we have in the first buffer with subsequent bytes to try
* again.
*/
|
| ︙ | ︙ | |||
6482 6483 6484 6485 6486 6487 6488 |
* This keeps the scan for eof char below from being pointlessly long.
*/
switch (statePtr->inputTranslation) {
case TCL_TRANSLATE_LF:
case TCL_TRANSLATE_CR:
if (srcLen > dstLen) {
| | | | | | | | | | 6514 6515 6516 6517 6518 6519 6520 6521 6522 6523 6524 6525 6526 6527 6528 6529 6530 6531 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 6543 6544 6545 6546 6547 6548 6549 6550 6551 6552 6553 6554 6555 6556 6557 6558 6559 6560 6561 6562 6563 6564 6565 6566 6567 6568 6569 6570 6571 6572 6573 6574 6575 6576 6577 6578 |
* This keeps the scan for eof char below from being pointlessly long.
*/
switch (statePtr->inputTranslation) {
case TCL_TRANSLATE_LF:
case TCL_TRANSLATE_CR:
if (srcLen > dstLen) {
/*
* In these modes, each src byte become a dst byte.
*/
srcLen = dstLen;
}
break;
default:
/*
* In other modes, at most 2 src bytes become a dst byte.
*/
if (srcLen/2 > dstLen) {
srcLen = 2 * dstLen;
}
break;
}
if (inEofChar != '\0') {
/*
* Make sure we do not read past any logical end of channel input
* created by the presence of the input eof char.
*/
if ((eof = (const char *)memchr(srcStart, inEofChar, srcLen))) {
srcLen = eof - srcStart;
}
}
switch (statePtr->inputTranslation) {
case TCL_TRANSLATE_LF:
case TCL_TRANSLATE_CR:
if (dstStart != srcStart) {
memcpy(dstStart, srcStart, srcLen);
}
if (statePtr->inputTranslation == TCL_TRANSLATE_CR) {
char *dst = dstStart;
char *dstEnd = dstStart + srcLen;
while ((dst = (char *)memchr(dst, '\r', dstEnd - dst))) {
*dst++ = '\n';
}
}
dstLen = srcLen;
break;
case TCL_TRANSLATE_CRLF: {
const char *crFound, *src = srcStart;
char *dst = dstStart;
int lesser = (dstLen < srcLen) ? dstLen : srcLen;
while ((crFound = (const char *)memchr(src, '\r', lesser))) {
int numBytes = crFound - src;
memmove(dst, src, numBytes);
dst += numBytes; dstLen -= numBytes;
src += numBytes; srcLen -= numBytes;
if (srcLen == 1) {
/* valid src bytes end in \r */
|
| ︙ | ︙ | |||
6572 6573 6574 6575 6576 6577 6578 |
int lesser;
if ((statePtr->flags & INPUT_SAW_CR) && srcLen) {
if (*src == '\n') { src++; srcLen--; }
ResetFlag(statePtr, INPUT_SAW_CR);
}
lesser = (dstLen < srcLen) ? dstLen : srcLen;
| | | 6604 6605 6606 6607 6608 6609 6610 6611 6612 6613 6614 6615 6616 6617 6618 |
int lesser;
if ((statePtr->flags & INPUT_SAW_CR) && srcLen) {
if (*src == '\n') { src++; srcLen--; }
ResetFlag(statePtr, INPUT_SAW_CR);
}
lesser = (dstLen < srcLen) ? dstLen : srcLen;
while ((crFound = (const char *)memchr(src, '\r', lesser))) {
int numBytes = crFound - src;
memmove(dst, src, numBytes);
dst[numBytes] = '\n';
dst += numBytes + 1; dstLen -= numBytes + 1;
src += numBytes + 1; srcLen -= numBytes + 1;
if (srcLen == 0) {
|
| ︙ | ︙ | |||
6619 6620 6621 6622 6623 6624 6625 | * * Tcl_Ungets -- * * Causes the supplied string to be added to the input queue of the * channel, at either the head or tail of the queue. * * Results: | | | | | 6651 6652 6653 6654 6655 6656 6657 6658 6659 6660 6661 6662 6663 6664 6665 6666 6667 6668 6669 6670 6671 6672 6673 6674 6675 6676 6677 |
*
* Tcl_Ungets --
*
* Causes the supplied string to be added to the input queue of the
* channel, at either the head or tail of the queue.
*
* Results:
* The number of bytes stored in the channel, or -1 on error.
*
* Side effects:
* Adds input to the input queue of a channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_Ungets(
Tcl_Channel chan, /* The channel for which to add the input. */
const char *str, /* The input itself. */
int len, /* The length of the input. */
int atEnd) /* If non-zero, add at end of queue; otherwise
* add at head of queue. */
{
Channel *chanPtr; /* The real IO channel. */
ChannelState *statePtr; /* State of actual channel. */
ChannelBuffer *bufPtr; /* Buffer to contain the data. */
int flags;
|
| ︙ | ︙ | |||
6655 6656 6657 6658 6659 6660 6661 |
/*
* CheckChannelErrors clears too many flag bits in this one case.
*/
flags = statePtr->flags;
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
| | | 6687 6688 6689 6690 6691 6692 6693 6694 6695 6696 6697 6698 6699 6700 6701 |
/*
* CheckChannelErrors clears too many flag bits in this one case.
*/
flags = statePtr->flags;
if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) {
len = -1;
goto done;
}
statePtr->flags = flags;
/*
* Clear the EOF flags, and clear the BLOCKED bit.
*/
|
| ︙ | ︙ | |||
6997 6998 6999 7000 7001 7002 7003 |
chanPtr = statePtr->topChanPtr;
/*
* Disallow seek on channels whose type does not have a seek procedure
* defined. This means that the channel does not support seeking.
*/
| > > | > > | 7029 7030 7031 7032 7033 7034 7035 7036 7037 7038 7039 7040 7041 7042 7043 7044 7045 7046 7047 |
chanPtr = statePtr->topChanPtr;
/*
* Disallow seek on channels whose type does not have a seek procedure
* defined. This means that the channel does not support seeking.
*/
if ((Tcl_ChannelWideSeekProc(chanPtr->typePtr) == NULL)
#ifndef TCL_NO_DEPRECATED
&& (Tcl_ChannelSeekProc(chanPtr->typePtr) == NULL)
#endif
) {
Tcl_SetErrno(EINVAL);
return -1;
}
/*
* Compute how much input and output is buffered. If both input and output
* is buffered, cannot compute the current position.
|
| ︙ | ︙ | |||
7161 7162 7163 7164 7165 7166 7167 |
chanPtr = statePtr->topChanPtr;
/*
* Disallow tell on channels whose type does not have a seek procedure
* defined. This means that the channel does not support seeking.
*/
| > > | > > | 7197 7198 7199 7200 7201 7202 7203 7204 7205 7206 7207 7208 7209 7210 7211 7212 7213 7214 7215 |
chanPtr = statePtr->topChanPtr;
/*
* Disallow tell on channels whose type does not have a seek procedure
* defined. This means that the channel does not support seeking.
*/
if ((Tcl_ChannelWideSeekProc(chanPtr->typePtr) == NULL)
#ifndef TCL_NO_DEPRECATED
&& (Tcl_ChannelSeekProc(chanPtr->typePtr) == NULL)
#endif
) {
Tcl_SetErrno(EINVAL);
return -1;
}
/*
* Compute how much input and output is buffered. If both input and output
* is buffered, cannot compute the current position.
|
| ︙ | ︙ | |||
7247 7248 7249 7250 7251 7252 7253 |
/*
* Seek first to force a total flush of all pending buffers and ditch any
* pre-read input data.
*/
WillWrite(chanPtr);
| | | 7287 7288 7289 7290 7291 7292 7293 7294 7295 7296 7297 7298 7299 7300 7301 |
/*
* Seek first to force a total flush of all pending buffers and ditch any
* pre-read input data.
*/
WillWrite(chanPtr);
if (WillRead(chanPtr) < 0) {
return TCL_ERROR;
}
/*
* We're all flushed to disk now and we also don't have any unfortunate
* input baggage around either; can truncate with impunity.
*/
|
| ︙ | ︙ | |||
7480 7481 7482 7483 7484 7485 7486 |
int bytesBuffered;
for (bytesBuffered = 0, bufPtr = statePtr->outQueueHead; bufPtr != NULL;
bufPtr = bufPtr->nextPtr) {
bytesBuffered += BytesLeft(bufPtr);
}
if (statePtr->curOutPtr != NULL) {
| | | 7520 7521 7522 7523 7524 7525 7526 7527 7528 7529 7530 7531 7532 7533 7534 |
int bytesBuffered;
for (bytesBuffered = 0, bufPtr = statePtr->outQueueHead; bufPtr != NULL;
bufPtr = bufPtr->nextPtr) {
bytesBuffered += BytesLeft(bufPtr);
}
if (statePtr->curOutPtr != NULL) {
ChannelBuffer *curOutPtr = statePtr->curOutPtr;
if (IsBufferReady(curOutPtr)) {
bytesBuffered += BytesLeft(curOutPtr);
}
}
return bytesBuffered;
|
| ︙ | ︙ | |||
7675 7676 7677 7678 7679 7680 7681 |
argc--;
for (i = 0; i < argc; i++) {
Tcl_AppendPrintfToObj(errObj, "-%s, ", argv[i]);
}
Tcl_AppendPrintfToObj(errObj, "or -%s", argv[i]);
Tcl_SetObjResult(interp, errObj);
Tcl_DStringFree(&ds);
| | | 7715 7716 7717 7718 7719 7720 7721 7722 7723 7724 7725 7726 7727 7728 7729 |
argc--;
for (i = 0; i < argc; i++) {
Tcl_AppendPrintfToObj(errObj, "-%s, ", argv[i]);
}
Tcl_AppendPrintfToObj(errObj, "or -%s", argv[i]);
Tcl_SetObjResult(interp, errObj);
Tcl_DStringFree(&ds);
ckfree(argv);
}
Tcl_SetErrno(EINVAL);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
8066 8067 8068 8069 8070 8071 8072 |
if (inValue & 0x80 || outValue & 0x80) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -eofchar: must be non-NUL ASCII"
" character", -1));
}
| | | | | 8106 8107 8108 8109 8110 8111 8112 8113 8114 8115 8116 8117 8118 8119 8120 8121 8122 8123 8124 8125 8126 8127 8128 8129 8130 8131 8132 8133 8134 8135 8136 8137 8138 8139 |
if (inValue & 0x80 || outValue & 0x80) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -eofchar: must be non-NUL ASCII"
" character", -1));
}
ckfree(argv);
return TCL_ERROR;
}
if (GotFlag(statePtr, TCL_READABLE)) {
statePtr->inEofChar = inValue;
}
if (GotFlag(statePtr, TCL_WRITABLE)) {
statePtr->outEofChar = outValue;
}
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -eofchar: should be a list of zero,"
" one, or two elements", -1));
}
ckfree(argv);
return TCL_ERROR;
}
if (argv != NULL) {
ckfree(argv);
}
/*
* [Bug 930851] Reset EOF and BLOCKED flags. Changing the character
* which signals eof can transform a current eof condition into a 'go
* ahead'. Ditto for blocked.
*/
|
| ︙ | ︙ | |||
8119 8120 8121 8122 8123 8124 8125 |
writeMode = GotFlag(statePtr, TCL_WRITABLE) ? argv[1] : NULL;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be a one or two"
" element list", -1));
}
| | | 8159 8160 8161 8162 8163 8164 8165 8166 8167 8168 8169 8170 8171 8172 8173 |
writeMode = GotFlag(statePtr, TCL_WRITABLE) ? argv[1] : NULL;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be a one or two"
" element list", -1));
}
ckfree(argv);
return TCL_ERROR;
}
if (readMode) {
TclEolTranslation translation;
if (*readMode == '\0') {
|
| ︙ | ︙ | |||
8149 8150 8151 8152 8153 8154 8155 |
translation = TCL_PLATFORM_TRANSLATION;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be one of "
"auto, binary, cr, lf, crlf, or platform", -1));
}
| | | 8189 8190 8191 8192 8193 8194 8195 8196 8197 8198 8199 8200 8201 8202 8203 |
translation = TCL_PLATFORM_TRANSLATION;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be one of "
"auto, binary, cr, lf, crlf, or platform", -1));
}
ckfree(argv);
return TCL_ERROR;
}
/*
* Reset the EOL flags since we need to look at any buffered data
* to see if the new translation mode allows us to complete the
* line.
|
| ︙ | ︙ | |||
8199 8200 8201 8202 8203 8204 8205 |
statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be one of "
"auto, binary, cr, lf, crlf, or platform", -1));
}
| | | | 8239 8240 8241 8242 8243 8244 8245 8246 8247 8248 8249 8250 8251 8252 8253 8254 8255 8256 8257 |
statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION;
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -translation: must be one of "
"auto, binary, cr, lf, crlf, or platform", -1));
}
ckfree(argv);
return TCL_ERROR;
}
}
ckfree(argv);
return TCL_OK;
} else if (chanPtr->typePtr->setOptionProc != NULL) {
return chanPtr->typePtr->setOptionProc(chanPtr->instanceData, interp,
optionName, newValue);
} else {
return Tcl_BadChannelOption(interp, optionName, NULL);
}
|
| ︙ | ︙ | |||
8262 8263 8264 8265 8266 8267 8268 | prevPtr->nextPtr = nextPtr; } Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, TclChannelEventScriptInvoker, sPtr); TclDecrRefCount(sPtr->scriptPtr); | | | 8302 8303 8304 8305 8306 8307 8308 8309 8310 8311 8312 8313 8314 8315 8316 |
prevPtr->nextPtr = nextPtr;
}
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, sPtr);
TclDecrRefCount(sPtr->scriptPtr);
ckfree(sPtr);
} else {
prevPtr = sPtr;
}
}
}
/*
|
| ︙ | ︙ | |||
8354 8355 8356 8357 8358 8359 8360 8361 8362 8363 8364 8365 8366 8367 |
* Now call the channel handlers as usual.
*
* Preserve the channel struct in case the script closes it.
*/
TclChannelPreserve((Tcl_Channel)channel);
Tcl_Preserve(statePtr);
/*
* If we are flushing in the background, be sure to call FlushChannel for
* writable events. Note that we have to discard the writable event so we
* don't call any write handlers before the flush is complete.
*/
| > > > > > > > | 8394 8395 8396 8397 8398 8399 8400 8401 8402 8403 8404 8405 8406 8407 8408 8409 8410 8411 8412 8413 8414 |
* Now call the channel handlers as usual.
*
* Preserve the channel struct in case the script closes it.
*/
TclChannelPreserve((Tcl_Channel)channel);
Tcl_Preserve(statePtr);
/*
* Avoid processing if the channel owner has been changed.
*/
if (statePtr->managingThread != Tcl_GetCurrentThread()) {
goto done;
}
/*
* If we are flushing in the background, be sure to call FlushChannel for
* writable events. Note that we have to discard the writable event so we
* don't call any write handlers before the flush is complete.
*/
|
| ︙ | ︙ | |||
8389 8390 8391 8392 8393 8394 8395 8396 8397 8398 8399 8400 8401 8402 8403 8404 8405 8406 8407 8408 8409 8410 8411 8412 8413 8414 8415 8416 8417 8418 8419 |
if ((chPtr->mask & mask) != 0) {
nh.nextHandlerPtr = chPtr->nextPtr;
chPtr->proc(chPtr->clientData, chPtr->mask & mask);
chPtr = nh.nextHandlerPtr;
} else {
chPtr = chPtr->nextPtr;
}
}
/*
* Update the notifier interest, since it may have changed after invoking
* event handlers. Skip that if the channel was deleted in the call to the
* channel handler.
*/
if (chanPtr->typePtr != NULL) {
/*
* TODO: This call may not be needed. If a handler induced a
* change in interest, that handler should have made its own
* UpdateInterest() call, one would think.
*/
UpdateInterest(chanPtr);
}
Tcl_Release(statePtr);
TclChannelRelease(channel);
tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr;
}
/*
| > > > > > > > > | 8436 8437 8438 8439 8440 8441 8442 8443 8444 8445 8446 8447 8448 8449 8450 8451 8452 8453 8454 8455 8456 8457 8458 8459 8460 8461 8462 8463 8464 8465 8466 8467 8468 8469 8470 8471 8472 8473 8474 |
if ((chPtr->mask & mask) != 0) {
nh.nextHandlerPtr = chPtr->nextPtr;
chPtr->proc(chPtr->clientData, chPtr->mask & mask);
chPtr = nh.nextHandlerPtr;
} else {
chPtr = chPtr->nextPtr;
}
/*
* Stop if the channel owner has been changed in-between.
*/
if (chanPtr->state->managingThread != Tcl_GetCurrentThread()) {
goto done;
}
}
/*
* Update the notifier interest, since it may have changed after invoking
* event handlers. Skip that if the channel was deleted in the call to the
* channel handler.
*/
if (chanPtr->typePtr != NULL) {
/*
* TODO: This call may not be needed. If a handler induced a
* change in interest, that handler should have made its own
* UpdateInterest() call, one would think.
*/
UpdateInterest(chanPtr);
}
done:
Tcl_Release(statePtr);
TclChannelRelease(channel);
tsdPtr->nestedHandlerPtr = nh.nestedHandlerPtr;
}
/*
|
| ︙ | ︙ | |||
8544 8545 8546 8547 8548 8549 8550 |
*----------------------------------------------------------------------
*/
static void
ChannelTimerProc(
ClientData clientData)
{
| | | 8599 8600 8601 8602 8603 8604 8605 8606 8607 8608 8609 8610 8611 8612 8613 |
*----------------------------------------------------------------------
*/
static void
ChannelTimerProc(
ClientData clientData)
{
Channel *chanPtr = (Channel *)clientData;
ChannelState *statePtr = chanPtr->state;
/* State info for channel */
Tcl_Preserve(statePtr);
statePtr->timer = NULL;
if (statePtr->interestMask & TCL_WRITABLE
&& GotFlag(statePtr, CHANNEL_NONBLOCKING)
|
| ︙ | ︙ | |||
8632 8633 8634 8635 8636 8637 8638 |
for (chPtr = statePtr->chPtr; chPtr != NULL; chPtr = chPtr->nextPtr) {
if ((chPtr->chanPtr == chanPtr) && (chPtr->proc == proc) &&
(chPtr->clientData == clientData)) {
break;
}
}
if (chPtr == NULL) {
| | | 8687 8688 8689 8690 8691 8692 8693 8694 8695 8696 8697 8698 8699 8700 8701 |
for (chPtr = statePtr->chPtr; chPtr != NULL; chPtr = chPtr->nextPtr) {
if ((chPtr->chanPtr == chanPtr) && (chPtr->proc == proc) &&
(chPtr->clientData == clientData)) {
break;
}
}
if (chPtr == NULL) {
chPtr = (ChannelHandler *)ckalloc(sizeof(ChannelHandler));
chPtr->mask = 0;
chPtr->proc = proc;
chPtr->clientData = clientData;
chPtr->chanPtr = chanPtr;
chPtr->nextPtr = statePtr->chPtr;
statePtr->chPtr = chPtr;
}
|
| ︙ | ︙ | |||
8736 8737 8738 8739 8740 8741 8742 |
*/
if (prevChPtr == NULL) {
statePtr->chPtr = chPtr->nextPtr;
} else {
prevChPtr->nextPtr = chPtr->nextPtr;
}
| | | 8791 8792 8793 8794 8795 8796 8797 8798 8799 8800 8801 8802 8803 8804 8805 |
*/
if (prevChPtr == NULL) {
statePtr->chPtr = chPtr->nextPtr;
} else {
prevChPtr->nextPtr = chPtr->nextPtr;
}
ckfree(chPtr);
/*
* Recompute the interest list for the channel, so that infinite loops
* will not result if Tcl_DeleteChannelHandler is called inside an event.
*/
statePtr->interestMask = 0;
|
| ︙ | ︙ | |||
8795 8796 8797 8798 8799 8800 8801 | prevEsPtr->nextPtr = esPtr->nextPtr; } Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, TclChannelEventScriptInvoker, esPtr); TclDecrRefCount(esPtr->scriptPtr); | | | 8850 8851 8852 8853 8854 8855 8856 8857 8858 8859 8860 8861 8862 8863 8864 |
prevEsPtr->nextPtr = esPtr->nextPtr;
}
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, esPtr);
TclDecrRefCount(esPtr->scriptPtr);
ckfree(esPtr);
break;
}
}
}
/*
|
| ︙ | ︙ | |||
8844 8845 8846 8847 8848 8849 8850 |
break;
}
}
makeCH = (esPtr == NULL);
if (makeCH) {
| | | 8899 8900 8901 8902 8903 8904 8905 8906 8907 8908 8909 8910 8911 8912 8913 |
break;
}
}
makeCH = (esPtr == NULL);
if (makeCH) {
esPtr = (EventScriptRecord *)ckalloc(sizeof(EventScriptRecord));
}
/*
* Initialize the structure before calling Tcl_CreateChannelHandler,
* because a reflected channel calling 'chan postevent' aka
* 'Tcl_NotifyChannel' in its 'watch'Proc will invoke
* 'TclChannelEventScriptInvoker' immediately, and we do not wish it to
|
| ︙ | ︙ | |||
8891 8892 8893 8894 8895 8896 8897 |
*
*----------------------------------------------------------------------
*/
void
TclChannelEventScriptInvoker(
ClientData clientData, /* The script+interp record. */
| | > | > > | > | | < > > > | < < | 8946 8947 8948 8949 8950 8951 8952 8953 8954 8955 8956 8957 8958 8959 8960 8961 8962 8963 8964 8965 8966 8967 8968 8969 8970 8971 8972 8973 8974 8975 8976 |
*
*----------------------------------------------------------------------
*/
void
TclChannelEventScriptInvoker(
ClientData clientData, /* The script+interp record. */
TCL_UNUSED(int) /*mask*/)
{
EventScriptRecord *esPtr = (EventScriptRecord *)clientData;
/* The event script + interpreter to eval it
* in. */
Channel *chanPtr = esPtr->chanPtr;
/* The channel for which this handler is
* registered. */
Tcl_Interp *interp = esPtr->interp;
/* Interpreter in which to eval the script. */
int mask = esPtr->mask;
int result; /* Result of call to eval script. */
/*
* Be sure event executed in managed channel (covering bugs similar [f583715154]).
*/
assert(chanPtr->state->managingThread == Tcl_GetCurrentThread());
/*
* We must preserve the interpreter so we can report errors on it later.
* Note that we do not need to preserve the channel because that is done
* by Tcl_NotifyChannel before calling channel handlers.
*/
|
| ︙ | ︙ | |||
8952 8953 8954 8955 8956 8957 8958 | * * Side effects: * May create a channel handler for the specified channel. * *---------------------------------------------------------------------- */ | < | | 9011 9012 9013 9014 9015 9016 9017 9018 9019 9020 9021 9022 9023 9024 9025 9026 9027 |
*
* Side effects:
* May create a channel handler for the specified channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_FileEventObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which the channel for which
* to create the handler is found. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Channel *chanPtr; /* The channel to create the handler for. */
ChannelState *statePtr; /* State info for channel */
|
| ︙ | ︙ | |||
9054 9055 9056 9057 9058 9059 9060 |
static void
ZeroTransferTimerProc(
ClientData clientData)
{
/* calling CopyData with mask==0 still implies immediate invocation of the
* -command callback, and completion of the fcopy.
*/
| | | 9112 9113 9114 9115 9116 9117 9118 9119 9120 9121 9122 9123 9124 9125 9126 |
static void
ZeroTransferTimerProc(
ClientData clientData)
{
/* calling CopyData with mask==0 still implies immediate invocation of the
* -command callback, and completion of the fcopy.
*/
CopyData((CopyState *)clientData, 0);
}
/*
*----------------------------------------------------------------------
*
* TclCopyChannel --
*
|
| ︙ | ︙ | |||
9077 9078 9079 9080 9081 9082 9083 9084 9085 9086 9087 9088 9089 9090 |
*
* Side effects:
* May schedule a background copy operation that causes both channels to
* be marked busy.
*
*----------------------------------------------------------------------
*/
int
TclCopyChannel(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Channel inChan, /* Channel to read from. */
Tcl_Channel outChan, /* Channel to write to. */
Tcl_WideInt toRead, /* Amount of data to copy, or -1 for all. */
| > > > > > > > > > > > > > > | 9135 9136 9137 9138 9139 9140 9141 9142 9143 9144 9145 9146 9147 9148 9149 9150 9151 9152 9153 9154 9155 9156 9157 9158 9159 9160 9161 9162 |
*
* Side effects:
* May schedule a background copy operation that causes both channels to
* be marked busy.
*
*----------------------------------------------------------------------
*/
#if !defined(TCL_NO_DEPRECATED)
int
TclCopyChannelOld(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Channel inChan, /* Channel to read from. */
Tcl_Channel outChan, /* Channel to write to. */
int toRead, /* Amount of data to copy, or -1 for all. */
Tcl_Obj *cmdPtr) /* Pointer to script to execute or NULL. */
{
return TclCopyChannel(interp, inChan, outChan, (Tcl_WideInt) toRead,
cmdPtr);
}
#endif
int
TclCopyChannel(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Channel inChan, /* Channel to read from. */
Tcl_Channel outChan, /* Channel to write to. */
Tcl_WideInt toRead, /* Amount of data to copy, or -1 for all. */
|
| ︙ | ︙ | |||
9160 9161 9162 9163 9164 9165 9166 |
/*
* Allocate a new CopyState to maintain info about the current copy in
* progress. This structure will be deallocated when the copy is
* completed.
*/
| | | 9232 9233 9234 9235 9236 9237 9238 9239 9240 9241 9242 9243 9244 9245 9246 |
/*
* Allocate a new CopyState to maintain info about the current copy in
* progress. This structure will be deallocated when the copy is
* completed.
*/
csPtr = (CopyState *)ckalloc(sizeof(CopyState) + !moveBytes * inStatePtr->bufSize);
csPtr->bufSize = !moveBytes * inStatePtr->bufSize;
csPtr->readPtr = inPtr;
csPtr->writePtr = outPtr;
csPtr->readFlags = readFlags;
csPtr->writeFlags = writeFlags;
csPtr->toRead = toRead;
csPtr->total = (Tcl_WideInt) 0;
|
| ︙ | ︙ | |||
9454 9455 9456 9457 9458 9459 9460 |
CopyState *csPtr, /* State of copy operation. */
int mask) /* Current channel event flags. */
{
Tcl_Interp *interp;
Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL, *msg = NULL;
Tcl_Channel inChan, outChan;
ChannelState *inStatePtr, *outStatePtr;
| | < | 9526 9527 9528 9529 9530 9531 9532 9533 9534 9535 9536 9537 9538 9539 9540 |
CopyState *csPtr, /* State of copy operation. */
int mask) /* Current channel event flags. */
{
Tcl_Interp *interp;
Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL, *msg = NULL;
Tcl_Channel inChan, outChan;
ChannelState *inStatePtr, *outStatePtr;
int result = TCL_OK, size, sizeb;
Tcl_WideInt total;
const char *buffer;
int inBinary, outBinary, sameEncoding;
/* Encoding control */
int underflow; /* Input underflow */
inChan = (Tcl_Channel) csPtr->readPtr;
|
| ︙ | ︙ | |||
9521 9522 9523 9524 9525 9526 9527 |
* Read up to bufSize bytes.
*/
if ((csPtr->toRead == (Tcl_WideInt) -1)
|| (csPtr->toRead > (Tcl_WideInt) csPtr->bufSize)) {
sizeb = csPtr->bufSize;
} else {
| | | | 9592 9593 9594 9595 9596 9597 9598 9599 9600 9601 9602 9603 9604 9605 9606 9607 9608 9609 9610 9611 9612 9613 9614 9615 9616 |
* Read up to bufSize bytes.
*/
if ((csPtr->toRead == (Tcl_WideInt) -1)
|| (csPtr->toRead > (Tcl_WideInt) csPtr->bufSize)) {
sizeb = csPtr->bufSize;
} else {
sizeb = (int) csPtr->toRead;
}
if (inBinary || sameEncoding) {
size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb,
!GotFlag(inStatePtr, CHANNEL_NONBLOCKING));
} else {
size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb,
0 /* No append */);
}
underflow = (size >= 0) && (size < sizeb); /* Input underflow */
}
if (size < 0) {
readError:
if (interp) {
TclNewObj(errObj);
Tcl_AppendStringsToObj(errObj, "error reading \"",
|
| ︙ | ︙ | |||
9573 9574 9575 9576 9577 9578 9579 |
}
Tcl_CreateChannelHandler(inChan, TCL_READABLE, CopyEventProc,
csPtr);
}
if (size == 0) {
if (!GotFlag(inStatePtr, CHANNEL_NONBLOCKING)) {
/*
| | | | 9644 9645 9646 9647 9648 9649 9650 9651 9652 9653 9654 9655 9656 9657 9658 9659 |
}
Tcl_CreateChannelHandler(inChan, TCL_READABLE, CopyEventProc,
csPtr);
}
if (size == 0) {
if (!GotFlag(inStatePtr, CHANNEL_NONBLOCKING)) {
/*
* We allowed a short read. Keep trying.
*/
continue;
}
if (bufObj != NULL) {
TclDecrRefCount(bufObj);
bufObj = NULL;
}
|
| ︙ | ︙ | |||
9615 9616 9617 9618 9619 9620 9621 | * bytes or characters, and both EOL translation and encoding * conversion may have changed this number unpredictably in relation * to 'size' (It can be smaller or larger, in the latter case able to * drive toRead below -1, causing infinite looping). Completely * unsuitable for updating totals and toRead. */ | | | 9686 9687 9688 9689 9690 9691 9692 9693 9694 9695 9696 9697 9698 9699 9700 |
* bytes or characters, and both EOL translation and encoding
* conversion may have changed this number unpredictably in relation
* to 'size' (It can be smaller or larger, in the latter case able to
* drive toRead below -1, causing infinite looping). Completely
* unsuitable for updating totals and toRead.
*/
if (sizeb < 0) {
writeError:
if (interp) {
TclNewObj(errObj);
Tcl_AppendStringsToObj(errObj, "error writing \"",
Tcl_GetChannelName(outChan), "\": ", NULL);
if (msg != NULL) {
Tcl_AppendObjToObj(errObj, msg);
|
| ︙ | ︙ | |||
9783 9784 9785 9786 9787 9788 9789 |
*----------------------------------------------------------------------
*/
static int
DoRead(
Channel *chanPtr, /* The channel from which to read. */
char *dst, /* Where to store input read. */
| | > > | 9854 9855 9856 9857 9858 9859 9860 9861 9862 9863 9864 9865 9866 9867 9868 9869 9870 9871 9872 9873 9874 |
*----------------------------------------------------------------------
*/
static int
DoRead(
Channel *chanPtr, /* The channel from which to read. */
char *dst, /* Where to store input read. */
int bytesToRead, /* Maximum number of bytes to read. */
int allowShortReads) /* Allow half-blocking (pipes,sockets) */
{
ChannelState *statePtr = chanPtr->state;
char *p = dst;
assert(bytesToRead >= 0);
/*
* Early out when we know a read will get the eofchar.
*
* NOTE: This seems to be a bug. The special handling for
* a zero-char read request ought to come first. As coded
* the EOF due to eofchar has distinguishing behavior from
|
| ︙ | ︙ | |||
9842 9843 9844 9845 9846 9847 9848 | /* * Don't read more data if we have what we need. */ while (!bufPtr || /* We got no buffer! OR */ (!IsBufferFull(bufPtr) && /* Our buffer has room AND */ | | | | | | | 9915 9916 9917 9918 9919 9920 9921 9922 9923 9924 9925 9926 9927 9928 9929 9930 9931 9932 9933 9934 9935 9936 9937 9938 9939 9940 9941 9942 9943 9944 9945 9946 9947 9948 9949 9950 9951 |
/*
* Don't read more data if we have what we need.
*/
while (!bufPtr || /* We got no buffer! OR */
(!IsBufferFull(bufPtr) && /* Our buffer has room AND */
(BytesLeft(bufPtr) < bytesToRead))) {
/* Not enough bytes in it yet
* to fill the dst */
int code;
moreData:
code = GetInput(chanPtr);
bufPtr = statePtr->inQueueHead;
assert(bufPtr != NULL);
if (GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)) {
/*
* Further reads cannot do any more.
*/
break;
}
if (code) {
/*
* Read error
*/
UpdateInterest(chanPtr);
TclChannelRelease((Tcl_Channel)chanPtr);
return -1;
}
assert(IsBufferFull(bufPtr));
|
| ︙ | ︙ | |||
9916 9917 9918 9919 9920 9921 9922 |
assert(statePtr->inputTranslation == TCL_TRANSLATE_CRLF);
assert(RemovePoint(bufPtr)[0] == '\r');
assert(BytesLeft(bufPtr) == 1);
if (bufPtr->nextPtr == NULL) {
/*
| | | | | | | | | | | | 9989 9990 9991 9992 9993 9994 9995 9996 9997 9998 9999 10000 10001 10002 10003 10004 10005 10006 10007 10008 10009 10010 10011 10012 10013 10014 10015 10016 10017 10018 10019 10020 10021 10022 10023 10024 10025 10026 10027 10028 10029 10030 10031 10032 10033 |
assert(statePtr->inputTranslation == TCL_TRANSLATE_CRLF);
assert(RemovePoint(bufPtr)[0] == '\r');
assert(BytesLeft(bufPtr) == 1);
if (bufPtr->nextPtr == NULL) {
/*
* There's no more buffered data...
*/
if (statePtr->flags & CHANNEL_EOF) {
/*
* ...and there never will be.
*/
*p++ = '\r';
bytesToRead--;
bufPtr->nextRemoved++;
} else if (statePtr->flags & CHANNEL_BLOCKED) {
/*
* ...and we cannot get more now.
*/
SetFlag(statePtr, CHANNEL_NEED_MORE_DATA);
break;
} else {
/*
* ...so we need to get some.
*/
goto moreData;
}
}
if (bufPtr->nextPtr) {
/*
* There's a next buffer. Shift orphan \r to it.
*/
ChannelBuffer *nextPtr = bufPtr->nextPtr;
nextPtr->nextRemoved -= 1;
RemovePoint(nextPtr)[0] = '\r';
bufPtr->nextRemoved++;
}
|
| ︙ | ︙ | |||
10017 10018 10019 10020 10021 10022 10023 |
*/
static void
CopyEventProc(
ClientData clientData,
int mask)
{
| | | 10090 10091 10092 10093 10094 10095 10096 10097 10098 10099 10100 10101 10102 10103 10104 |
*/
static void
CopyEventProc(
ClientData clientData,
int mask)
{
(void) CopyData((CopyState *)clientData, mask);
}
/*
*----------------------------------------------------------------------
*
* StopCopy --
*
|
| ︙ | ︙ | |||
10086 10087 10088 10089 10090 10091 10092 |
}
Tcl_DeleteChannelHandler(inChan, MBEvent, csPtr);
Tcl_DeleteChannelHandler(outChan, MBEvent, csPtr);
TclDecrRefCount(csPtr->cmdPtr);
}
inStatePtr->csPtrR = NULL;
outStatePtr->csPtrW = NULL;
| | | 10159 10160 10161 10162 10163 10164 10165 10166 10167 10168 10169 10170 10171 10172 10173 |
}
Tcl_DeleteChannelHandler(inChan, MBEvent, csPtr);
Tcl_DeleteChannelHandler(outChan, MBEvent, csPtr);
TclDecrRefCount(csPtr->cmdPtr);
}
inStatePtr->csPtrR = NULL;
outStatePtr->csPtrW = NULL;
ckfree(csPtr);
}
/*
*----------------------------------------------------------------------
*
* StackSetBlockMode --
*
|
| ︙ | ︙ | |||
10350 10351 10352 10353 10354 10355 10356 |
* Always check bottom-most channel in the stack. This is the one that
* gets registered.
*/
chanPtr = ((Channel *) chan)->state->bottomChanPtr;
statePtr = chanPtr->state;
| | | 10423 10424 10425 10426 10427 10428 10429 10430 10431 10432 10433 10434 10435 10436 10437 |
* Always check bottom-most channel in the stack. This is the one that
* gets registered.
*/
chanPtr = ((Channel *) chan)->state->bottomChanPtr;
statePtr = chanPtr->state;
hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == NULL) {
return 0;
}
hPtr = Tcl_FindHashEntry(hTblPtr, statePtr->channelName);
if (hPtr == NULL) {
return 0;
}
|
| ︙ | ︙ | |||
10388 10389 10390 10391 10392 10393 10394 |
int
Tcl_IsChannelShared(
Tcl_Channel chan) /* The channel to query */
{
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of real channel structure. */
| | | 10461 10462 10463 10464 10465 10466 10467 10468 10469 10470 10471 10472 10473 10474 10475 |
int
Tcl_IsChannelShared(
Tcl_Channel chan) /* The channel to query */
{
ChannelState *statePtr = ((Channel *) chan)->state;
/* State of real channel structure. */
return ((statePtr->refCount > 1) ? 1 : 0);
}
/*
*----------------------------------------------------------------------
*
* Tcl_IsChannelExisting --
*
|
| ︙ | ︙ | |||
10432 10433 10434 10435 10436 10437 10438 |
} else if (statePtr->topChanPtr == (Channel *) tsdPtr->stderrChannel) {
name = "stderr";
} else {
name = statePtr->channelName;
}
if ((*chanName == *name) &&
| | | 10505 10506 10507 10508 10509 10510 10511 10512 10513 10514 10515 10516 10517 10518 10519 |
} else if (statePtr->topChanPtr == (Channel *) tsdPtr->stderrChannel) {
name = "stderr";
} else {
name = statePtr->channelName;
}
if ((*chanName == *name) &&
(memcmp(name, chanName, (size_t) chanNameLen + 1) == 0)) {
return 1;
}
}
return 0;
}
|
| ︙ | ︙ | |||
10484 10485 10486 10487 10488 10489 10490 |
*/
Tcl_ChannelTypeVersion
Tcl_ChannelVersion(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
| < | < | < < < | < < < | < < < < < < < < < < < < < < < < < < < | < < < < < | 10557 10558 10559 10560 10561 10562 10563 10564 10565 10566 10567 10568 10569 10570 10571 10572 10573 10574 10575 10576 10577 10578 10579 10580 10581 |
*/
Tcl_ChannelTypeVersion
Tcl_ChannelVersion(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
#ifndef TCL_NO_DEPRECATED
if ((chanTypePtr->version < TCL_CHANNEL_VERSION_2)
|| (chanTypePtr->version > TCL_CHANNEL_VERSION_5)) {
/*
* In <v2 channel versions, the version field is occupied by the
* Tcl_DriverBlockModeProc
*/
return TCL_CHANNEL_VERSION_1;
}
#endif
return chanTypePtr->version;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelBlockModeProc --
*
|
| ︙ | ︙ | |||
10549 10550 10551 10552 10553 10554 10555 |
*---------------------------------------------------------------------- */
Tcl_DriverBlockModeProc *
Tcl_ChannelBlockModeProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
| | < < | | | | > | > | > > | 10590 10591 10592 10593 10594 10595 10596 10597 10598 10599 10600 10601 10602 10603 10604 10605 10606 10607 10608 10609 10610 10611 10612 10613 10614 10615 10616 10617 10618 10619 10620 10621 10622 10623 10624 10625 10626 10627 10628 10629 10630 10631 10632 10633 10634 10635 10636 10637 10638 10639 |
*---------------------------------------------------------------------- */
Tcl_DriverBlockModeProc *
Tcl_ChannelBlockModeProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
#ifndef TCL_NO_DEPRECATED
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) {
/*
* The v1 structure had the blockModeProc in a different place.
*/
return (Tcl_DriverBlockModeProc *) chanTypePtr->version;
}
#endif
return chanTypePtr->blockModeProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelCloseProc --
*
* Return the Tcl_DriverCloseProc of the channel type.
*
* Results:
* A pointer to the proc.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
Tcl_DriverCloseProc *
Tcl_ChannelCloseProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
return chanTypePtr->closeProc;
}
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelClose2Proc --
*
* Return the Tcl_DriverClose2Proc of the channel type.
|
| ︙ | ︙ | |||
10672 10673 10674 10675 10676 10677 10678 10679 10680 10681 10682 10683 10684 10685 10686 10687 10688 10689 10690 10691 10692 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_DriverSeekProc *
Tcl_ChannelSeekProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
return chanTypePtr->seekProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelSetOptionProc --
*
* Return the Tcl_DriverSetOptionProc of the channel type.
| > > | 10715 10716 10717 10718 10719 10720 10721 10722 10723 10724 10725 10726 10727 10728 10729 10730 10731 10732 10733 10734 10735 10736 10737 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
Tcl_DriverSeekProc *
Tcl_ChannelSeekProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
return chanTypePtr->seekProc;
}
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelSetOptionProc --
*
* Return the Tcl_DriverSetOptionProc of the channel type.
|
| ︙ | ︙ | |||
10797 10798 10799 10800 10801 10802 10803 |
*/
Tcl_DriverFlushProc *
Tcl_ChannelFlushProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
| > | | > | | 10842 10843 10844 10845 10846 10847 10848 10849 10850 10851 10852 10853 10854 10855 10856 10857 10858 10859 10860 10861 |
*/
Tcl_DriverFlushProc *
Tcl_ChannelFlushProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
#ifndef TCL_NO_DEPRECATED
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) {
return NULL;
}
#endif
return chanTypePtr->flushProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelHandlerProc --
*
|
| ︙ | ︙ | |||
10824 10825 10826 10827 10828 10829 10830 |
*/
Tcl_DriverHandlerProc *
Tcl_ChannelHandlerProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
| > | | > | | 10871 10872 10873 10874 10875 10876 10877 10878 10879 10880 10881 10882 10883 10884 10885 10886 10887 10888 10889 10890 |
*/
Tcl_DriverHandlerProc *
Tcl_ChannelHandlerProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
#ifndef TCL_NO_DEPRECATED
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) {
return NULL;
}
#endif
return chanTypePtr->handlerProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelWideSeekProc --
*
|
| ︙ | ︙ | |||
10851 10852 10853 10854 10855 10856 10857 |
*/
Tcl_DriverWideSeekProc *
Tcl_ChannelWideSeekProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
| > | | > | | 10900 10901 10902 10903 10904 10905 10906 10907 10908 10909 10910 10911 10912 10913 10914 10915 10916 10917 10918 10919 |
*/
Tcl_DriverWideSeekProc *
Tcl_ChannelWideSeekProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
#ifndef TCL_NO_DEPRECATED
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_3) {
return NULL;
}
#endif
return chanTypePtr->wideSeekProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ChannelThreadActionProc --
*
|
| ︙ | ︙ | |||
10879 10880 10881 10882 10883 10884 10885 |
*/
Tcl_DriverThreadActionProc *
Tcl_ChannelThreadActionProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
| > | | > | | 10930 10931 10932 10933 10934 10935 10936 10937 10938 10939 10940 10941 10942 10943 10944 10945 10946 10947 10948 10949 |
*/
Tcl_DriverThreadActionProc *
Tcl_ChannelThreadActionProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
#ifndef TCL_NO_DEPRECATED
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_4) {
return NULL;
}
#endif
return chanTypePtr->threadActionProc;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetChannelErrorInterp --
*
|
| ︙ | ︙ | |||
11059 11060 11061 11062 11063 11064 11065 |
if (newlevel >= 0) {
lcn += 2;
}
if (newcode >= 0) {
lcn += 2;
}
| | | 11112 11113 11114 11115 11116 11117 11118 11119 11120 11121 11122 11123 11124 11125 11126 |
if (newlevel >= 0) {
lcn += 2;
}
if (newcode >= 0) {
lcn += 2;
}
lvn = (Tcl_Obj **)ckalloc(lcn * sizeof(Tcl_Obj *));
/*
* New level/code information is spliced into the first occurence of
* -level, -code, further occurences are ignored. The options cannot be
* not present, we would not come here. Options which are ok are simply
* copied over.
*/
|
| ︙ | ︙ | |||
11112 11113 11114 11115 11116 11117 11118 |
if (explicitResult) {
lvn[j++] = lv[i];
}
msg = Tcl_NewListObj(j, lvn);
| | | 11165 11166 11167 11168 11169 11170 11171 11172 11173 11174 11175 11176 11177 11178 11179 |
if (explicitResult) {
lvn[j++] = lv[i];
}
msg = Tcl_NewListObj(j, lvn);
ckfree(lvn);
return msg;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetChannelErrorInterp --
|
| ︙ | ︙ | |||
11194 11195 11196 11197 11198 11199 11200 |
*/
Tcl_DriverTruncateProc *
Tcl_ChannelTruncateProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
| | | | | 11247 11248 11249 11250 11251 11252 11253 11254 11255 11256 11257 11258 11259 11260 11261 11262 11263 11264 |
*/
Tcl_DriverTruncateProc *
Tcl_ChannelTruncateProc(
const Tcl_ChannelType *chanTypePtr)
/* Pointer to channel type. */
{
if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_5) {
return NULL;
}
return chanTypePtr->truncateProc;
}
/*
*----------------------------------------------------------------------
*
* DupChannelIntRep --
*
|
| ︙ | ︙ | |||
11220 11221 11222 11223 11224 11225 11226 | * representation. * *---------------------------------------------------------------------- */ static void DupChannelIntRep( | | | | 11273 11274 11275 11276 11277 11278 11279 11280 11281 11282 11283 11284 11285 11286 11287 11288 11289 |
* representation.
*
*----------------------------------------------------------------------
*/
static void
DupChannelIntRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have
* an internal rep of type "Channel". */
Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not
* currently have an internal rep.*/
{
ResolvedChanName *resPtr;
ChanGetIntRep(srcPtr, resPtr);
assert(resPtr);
ChanSetIntRep(copyPtr, resPtr);
|
| ︙ | ︙ | |||
11260 11261 11262 11263 11264 11265 11266 |
ChanGetIntRep(objPtr, resPtr);
assert(resPtr);
if (resPtr->refCount-- > 1) {
return;
}
Tcl_Release(resPtr->statePtr);
| | | 11313 11314 11315 11316 11317 11318 11319 11320 11321 11322 11323 11324 11325 11326 11327 |
ChanGetIntRep(objPtr, resPtr);
assert(resPtr);
if (resPtr->refCount-- > 1) {
return;
}
Tcl_Release(resPtr->statePtr);
ckfree(resPtr);
}
#if 0
/*
* For future debugging work, a simple function to print the flags of a
* channel in semi-readable form.
*/
|
| ︙ | ︙ |
Changes to generic/tclIO.h.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 |
/*
* struct ChannelBuffer:
*
* Buffers data being sent to or from a channel.
*/
typedef struct ChannelBuffer {
| | | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
/*
* struct ChannelBuffer:
*
* Buffers data being sent to or from a channel.
*/
typedef struct ChannelBuffer {
int refCount; /* Current uses count */
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. */
|
| ︙ | ︙ | |||
109 110 111 112 113 114 115 |
* Intermediate buffers to hold pre-read data for consumption by a newly
* stacked transformation. See 'Tcl_StackChannel'.
*/
ChannelBuffer *inQueueHead; /* Points at first buffer in input queue. */
ChannelBuffer *inQueueTail; /* Points at last buffer in input queue. */
| | | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 |
* Intermediate buffers to hold pre-read data for consumption by a newly
* stacked transformation. See 'Tcl_StackChannel'.
*/
ChannelBuffer *inQueueHead; /* Points at first buffer in input queue. */
ChannelBuffer *inQueueTail; /* Points at last buffer in input queue. */
int refCount;
} Channel;
/*
* struct ChannelState:
*
* One of these structures is allocated for each open channel. It contains
* data specific to the channel but which belongs to the generic part of the
|
| ︙ | ︙ | |||
159 160 161 162 163 164 165 |
int inEofChar; /* If nonzero, use this as a signal of EOF on
* input. */
int outEofChar; /* If nonzero, append this to the channel when
* it is closed if it is open for writing. */
int unreportedError; /* Non-zero if an error report was deferred
* because it happened in the background. The
* value is the POSIX error code. */
| | | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 |
int inEofChar; /* If nonzero, use this as a signal of EOF on
* input. */
int outEofChar; /* If nonzero, append this to the channel when
* it is closed if it is open for writing. */
int unreportedError; /* Non-zero if an error report was deferred
* because it happened in the background. The
* value is the POSIX error code. */
int refCount; /* How many interpreters hold references to
* this IO channel? */
struct CloseCallback *closeCbPtr;
/* Callbacks registered to be called when the
* channel is closed. */
char *outputStage; /* Temporary staging buffer used when
* translating EOL before converting from
* UTF-8 to external form. */
|
| ︙ | ︙ |
Changes to generic/tclIOCmd.c.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | #include "tclInt.h" /* * Callback structure for accept callback in a TCP server. */ | | | | | < < | > | < < | | < | 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 |
#include "tclInt.h"
/*
* Callback structure for accept callback in a TCP server.
*/
typedef struct AcceptCallback {
Tcl_Obj *script; /* Script to invoke. */
Tcl_Interp *interp; /* Interpreter in which to run it. */
} AcceptCallback;
/*
* Thread local storage used to maintain a per-thread stdout channel obj.
* It must be per-thread because of std channel limitations.
*/
typedef struct {
int initialized; /* Set to 1 when the module is initialized. */
Tcl_Obj *stdoutObjPtr; /* Cached stdout channel Tcl_Obj */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* Static functions for this file:
*/
static Tcl_ExitProc FinalizeIOCmdTSD;
static Tcl_TcpAcceptProc AcceptCallbackProc;
static Tcl_ObjCmdProc ChanPendingObjCmd;
static Tcl_ObjCmdProc ChanTruncateObjCmd;
static void RegisterTcpServerInterpCleanup(
Tcl_Interp *interp,
AcceptCallback *acceptCallbackPtr);
static Tcl_InterpDeleteProc TcpAcceptCallbacksDeleteProc;
static void TcpServerCloseProc(ClientData callbackData);
static void UnregisterTcpServerInterpCleanupProc(
Tcl_Interp *interp,
AcceptCallback *acceptCallbackPtr);
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
67 68 69 70 71 72 73 | * None. * *---------------------------------------------------------------------- */ static void FinalizeIOCmdTSD( | | | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 |
* None.
*
*----------------------------------------------------------------------
*/
static void
FinalizeIOCmdTSD(
TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->stdoutObjPtr != NULL) {
Tcl_DecrRefCount(tsdPtr->stdoutObjPtr);
tsdPtr->stdoutObjPtr = NULL;
}
|
| ︙ | ︙ | |||
95 96 97 98 99 100 101 | * * Side effects: * Produces output on a channel. * *---------------------------------------------------------------------- */ | < | | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 |
*
* Side effects:
* Produces output on a channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_PutsObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to puts on. */
Tcl_Obj *string; /* String to write. */
Tcl_Obj *chanObjPtr = NULL; /* channel object. */
|
| ︙ | ︙ | |||
133 134 135 136 137 138 139 140 141 142 143 144 145 146 |
case 4: /* [puts -nonewline $chan $x] or
* [puts $chan $x nonewline] */
newline = 0;
if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
chanObjPtr = objv[2];
string = objv[3];
break;
}
/* Fall through */
default: /* [puts] or
* [puts some bad number of arguments...] */
Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string");
return TCL_ERROR;
}
| > > > > > > > > > > > > > | 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 |
case 4: /* [puts -nonewline $chan $x] or
* [puts $chan $x nonewline] */
newline = 0;
if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) {
chanObjPtr = objv[2];
string = objv[3];
break;
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
} else if (strcmp(TclGetString(objv[3]), "nonewline") == 0) {
/*
* The code below provides backwards compatibility with an old
* form of the command that is no longer recommended or
* documented. See also [Bug #3151675]. Will be removed in Tcl 9,
* maybe even earlier.
*/
chanObjPtr = objv[1];
string = objv[2];
break;
#endif
}
/* Fall through */
default: /* [puts] or
* [puts some bad number of arguments...] */
Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
164 165 166 167 168 169 170 |
"channel \"%s\" wasn't opened for writing",
TclGetString(chanObjPtr)));
return TCL_ERROR;
}
TclChannelPreserve(chan);
result = Tcl_WriteObj(chan, string);
| | | | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 |
"channel \"%s\" wasn't opened for writing",
TclGetString(chanObjPtr)));
return TCL_ERROR;
}
TclChannelPreserve(chan);
result = Tcl_WriteObj(chan, string);
if (result < 0) {
goto error;
}
if (newline != 0) {
result = Tcl_WriteChars(chan, "\n", 1);
if (result < 0) {
goto error;
}
}
TclChannelRelease(chan);
return TCL_OK;
/*
|
| ︙ | ︙ | |||
209 210 211 212 213 214 215 | * * Side effects: * May cause output to appear on the specified channel. * *---------------------------------------------------------------------- */ | < | | 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 |
*
* Side effects:
* May cause output to appear on the specified channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_FlushObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *chanObjPtr;
Tcl_Channel chan; /* The channel to flush on. */
int mode;
|
| ︙ | ︙ | |||
274 275 276 277 278 279 280 | * * Side effects: * May consume input from channel. * *---------------------------------------------------------------------- */ | < | | 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 |
*
* Side effects:
* May consume input from channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetsObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to read from. */
int lineLen; /* Length of line just read. */
int mode; /* Mode in which channel is opened. */
|
| ︙ | ︙ | |||
359 360 361 362 363 364 365 | * * Side effects: * May consume input from channel. * *---------------------------------------------------------------------- */ | < | | 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 |
*
* Side effects:
* May consume input from channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_ReadObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to read from. */
int newline, i; /* Discard newline at end? */
int toRead; /* How many bytes to read? */
|
| ︙ | ︙ | |||
422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 |
* Compute how many bytes to read.
*/
toRead = -1;
if (i < objc) {
if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK)
|| (toRead < 0)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected non-negative integer but got \"%s\"",
TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL);
return TCL_ERROR;
}
}
resultPtr = Tcl_NewObj();
Tcl_IncrRefCount(resultPtr);
TclChannelPreserve(chan);
charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
| > > > > > > > > > > > > > > | 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 |
* Compute how many bytes to read.
*/
toRead = -1;
if (i < objc) {
if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK)
|| (toRead < 0)) {
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
* The code below provides backwards compatibility with an old
* form of the command that is no longer recommended or
* documented. See also [Bug #3151675]. Will be removed in Tcl 9,
* maybe even earlier.
*/
if (strcmp(TclGetString(objv[i]), "nonewline") != 0) {
#endif
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected non-negative integer but got \"%s\"",
TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL);
return TCL_ERROR;
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
}
newline = 1;
#endif
}
}
resultPtr = Tcl_NewObj();
Tcl_IncrRefCount(resultPtr);
TclChannelPreserve(chan);
charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0);
|
| ︙ | ︙ | |||
458 459 460 461 462 463 464 |
/*
* If requested, remove the last newline in the channel if at EOF.
*/
if ((charactersRead > 0) && (newline != 0)) {
const char *result;
| | | 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 |
/*
* If requested, remove the last newline in the channel if at EOF.
*/
if ((charactersRead > 0) && (newline != 0)) {
const char *result;
int length;
result = TclGetStringFromObj(resultPtr, &length);
if (result[length - 1] == '\n') {
Tcl_SetObjLength(resultPtr, length - 1);
}
}
Tcl_SetObjResult(interp, resultPtr);
|
| ︙ | ︙ | |||
489 490 491 492 493 494 495 | * Side effects: * Moves the position of the access point on the specified channel. May * flush queued output. * *---------------------------------------------------------------------- */ | < | | 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 |
* Side effects:
* Moves the position of the access point on the specified channel. May
* flush queued output.
*
*----------------------------------------------------------------------
*/
int
Tcl_SeekObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to tell on. */
Tcl_WideInt offset; /* Where to seek? */
int mode; /* How to seek? */
|
| ︙ | ︙ | |||
565 566 567 568 569 570 571 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < | | 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_TellObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to tell on. */
Tcl_WideInt newLoc;
int code;
|
| ︙ | ︙ | |||
628 629 630 631 632 633 634 | * * Side effects: * May discard queued input; may flush queued output. * *---------------------------------------------------------------------- */ | < | | 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 |
*
* Side effects:
* May discard queued input; may flush queued output.
*
*----------------------------------------------------------------------
*/
int
Tcl_CloseObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to close. */
static const char *const dirOptions[] = {
"read", "write", NULL
|
| ︙ | ︙ | |||
680 681 682 683 684 685 686 | " or already closed", dirOptions[index])); return TCL_ERROR; } /* * Special handling is needed if and only if the channel mode supports * more than the direction to close. Because if the close the last | | | 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 |
" or already closed", dirOptions[index]));
return TCL_ERROR;
}
/*
* Special handling is needed if and only if the channel mode supports
* more than the direction to close. Because if the close the last
* direction supported we can and will go through the regular
* process.
*/
if ((Tcl_GetChannelMode(chan) &
(TCL_CLOSE_READ|TCL_CLOSE_WRITE)) != dir) {
return Tcl_CloseEx(interp, chan, dir);
}
|
| ︙ | ︙ | |||
704 705 706 707 708 709 710 | * messages produced by drivers during the closing of a channel, * because the Tcl convention is that such error messages do not have * a terminating newline. */ Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); const char *string; | | | 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 |
* messages produced by drivers during the closing of a channel,
* because the Tcl convention is that such error messages do not have
* a terminating newline.
*/
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
const char *string;
int len;
if (Tcl_IsShared(resultPtr)) {
resultPtr = Tcl_DuplicateObj(resultPtr);
Tcl_SetObjResult(interp, resultPtr);
}
string = TclGetStringFromObj(resultPtr, &len);
if ((len > 0) && (string[len - 1] == '\n')) {
|
| ︙ | ︙ | |||
737 738 739 740 741 742 743 | * * Side effects: * May modify the behavior of an IO channel. * *---------------------------------------------------------------------- */ | < | | 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 |
*
* Side effects:
* May modify the behavior of an IO channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_FconfigureObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *optionName, *valueName;
Tcl_Channel chan; /* The channel to set a mode on. */
int i; /* Iterate over arg-value pairs. */
|
| ︙ | ︙ | |||
813 814 815 816 817 818 819 | * Side effects: * Sets interp's result to boolean true or false depending on whether the * specified channel has an EOF condition. * *--------------------------------------------------------------------------- */ | < | | 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 |
* Side effects:
* Sets interp's result to boolean true or false depending on whether the
* specified channel has an EOF condition.
*
*---------------------------------------------------------------------------
*/
int
Tcl_EofObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
if (objc != 2) {
|
| ︙ | ︙ | |||
853 854 855 856 857 858 859 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | | | 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ExecObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *resultPtr;
const char **argv; /* An array for the string arguments. Stored
* on the _Tcl_ stack. */
const char *string;
Tcl_Channel chan;
int argc, background, i, index, keepNewline, result, skip, length;
int ignoreStderr;
static const char *const options[] = {
"-ignorestderr", "-keepnewline", "--", NULL
};
enum options {
EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST
};
|
| ︙ | ︙ | |||
921 922 923 924 925 926 927 |
/*
* Create the string argument array "argv". Make sure argv is large enough
* to hold the argc arguments plus 1 extra for the zero end-of-argv word.
*/
argc = objc - skip;
| | | 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 |
/*
* Create the string argument array "argv". Make sure argv is large enough
* to hold the argc arguments plus 1 extra for the zero end-of-argv word.
*/
argc = objc - skip;
argv = (const char **)TclStackAlloc(interp, (argc + 1) * sizeof(char *));
/*
* Copy the string conversions of each (post option) object into the
* argument vector.
*/
for (i = 0; i < argc; i++) {
|
| ︙ | ︙ | |||
1021 1022 1023 1024 1025 1026 1027 | * Side effects: * Sets interp's result to boolean true or false depending on whether the * preceeding input operation on the channel would have blocked. * *--------------------------------------------------------------------------- */ | < | | 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 |
* Side effects:
* Sets interp's result to boolean true or false depending on whether the
* preceeding input operation on the channel would have blocked.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FblockedObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
int mode;
|
| ︙ | ︙ | |||
1068 1069 1070 1071 1072 1073 1074 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_OpenObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int pipeline, prot;
const char *modeString, *what;
Tcl_Channel chan;
|
| ︙ | ︙ | |||
1161 1162 1163 1164 1165 1166 1167 |
break;
}
chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags);
if (binary && chan) {
Tcl_SetChannelOption(interp, chan, "-translation", "binary");
}
}
| | | 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 |
break;
}
chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags);
if (binary && chan) {
Tcl_SetChannelOption(interp, chan, "-translation", "binary");
}
}
ckfree(cmdArgv);
}
if (chan == NULL) {
return TCL_ERROR;
}
Tcl_RegisterChannel(interp, chan);
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
return TCL_OK;
|
| ︙ | ︙ | |||
1192 1193 1194 1195 1196 1197 1198 | * Deallocates memory and sets the interp field of all the accept * callback records to NULL to prevent this interpreter from being used * subsequently to eval accept scripts. * *---------------------------------------------------------------------- */ | < | | | | | 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 |
* Deallocates memory and sets the interp field of all the accept
* callback records to NULL to prevent this interpreter from being used
* subsequently to eval accept scripts.
*
*----------------------------------------------------------------------
*/
static void
TcpAcceptCallbacksDeleteProc(
ClientData clientData, /* Data which was passed when the assocdata
* was registered. */
TCL_UNUSED(Tcl_Interp *))
{
Tcl_HashTable *hTblPtr = (Tcl_HashTable *)clientData;
Tcl_HashEntry *hPtr;
Tcl_HashSearch hSearch;
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
AcceptCallback *acceptCallbackPtr = (AcceptCallback *)Tcl_GetHashValue(hPtr);
acceptCallbackPtr->interp = NULL;
}
Tcl_DeleteHashTable(hTblPtr);
ckfree(hTblPtr);
}
/*
*----------------------------------------------------------------------
*
* RegisterTcpServerInterpCleanup --
*
|
| ︙ | ︙ | |||
1247 1248 1249 1250 1251 1252 1253 |
{
Tcl_HashTable *hTblPtr; /* Hash table for accept callback records to
* smash when the interpreter will be
* deleted. */
Tcl_HashEntry *hPtr; /* Entry for this record. */
int isNew; /* Is the entry new? */
| | | | 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 |
{
Tcl_HashTable *hTblPtr; /* Hash table for accept callback records to
* smash when the interpreter will be
* deleted. */
Tcl_HashEntry *hPtr; /* Entry for this record. */
int isNew; /* Is the entry new? */
hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL);
if (hTblPtr == NULL) {
hTblPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS);
Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks",
TcpAcceptCallbacksDeleteProc, hTblPtr);
}
hPtr = Tcl_CreateHashEntry(hTblPtr, acceptCallbackPtr, &isNew);
if (!isNew) {
|
| ︙ | ︙ | |||
1293 1294 1295 1296 1297 1298 1299 |
AcceptCallback *acceptCallbackPtr)
/* The record for which to delete the
* registration. */
{
Tcl_HashTable *hTblPtr;
Tcl_HashEntry *hPtr;
| | | 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 |
AcceptCallback *acceptCallbackPtr)
/* The record for which to delete the
* registration. */
{
Tcl_HashTable *hTblPtr;
Tcl_HashEntry *hPtr;
hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL);
if (hTblPtr == NULL) {
return;
}
hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr);
if (hPtr != NULL) {
Tcl_DeleteHashEntry(hPtr);
|
| ︙ | ︙ | |||
1331 1332 1333 1334 1335 1336 1337 |
* created in the call to
* Tcl_OpenTcpServer. */
Tcl_Channel chan, /* Channel for the newly accepted
* connection. */
char *address, /* Address of client that was accepted. */
int port) /* Port of client that was accepted. */
{
| | | 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 |
* created in the call to
* Tcl_OpenTcpServer. */
Tcl_Channel chan, /* Channel for the newly accepted
* connection. */
char *address, /* Address of client that was accepted. */
int port) /* Port of client that was accepted. */
{
AcceptCallback *acceptCallbackPtr = (AcceptCallback *)callbackData;
/*
* Check if the callback is still valid; the interpreter may have gone
* away, this is signalled by setting the interp field of the callback
* data to NULL.
*/
|
| ︙ | ︙ | |||
1417 1418 1419 1420 1421 1422 1423 |
*/
static void
TcpServerCloseProc(
ClientData callbackData) /* The data passed in the call to
* Tcl_CreateCloseHandler. */
{
| | | | 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 |
*/
static void
TcpServerCloseProc(
ClientData callbackData) /* The data passed in the call to
* Tcl_CreateCloseHandler. */
{
AcceptCallback *acceptCallbackPtr = (AcceptCallback *)callbackData;
/* The actual data. */
if (acceptCallbackPtr->interp != NULL) {
UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp,
acceptCallbackPtr);
}
Tcl_DecrRefCount(acceptCallbackPtr->script);
ckfree(acceptCallbackPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SocketObjCmd --
*
|
| ︙ | ︙ | |||
1447 1448 1449 1450 1451 1452 1453 | * Creates a socket based channel. * *---------------------------------------------------------------------- */ int Tcl_SocketObjCmd( | | | 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 |
* Creates a socket based channel.
*
*----------------------------------------------------------------------
*/
int
Tcl_SocketObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const socketOptions[] = {
"-async", "-myaddr", "-myport", "-reuseaddr", "-reuseport", "-server",
NULL
|
| ︙ | ︙ | |||
1472 1473 1474 1475 1476 1477 1478 |
Tcl_Channel chan;
if (TclpHasSockets(interp) != TCL_OK) {
return TCL_ERROR;
}
for (a = 1; a < objc; a++) {
| | | 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 |
Tcl_Channel chan;
if (TclpHasSockets(interp) != TCL_OK) {
return TCL_ERROR;
}
for (a = 1; a < objc; a++) {
const char *arg = Tcl_GetString(objv[a]);
if (arg[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, "option",
TCL_EXACT, &optionIndex) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
1621 1622 1623 1624 1625 1626 1627 |
if (a != objc-1) {
goto wrongNumArgs;
}
port = TclGetString(objv[a]);
if (server) {
| | | | 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 |
if (a != objc-1) {
goto wrongNumArgs;
}
port = TclGetString(objv[a]);
if (server) {
AcceptCallback *acceptCallbackPtr = (AcceptCallback *)ckalloc(sizeof(AcceptCallback));
Tcl_IncrRefCount(script);
acceptCallbackPtr->script = script;
acceptCallbackPtr->interp = interp;
chan = Tcl_OpenTcpServerEx(interp, port, host, flags,
AcceptCallbackProc, acceptCallbackPtr);
if (chan == NULL) {
Tcl_DecrRefCount(script);
ckfree(acceptCallbackPtr);
return TCL_ERROR;
}
/*
* Register with the interpreter to let us know when the interpreter
* is deleted (by having the callback set the interp field of the
* acceptCallbackPtr's structure to NULL). This is to avoid trying to
|
| ︙ | ︙ | |||
1689 1690 1691 1692 1693 1694 1695 | * handler. * *---------------------------------------------------------------------- */ int Tcl_FcopyObjCmd( | | | 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 |
* handler.
*
*----------------------------------------------------------------------
*/
int
Tcl_FcopyObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel inChan, outChan;
int mode, i, index;
Tcl_WideInt toRead;
|
| ︙ | ︙ | |||
1782 1783 1784 1785 1786 1787 1788 | * Sets interp's result to the number of bytes of buffered input or * output (depending on whether the first argument is "input" or * "output"), or -1 if the channel wasn't opened for that mode. * *--------------------------------------------------------------------------- */ | < | | 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 |
* Sets interp's result to the number of bytes of buffered input or
* output (depending on whether the first argument is "input" or
* "output"), or -1 if the channel wasn't opened for that mode.
*
*---------------------------------------------------------------------------
*/
static int
ChanPendingObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
int index, mode;
static const char *const options[] = {"input", "output", NULL};
|
| ︙ | ︙ | |||
1847 1848 1849 1850 1851 1852 1853 | * Truncates a channel (or rather a file underlying a channel). * *---------------------------------------------------------------------- */ static int ChanTruncateObjCmd( | | | 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 |
* Truncates a channel (or rather a file underlying a channel).
*
*----------------------------------------------------------------------
*/
static int
ChanTruncateObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
Tcl_WideInt length;
|
| ︙ | ︙ | |||
1920 1921 1922 1923 1924 1925 1926 | * anonymous pipe. * *---------------------------------------------------------------------- */ static int ChanPipeObjCmd( | | | 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 |
* anonymous pipe.
*
*----------------------------------------------------------------------
*/
static int
ChanPipeObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel rchan, wchan;
const char *channelNames[2];
Tcl_Obj *resultPtr;
|
| ︙ | ︙ | |||
1971 1972 1973 1974 1975 1976 1977 | * None. * *---------------------------------------------------------------------- */ int TclChannelNamesCmd( | | | 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 |
* None.
*
*----------------------------------------------------------------------
*/
int
TclChannelNamesCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc < 1 || objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?pattern?");
return TCL_ERROR;
|
| ︙ | ︙ |
Changes to generic/tclIOGT.c.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 | * Forward declarations of internal procedures. First the driver procedures of * the transformation. */ static int TransformBlockModeProc(ClientData instanceData, int mode); static int TransformCloseProc(ClientData instanceData, | | > > | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | * Forward declarations of internal procedures. First the driver procedures of * the transformation. */ static int TransformBlockModeProc(ClientData instanceData, int mode); static int TransformCloseProc(ClientData instanceData, Tcl_Interp *interp, int flags); static int TransformInputProc(ClientData instanceData, char *buf, int toRead, int *errorCodePtr); static int TransformOutputProc(ClientData instanceData, const char *buf, int toWrite, int *errorCodePtr); #ifndef TCL_NO_DEPRECATED static int TransformSeekProc(ClientData instanceData, long offset, int mode, int *errorCodePtr); #endif static int TransformSetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, const char *value); static int TransformGetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); static void TransformWatchProc(ClientData instanceData, int mask); |
| ︙ | ︙ | |||
115 116 117 118 119 120 121 |
* This structure describes the channel type structure for Tcl-based
* transformations.
*/
static const Tcl_ChannelType transformChannelType = {
"transform", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
| | > > > > | | 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 |
* This structure describes the channel type structure for Tcl-based
* transformations.
*/
static const Tcl_ChannelType transformChannelType = {
"transform", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
TCL_CLOSE2PROC, /* Close proc. */
TransformInputProc, /* Input proc. */
TransformOutputProc, /* Output proc. */
#ifndef TCL_NO_DEPRECATED
TransformSeekProc, /* Seek proc. */
#else
NULL, /* Seek proc. */
#endif
TransformSetOptionProc, /* Set option proc. */
TransformGetOptionProc, /* Get option proc. */
TransformWatchProc, /* Initialize notifier. */
TransformGetFileHandleProc, /* Get OS handles out of channel. */
TransformCloseProc, /* close2proc */
TransformBlockModeProc, /* Set blocking/nonblocking mode.*/
NULL, /* Flush proc. */
TransformNotifyProc, /* Handling of events bubbling up. */
TransformWideSeekProc, /* Wide seek proc. */
NULL, /* Thread action. */
NULL /* Truncate. */
};
|
| ︙ | ︙ | |||
226 227 228 229 230 231 232 |
TransformChannelData *dataPtr)
{
if (dataPtr->refCount-- > 1) {
return;
}
ResultClear(&dataPtr->result);
Tcl_DecrRefCount(dataPtr->command);
| | < | 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 |
TransformChannelData *dataPtr)
{
if (dataPtr->refCount-- > 1) {
return;
}
ResultClear(&dataPtr->result);
Tcl_DecrRefCount(dataPtr->command);
ckfree(dataPtr);
}
/*
*----------------------------------------------------------------------
*
* TclChannelTransform --
*
* Implements the Tcl "testchannel transform" debugging command. This is
* part of the testing environment. This sets up a tcl script (cmdObjPtr)
* to be used as a transform on the channel.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclChannelTransform(
Tcl_Interp *interp, /* Interpreter for result. */
Tcl_Channel chan, /* Channel to transform. */
Tcl_Obj *cmdObjPtr) /* Script to use for transform. */
{
Channel *chanPtr; /* The actual channel. */
|
| ︙ | ︙ | |||
283 284 285 286 287 288 289 |
/*
* Now initialize the transformation state and stack it upon the specified
* channel. One of the necessary things to do is to retrieve the blocking
* regime of the underlying channel and to use the same for us too.
*/
| | | 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 |
/*
* Now initialize the transformation state and stack it upon the specified
* channel. One of the necessary things to do is to retrieve the blocking
* regime of the underlying channel and to use the same for us too.
*/
dataPtr = (TransformChannelData *)ckalloc(sizeof(TransformChannelData));
dataPtr->refCount = 1;
Tcl_DStringInit(&ds);
Tcl_GetChannelOption(interp, chan, "-blocking", &ds);
dataPtr->readIsFlushed = 0;
dataPtr->eofPending = 0;
dataPtr->flags = 0;
|
| ︙ | ︙ | |||
374 375 376 377 378 379 380 |
* callback is sent to the underlying channel
* or not. */
int preserve) /* Flag. If true the procedure will preserve
* the result state of all accessed
* interpreters. */
{
Tcl_Obj *resObj; /* See below, switch (transmit). */
| | | 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 |
* callback is sent to the underlying channel
* or not. */
int preserve) /* Flag. If true the procedure will preserve
* the result state of all accessed
* interpreters. */
{
Tcl_Obj *resObj; /* See below, switch (transmit). */
int resLen;
unsigned char *resBuf;
Tcl_InterpState state = NULL;
int res = TCL_OK;
Tcl_Obj *command = TclListObjCopy(NULL, dataPtr->command);
Tcl_Interp *eval = dataPtr->interp;
Tcl_Preserve(eval);
|
| ︙ | ︙ | |||
439 440 441 442 443 444 445 |
break;
case TRANSMIT_DOWN:
if (dataPtr->self == NULL) {
break;
}
resObj = Tcl_GetObjResult(eval);
| | | | | 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 |
break;
case TRANSMIT_DOWN:
if (dataPtr->self == NULL) {
break;
}
resObj = Tcl_GetObjResult(eval);
resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen);
Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), (char *) resBuf,
resLen);
break;
case TRANSMIT_SELF:
if (dataPtr->self == NULL) {
break;
}
resObj = Tcl_GetObjResult(eval);
resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen);
Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen);
break;
case TRANSMIT_IBUF:
resObj = Tcl_GetObjResult(eval);
resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen);
ResultAdd(&dataPtr->result, resBuf, resLen);
break;
case TRANSMIT_NUM:
/*
* Interpret result as integer number.
*/
|
| ︙ | ︙ | |||
499 500 501 502 503 504 505 |
*/
static int
TransformBlockModeProc(
ClientData instanceData, /* State of transformation. */
int mode) /* New blocking mode. */
{
| | | 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 |
*/
static int
TransformBlockModeProc(
ClientData instanceData, /* State of transformation. */
int mode) /* New blocking mode. */
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
if (mode == TCL_MODE_NONBLOCKING) {
dataPtr->flags |= CHANNEL_ASYNC;
} else {
dataPtr->flags &= ~CHANNEL_ASYNC;
}
return 0;
|
| ︙ | ︙ | |||
529 530 531 532 533 534 535 |
*
*----------------------------------------------------------------------
*/
static int
TransformCloseProc(
ClientData instanceData,
| | > | > > > > | 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 |
*
*----------------------------------------------------------------------
*/
static int
TransformCloseProc(
ClientData instanceData,
Tcl_Interp *interp,
int flags)
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
/*
* Important: In this procedure 'dataPtr->self' already points to the
* underlying channel.
*
* There is no need to cancel an existing channel handler, this is already
* done. Either by 'Tcl_UnstackChannel' or by the general cleanup in
|
| ︙ | ︙ | |||
612 613 614 615 616 617 618 |
static int
TransformInputProc(
ClientData instanceData,
char *buf,
int toRead,
int *errorCodePtr)
{
| | | 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 |
static int
TransformInputProc(
ClientData instanceData,
char *buf,
int toRead,
int *errorCodePtr)
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
int gotBytes, read, copied;
Tcl_Channel downChan;
/*
* Should assert(dataPtr->mode & TCL_READABLE);
*/
|
| ︙ | ︙ | |||
779 780 781 782 783 784 785 |
static int
TransformOutputProc(
ClientData instanceData,
const char *buf,
int toWrite,
int *errorCodePtr)
{
| | | 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 |
static int
TransformOutputProc(
ClientData instanceData,
const char *buf,
int toWrite,
int *errorCodePtr)
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
/*
* Should assert(dataPtr->mode & TCL_WRITABLE);
*/
if (toWrite == 0) {
/*
|
| ︙ | ︙ | |||
824 825 826 827 828 829 830 831 832 833 834 835 836 837 |
* Result:
* -1 if failed, the new position if successful. An output argument
* contains the POSIX error code if an error occurred, or zero.
*
*----------------------------------------------------------------------
*/
static int
TransformSeekProc(
ClientData instanceData, /* The channel to manipulate. */
long offset, /* Size of movement. */
int mode, /* How to move. */
int *errorCodePtr) /* Location of error flag. */
{
| > | | 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 |
* Result:
* -1 if failed, the new position if successful. An output argument
* contains the POSIX error code if an error occurred, or zero.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
static int
TransformSeekProc(
ClientData instanceData, /* The channel to manipulate. */
long offset, /* Size of movement. */
int mode, /* How to move. */
int *errorCodePtr) /* Location of error flag. */
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self);
const Tcl_ChannelType *parentType = Tcl_GetChannelType(parent);
Tcl_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType);
if ((offset == 0) && (mode == SEEK_CUR)) {
/*
* This is no seek but a request to tell the caller the current
|
| ︙ | ︙ | |||
870 871 872 873 874 875 876 877 878 879 880 881 882 883 |
dataPtr->eofPending = 0;
}
ReleaseData(dataPtr);
return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset, mode,
errorCodePtr);
}
/*
*----------------------------------------------------------------------
*
* TransformWideSeekProc --
*
* This procedure is called by the generic IO level to move the access
| > | 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 |
dataPtr->eofPending = 0;
}
ReleaseData(dataPtr);
return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset, mode,
errorCodePtr);
}
#endif
/*
*----------------------------------------------------------------------
*
* TransformWideSeekProc --
*
* This procedure is called by the generic IO level to move the access
|
| ︙ | ︙ | |||
898 899 900 901 902 903 904 |
static Tcl_WideInt
TransformWideSeekProc(
ClientData instanceData, /* The channel to manipulate. */
Tcl_WideInt offset, /* Size of movement. */
int mode, /* How to move. */
int *errorCodePtr) /* Location of error flag. */
{
| | > > < | > | > > > > > | 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 |
static Tcl_WideInt
TransformWideSeekProc(
ClientData instanceData, /* The channel to manipulate. */
Tcl_WideInt offset, /* Size of movement. */
int mode, /* How to move. */
int *errorCodePtr) /* Location of error flag. */
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self);
const Tcl_ChannelType *parentType = Tcl_GetChannelType(parent);
#ifndef TCL_NO_DEPRECATED
Tcl_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType);
#endif
Tcl_DriverWideSeekProc *parentWideSeekProc =
Tcl_ChannelWideSeekProc(parentType);
ClientData parentData = Tcl_GetChannelInstanceData(parent);
if ((offset == 0) && (mode == SEEK_CUR)) {
/*
* This is no seek but a request to tell the caller the current
* location. Simply pass the request down.
*/
if (parentWideSeekProc != NULL) {
return parentWideSeekProc(parentData, offset, mode, errorCodePtr);
#ifndef TCL_NO_DEPRECATED
} else if (parentSeekProc) {
return parentSeekProc(parentData, 0, mode, errorCodePtr);
#endif
} else {
*errorCodePtr = EINVAL;
return -1;
}
}
/*
* It is a real request to change the position. Flush all data waiting for
* output and discard everything in the input buffers. Then pass the
* request down, unchanged.
*/
|
| ︙ | ︙ | |||
944 945 946 947 948 949 950 |
}
ReleaseData(dataPtr);
/*
* If we have a wide seek capability, we should stick with that.
*/
| | < < < | | | | | | | > | | | | | | > > > > > > | 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 |
}
ReleaseData(dataPtr);
/*
* If we have a wide seek capability, we should stick with that.
*/
if (parentWideSeekProc == NULL) {
/*
* We're transferring to narrow seeks at this point; this is a bit complex
* because we have to check whether the seek is possible first (i.e.
* whether we are losing information in truncating the bits of the
* offset). Luckily, there's a defined error for what happens when trying
* to go out of the representable range.
*/
#ifndef TCL_NO_DEPRECATED
if (offset<LONG_MIN || offset>LONG_MAX) {
*errorCodePtr = EOVERFLOW;
return -1;
}
return parentSeekProc(parentData, offset,
mode, errorCodePtr);
#else
*errorCodePtr = EINVAL;
return -1;
#endif
}
return parentWideSeekProc(parentData, offset, mode, errorCodePtr);
}
/*
*----------------------------------------------------------------------
*
* TransformSetOptionProc --
*
|
| ︙ | ︙ | |||
990 991 992 993 994 995 996 |
static int
TransformSetOptionProc(
ClientData instanceData,
Tcl_Interp *interp,
const char *optionName,
const char *value)
{
| | | 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 |
static int
TransformSetOptionProc(
ClientData instanceData,
Tcl_Interp *interp,
const char *optionName,
const char *value)
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self);
Tcl_DriverSetOptionProc *setOptionProc;
setOptionProc = Tcl_ChannelSetOptionProc(Tcl_GetChannelType(downChan));
if (setOptionProc == NULL) {
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1028 1029 1030 1031 1032 1033 1034 |
static int
TransformGetOptionProc(
ClientData instanceData,
Tcl_Interp *interp,
const char *optionName,
Tcl_DString *dsPtr)
{
| | | 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 |
static int
TransformGetOptionProc(
ClientData instanceData,
Tcl_Interp *interp,
const char *optionName,
Tcl_DString *dsPtr)
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self);
Tcl_DriverGetOptionProc *getOptionProc;
getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan));
if (getOptionProc != NULL) {
return getOptionProc(Tcl_GetChannelInstanceData(downChan), interp,
optionName, dsPtr);
|
| ︙ | ︙ | |||
1068 1069 1070 1071 1072 1073 1074 | * * Result: * None. * *---------------------------------------------------------------------- */ | < | | 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 |
*
* Result:
* None.
*
*----------------------------------------------------------------------
*/
static void
TransformWatchProc(
ClientData instanceData, /* Channel to watch. */
int mask) /* Events of interest. */
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
Tcl_Channel downChan;
/*
* The caller expressed interest in events occuring for this channel. We
* are forwarding the call to the underlying channel now.
*/
|
| ︙ | ︙ | |||
1153 1154 1155 1156 1157 1158 1159 |
static int
TransformGetFileHandleProc(
ClientData instanceData, /* Channel to query. */
int direction, /* Direction of interest. */
ClientData *handlePtr) /* Place to store the handle into. */
{
| | | 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 |
static int
TransformGetFileHandleProc(
ClientData instanceData, /* Channel to query. */
int direction, /* Direction of interest. */
ClientData *handlePtr) /* Place to store the handle into. */
{
TransformChannelData *dataPtr = (TransformChannelData *)instanceData;
/*
* Return the handle belonging to parent channel. IOW, pass the request
* down and the result up.
*/
return Tcl_GetChannelHandle(Tcl_GetStackedChannel(dataPtr->self),
|
| ︙ | ︙ | |||
1187 1188 1189 1190 1191 1192 1193 |
static int
TransformNotifyProc(
ClientData clientData, /* The state of the notified
* transformation. */
int mask) /* The mask of occuring events. */
{
| | | 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 |
static int
TransformNotifyProc(
ClientData clientData, /* The state of the notified
* transformation. */
int mask) /* The mask of occuring events. */
{
TransformChannelData *dataPtr = (TransformChannelData *)clientData;
/*
* An event occured in the underlying channel. This transformation doesn't
* process such events thus returns the incoming mask unchanged.
*/
if (dataPtr->timer != NULL) {
|
| ︙ | ︙ | |||
1230 1231 1232 1233 1234 1235 1236 |
*----------------------------------------------------------------------
*/
static void
TransformChannelHandlerTimer(
ClientData clientData) /* Transformation to query. */
{
| | | 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 |
*----------------------------------------------------------------------
*/
static void
TransformChannelHandlerTimer(
ClientData clientData) /* Transformation to query. */
{
TransformChannelData *dataPtr = (TransformChannelData *)clientData;
dataPtr->timer = NULL;
if (!(dataPtr->watchMask&TCL_READABLE) || ResultEmpty(&dataPtr->result)) {
/*
* The timer fired, but either is there no (more) interest in the
* events it generates or nothing is available for reading, so ignore
* it and don't recreate it.
|
| ︙ | ︙ | |||
1268 1269 1270 1271 1272 1273 1274 |
static inline void
ResultClear(
ResultBuffer *r) /* Reference to the buffer to clear out. */
{
r->used = 0;
if (r->allocated) {
| | | 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 |
static inline void
ResultClear(
ResultBuffer *r) /* Reference to the buffer to clear out. */
{
r->used = 0;
if (r->allocated) {
ckfree(r->buf);
r->buf = NULL;
r->allocated = 0;
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1412 1413 1414 1415 1416 1417 1418 |
if (r->used + toWrite > r->allocated) {
/*
* Extension of the internal buffer is required.
*/
if (r->allocated == 0) {
r->allocated = toWrite + INCREMENT;
| | | | 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 |
if (r->used + toWrite > r->allocated) {
/*
* Extension of the internal buffer is required.
*/
if (r->allocated == 0) {
r->allocated = toWrite + INCREMENT;
r->buf = (unsigned char *)ckalloc(r->allocated);
} else {
r->allocated += toWrite + INCREMENT;
r->buf = (unsigned char *)ckrealloc(r->buf, r->allocated);
}
}
/*
* Now we may copy the data.
*/
|
| ︙ | ︙ |
Changes to generic/tclIORChan.c.
| ︙ | ︙ | |||
28 29 30 31 32 33 34 | #endif /* * Signatures of all functions used in the C layer of the reflection. */ static int ReflectClose(ClientData clientData, | | > > | > > > > | | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 |
#endif
/*
* Signatures of all functions used in the C layer of the reflection.
*/
static int ReflectClose(ClientData clientData,
Tcl_Interp *interp, int flags);
static int ReflectInput(ClientData clientData, char *buf,
int toRead, int *errorCodePtr);
static int ReflectOutput(ClientData clientData, const char *buf,
int toWrite, int *errorCodePtr);
static void ReflectWatch(ClientData clientData, int mask);
static int ReflectBlock(ClientData clientData, int mode);
#if TCL_THREADS
static void ReflectThread(ClientData clientData, int action);
static int ReflectEventRun(Tcl_Event *ev, int flags);
static int ReflectEventDelete(Tcl_Event *ev, ClientData cd);
#endif
static Tcl_WideInt ReflectSeekWide(ClientData clientData,
Tcl_WideInt offset, int mode, int *errorCodePtr);
#ifndef TCL_NO_DEPRECATED
static int ReflectSeek(ClientData clientData, long offset,
int mode, int *errorCodePtr);
#endif
static int ReflectGetOption(ClientData clientData,
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
static int ReflectSetOption(ClientData clientData,
Tcl_Interp *interp, const char *optionName,
const char *newValue);
static void TimerRunRead(ClientData clientData);
static void TimerRunWrite(ClientData clientData);
/*
* The C layer channel type/driver definition used by the reflection. This is
* a version 3 structure.
*/
static const Tcl_ChannelType tclRChannelType = {
"tclrchannel", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
TCL_CLOSE2PROC, /* Close channel, clean instance data */
ReflectInput, /* Handle read request */
ReflectOutput, /* Handle write request */
#ifndef TCL_NO_DEPRECATED
ReflectSeek, /* Move location of access point. NULL'able */
#else
NULL,
#endif
ReflectSetOption, /* Set options. NULL'able */
ReflectGetOption, /* Get options. NULL'able */
ReflectWatch, /* Initialize notifier */
NULL, /* Get OS handle from the channel. NULL'able */
ReflectClose, /* No close2 support. NULL'able */
ReflectBlock, /* Set blocking/nonblocking. NULL'able */
NULL, /* Flush channel. Not used by core. NULL'able */
NULL, /* Handle events. NULL'able */
ReflectSeekWide, /* Move access point (64 bit). NULL'able */
#if TCL_THREADS
ReflectThread, /* thread action, tracking owner */
#else
NULL, /* thread action */
#endif
NULL /* truncate */
};
/*
* Instance data for a reflected channel. ===========================
*/
|
| ︙ | ︙ | |||
259 260 261 262 263 264 265 |
* ForwardParamBase. Where an operation does not need any special types, it
* has no "subtype" and just uses ForwardParamBase, as listed above.)
*/
struct ForwardParamInput {
ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
char *buf; /* O: Where to store the read bytes */
| | | 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 |
* ForwardParamBase. Where an operation does not need any special types, it
* has no "subtype" and just uses ForwardParamBase, as listed above.)
*/
struct ForwardParamInput {
ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
char *buf; /* O: Where to store the read bytes */
int toRead; /* I: #bytes to read,
* O: #bytes actually read */
};
struct ForwardParamOutput {
ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
const char *buf; /* I: Where the bytes to write come from */
int toWrite; /* I: #bytes to write,
* O: #bytes actually written */
|
| ︙ | ︙ | |||
392 393 394 395 396 397 398 |
static void ForwardOpToHandlerThread(ReflectedChannel *rcPtr,
ForwardedOperation op, const void *param);
static int ForwardProc(Tcl_Event *evPtr, int mask);
static void SrcExitProc(ClientData clientData);
#define FreeReceivedError(p) \
if ((p)->base.mustFree) { \
| | | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 |
static void ForwardOpToHandlerThread(ReflectedChannel *rcPtr,
ForwardedOperation op, const void *param);
static int ForwardProc(Tcl_Event *evPtr, int mask);
static void SrcExitProc(ClientData clientData);
#define FreeReceivedError(p) \
if ((p)->base.mustFree) { \
ckfree((p)->base.msgStr); \
}
#define PassReceivedErrorInterp(i,p) \
if ((i) != NULL) { \
Tcl_SetChannelErrorInterp((i), \
Tcl_NewStringObj((p)->base.msgStr, -1)); \
} \
FreeReceivedError(p)
|
| ︙ | ︙ | |||
415 416 417 418 419 420 421 | (p)->base.code = TCL_ERROR; \ (p)->base.mustFree = 1; \ (p)->base.msgStr = (char *) (emsg) static void ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr); static ReflectedChannelMap * GetThreadReflectedChannelMap(void); | | | 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 | (p)->base.code = TCL_ERROR; \ (p)->base.mustFree = 1; \ (p)->base.msgStr = (char *) (emsg) static void ForwardSetObjError(ForwardParam *p, Tcl_Obj *objPtr); static ReflectedChannelMap * GetThreadReflectedChannelMap(void); static Tcl_ExitProc DeleteThreadReflectedChannelMap; #endif /* TCL_THREADS */ #define SetChannelErrorStr(c,msgStr) \ Tcl_SetChannelError((c), Tcl_NewStringObj((msgStr), -1)) static Tcl_Obj * MarshallError(Tcl_Interp *interp); |
| ︙ | ︙ | |||
442 443 444 445 446 447 448 | static Tcl_Obj * NextHandle(void); static void FreeReflectedChannel(ReflectedChannel *rcPtr); static int InvokeTclMethod(ReflectedChannel *rcPtr, MethodName method, Tcl_Obj *argOneObj, Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr); static ReflectedChannelMap * GetReflectedChannelMap(Tcl_Interp *interp); | | < | 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 | static Tcl_Obj * NextHandle(void); static void FreeReflectedChannel(ReflectedChannel *rcPtr); static int InvokeTclMethod(ReflectedChannel *rcPtr, MethodName method, Tcl_Obj *argOneObj, Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr); static ReflectedChannelMap * GetReflectedChannelMap(Tcl_Interp *interp); static Tcl_InterpDeleteProc DeleteReflectedChannelMap; static int ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj *resObj); static void MarkDead(ReflectedChannel *rcPtr); /* * Global constant strings (messages). ================== * These string are used directly as bypass errors, thus they have to be valid * Tcl lists where the last element is the message itself. Hence the |
| ︙ | ︙ | |||
488 489 490 491 492 493 494 | * Creates a new channel. * *---------------------------------------------------------------------- */ int TclChanCreateObjCmd( | | | 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 |
* Creates a new channel.
*
*----------------------------------------------------------------------
*/
int
TclChanCreateObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
ReflectedChannel *rcPtr; /* Instance data of the new channel */
Tcl_Obj *rcId; /* Handle of the new channel */
int mode; /* R/W mode of new channel. Has to match
|
| ︙ | ︙ | |||
677 678 679 680 681 682 683 |
if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) {
/*
* Some of the nullable methods are not supported. We clone the
* channel type, null the associated C functions, and use the result
* as the actual channel type.
*/
| | > > | 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 |
if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) {
/*
* Some of the nullable methods are not supported. We clone the
* channel type, null the associated C functions, and use the result
* as the actual channel type.
*/
Tcl_ChannelType *clonePtr = (Tcl_ChannelType *)ckalloc(sizeof(Tcl_ChannelType));
memcpy(clonePtr, &tclRChannelType, sizeof(Tcl_ChannelType));
if (!(methods & FLAG(METH_CONFIGURE))) {
clonePtr->setOptionProc = NULL;
}
if (!(methods & FLAG(METH_CGET)) && !(methods & FLAG(METH_CGETALL))) {
clonePtr->getOptionProc = NULL;
}
if (!(methods & FLAG(METH_BLOCKING))) {
clonePtr->blockModeProc = NULL;
}
if (!(methods & FLAG(METH_SEEK))) {
#ifndef TCL_NO_DEPRECATED
clonePtr->seekProc = NULL;
#endif
clonePtr->wideSeekProc = NULL;
}
chanPtr->typePtr = clonePtr;
}
/*
|
| ︙ | ︙ | |||
732 733 734 735 736 737 738 |
Tcl_NewStringObj(chanPtr->state->channelName, -1));
return TCL_OK;
error:
Tcl_DecrRefCount(rcPtr->name);
Tcl_DecrRefCount(rcPtr->methods);
Tcl_DecrRefCount(rcPtr->cmd);
| | | 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 |
Tcl_NewStringObj(chanPtr->state->channelName, -1));
return TCL_OK;
error:
Tcl_DecrRefCount(rcPtr->name);
Tcl_DecrRefCount(rcPtr->methods);
Tcl_DecrRefCount(rcPtr->cmd);
ckfree(rcPtr);
return TCL_ERROR;
#undef MODE
#undef CMD
}
/*
|
| ︙ | ︙ | |||
767 768 769 770 771 772 773 |
ReflectedChannel *rcPtr;
int events;
} ReflectEvent;
static int
ReflectEventRun(
Tcl_Event *ev,
| | | 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 |
ReflectedChannel *rcPtr;
int events;
} ReflectEvent;
static int
ReflectEventRun(
Tcl_Event *ev,
TCL_UNUSED(int) /*flags*/)
{
/* OWNER thread
*
* Note: When the channel is closed any pending events of this type are
* deleted. See ReflectClose() for the Tcl_DeleteEvents() calls
* accomplishing that.
*/
|
| ︙ | ︙ | |||
805 806 807 808 809 810 811 |
}
return 1;
}
#endif
int
TclChanPostEventObjCmd(
| | | 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 |
}
return 1;
}
#endif
int
TclChanPostEventObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
/*
* Ensure -> HANDLER thread
*
|
| ︙ | ︙ | |||
878 879 880 881 882 883 884 |
* defined in this interpreter.
*
* We keep the old checks for both, for paranioa, but abort now instead of
* throwing errors, as failure now means that our internal datastructures
* have gone seriously haywire.
*/
| | | | 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 |
* defined in this interpreter.
*
* We keep the old checks for both, for paranioa, but abort now instead of
* throwing errors, as failure now means that our internal datastructures
* have gone seriously haywire.
*/
chan = (Tcl_Channel)Tcl_GetHashValue(hPtr);
chanTypePtr = Tcl_GetChannelType(chan);
/*
* We use a function referenced by the channel type as our cookie to
* detect calls to non-reflecting channels. The channel type itself is not
* suitable, as it might not be the static definition in this file, but a
* clone thereof. And while we have reserved the name of the type nothing
* in the core checks against violation, so someone else might have
* created a channel type using our name, clashing with ourselves.
*/
if (chanTypePtr->watchProc != &ReflectWatch) {
Tcl_Panic("TclChanPostEventObjCmd: channel is not a reflected channel");
}
rcPtr = (ReflectedChannel *)Tcl_GetChannelInstanceData(chan);
if (rcPtr->interp != interp) {
Tcl_Panic("TclChanPostEventObjCmd: postevent accepted for call from outside interpreter");
}
/*
* Second argument is a list of events. Allowed entries are "read",
|
| ︙ | ︙ | |||
941 942 943 944 945 946 947 |
if (rcPtr->writeTimer == NULL) {
rcPtr->writeTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
TimerRunWrite, rcPtr);
}
}
#if TCL_THREADS
} else {
| | | 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 |
if (rcPtr->writeTimer == NULL) {
rcPtr->writeTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME,
TimerRunWrite, rcPtr);
}
}
#if TCL_THREADS
} else {
ReflectEvent *ev = (ReflectEvent *)ckalloc(sizeof(ReflectEvent));
ev->header.proc = ReflectEventRun;
ev->events = events;
ev->rcPtr = rcPtr;
/*
* We are not preserving the structure here. When the channel is
|
| ︙ | ︙ | |||
990 991 992 993 994 995 996 |
#undef EVENT
}
static void
TimerRunRead(
ClientData clientData)
{
| | | | 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 |
#undef EVENT
}
static void
TimerRunRead(
ClientData clientData)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
rcPtr->readTimer = NULL;
Tcl_NotifyChannel(rcPtr->chan, TCL_READABLE);
}
static void
TimerRunWrite(
ClientData clientData)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
rcPtr->writeTimer = NULL;
Tcl_NotifyChannel(rcPtr->chan, TCL_WRITABLE);
}
/*
* Channel error message marshalling utilities.
*/
|
| ︙ | ︙ | |||
1146 1147 1148 1149 1150 1151 1152 |
*
*----------------------------------------------------------------------
*/
static int
ReflectClose(
ClientData clientData,
| | > | > > > > | 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 |
*
*----------------------------------------------------------------------
*/
static int
ReflectClose(
ClientData clientData,
Tcl_Interp *interp,
int flags)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
int result; /* Result code for 'close' */
Tcl_Obj *resObj; /* Result data for 'close' */
ReflectedChannelMap *rcmPtr;/* Map of reflected channels with handlers in
* this interp */
Tcl_HashEntry *hPtr; /* Entry in the above map */
const Tcl_ChannelType *tctPtr;
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
if (TclInThreadExit()) {
/*
* This call comes from TclFinalizeIOSystem. There are no
* interpreters, and therefore we cannot call upon the handler command
* anymore. Threading is irrelevant as well. We simply clean up all
* our C level data structures and leave the Tcl level to the other
|
| ︙ | ︙ | |||
1194 1195 1196 1197 1198 1199 1200 |
FreeReceivedError(&p);
}
}
#endif
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &tclRChannelType) {
| | | 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 |
FreeReceivedError(&p);
}
}
#endif
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &tclRChannelType) {
ckfree(tctPtr);
((Channel *)rcPtr->chan)->typePtr = NULL;
}
if (rcPtr->readTimer != NULL) {
Tcl_DeleteTimerHandler(rcPtr->readTimer);
}
if (rcPtr->writeTimer != NULL) {
Tcl_DeleteTimerHandler(rcPtr->writeTimer);
|
| ︙ | ︙ | |||
1269 1270 1271 1272 1273 1274 1275 |
if (hPtr) {
Tcl_DeleteHashEntry(hPtr);
}
}
#endif
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &tclRChannelType) {
| | | 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 |
if (hPtr) {
Tcl_DeleteHashEntry(hPtr);
}
}
#endif
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &tclRChannelType) {
ckfree(tctPtr);
((Channel *)rcPtr->chan)->typePtr = NULL;
}
if (rcPtr->readTimer != NULL) {
Tcl_DeleteTimerHandler(rcPtr->readTimer);
}
if (rcPtr->writeTimer != NULL) {
Tcl_DeleteTimerHandler(rcPtr->writeTimer);
|
| ︙ | ︙ | |||
1305 1306 1307 1308 1309 1310 1311 |
static int
ReflectInput(
ClientData clientData,
char *buf,
int toRead,
int *errorCodePtr)
{
| | | | | | | 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 |
static int
ReflectInput(
ClientData clientData,
char *buf,
int toRead,
int *errorCodePtr)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
Tcl_Obj *toReadObj;
int bytec; /* Number of returned bytes */
unsigned char *bytev; /* Array of returned bytes */
Tcl_Obj *resObj; /* Result data for 'read' */
/*
* Are we in the correct thread?
*/
#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
p.input.buf = buf;
p.input.toRead = toRead;
ForwardOpToHandlerThread(rcPtr, ForwardedInput, &p);
if (p.base.code != TCL_OK) {
if (p.base.code < 0) {
/*
* No error message, this is an errno signal.
*/
*errorCodePtr = -p.base.code;
} else {
PassReceivedError(rcPtr->chan, &p);
*errorCodePtr = EINVAL;
}
p.input.toRead = -1;
} else {
*errorCodePtr = EOK;
}
return p.input.toRead;
}
#endif
|
| ︙ | ︙ | |||
1364 1365 1366 1367 1368 1369 1370 |
goto error;
}
Tcl_SetChannelError(rcPtr->chan, resObj);
goto invalid;
}
| | | | | | 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 |
goto error;
}
Tcl_SetChannelError(rcPtr->chan, resObj);
goto invalid;
}
bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
if (toRead < bytec) {
SetChannelErrorStr(rcPtr->chan, msg_read_toomuch);
goto invalid;
}
*errorCodePtr = EOK;
if (bytec > 0) {
memcpy(buf, bytev, bytec);
}
stop:
Tcl_DecrRefCount(toReadObj);
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
Tcl_Release(rcPtr);
|
| ︙ | ︙ | |||
1412 1413 1414 1415 1416 1417 1418 |
static int
ReflectOutput(
ClientData clientData,
const char *buf,
int toWrite,
int *errorCodePtr)
{
| | | | | 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 |
static int
ReflectOutput(
ClientData clientData,
const char *buf,
int toWrite,
int *errorCodePtr)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
Tcl_Obj *bufObj;
Tcl_Obj *resObj; /* Result data for 'write' */
int written;
/*
* Are we in the correct thread?
*/
#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
p.output.buf = buf;
p.output.toWrite = toWrite;
ForwardOpToHandlerThread(rcPtr, ForwardedOutput, &p);
if (p.base.code != TCL_OK) {
if (p.base.code < 0) {
/*
* No error message, this is an errno signal.
*/
*errorCodePtr = -p.base.code;
} else {
PassReceivedError(rcPtr->chan, &p);
*errorCodePtr = EINVAL;
}
p.output.toWrite = -1;
|
| ︙ | ︙ | |||
1541 1542 1543 1544 1545 1546 1547 |
static Tcl_WideInt
ReflectSeekWide(
ClientData clientData,
Tcl_WideInt offset,
int seekMode,
int *errorCodePtr)
{
| | | 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 |
static Tcl_WideInt
ReflectSeekWide(
ClientData clientData,
Tcl_WideInt offset,
int seekMode,
int *errorCodePtr)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
Tcl_Obj *offObj, *baseObj;
Tcl_Obj *resObj; /* Result for 'seek' */
Tcl_WideInt newLoc;
/*
* Are we in the correct thread?
*/
|
| ︙ | ︙ | |||
1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 |
return newLoc;
invalid:
*errorCodePtr = EINVAL;
newLoc = -1;
goto stop;
}
static int
ReflectSeek(
ClientData clientData,
long offset,
int seekMode,
int *errorCodePtr)
{
/*
* This function can be invoked from a transformation which is based on
* standard seeking, i.e. non-wide. Because of this we have to implement
* it, a dummy is not enough. We simply delegate the call to the wide
* routine.
*/
return ReflectSeekWide(clientData, offset, seekMode,
errorCodePtr);
}
/*
*----------------------------------------------------------------------
*
* ReflectWatch --
*
* This function is invoked to tell the channel what events the I/O
| > > | 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 |
return newLoc;
invalid:
*errorCodePtr = EINVAL;
newLoc = -1;
goto stop;
}
#ifndef TCL_NO_DEPRECATED
static int
ReflectSeek(
ClientData clientData,
long offset,
int seekMode,
int *errorCodePtr)
{
/*
* This function can be invoked from a transformation which is based on
* standard seeking, i.e. non-wide. Because of this we have to implement
* it, a dummy is not enough. We simply delegate the call to the wide
* routine.
*/
return ReflectSeekWide(clientData, offset, seekMode,
errorCodePtr);
}
#endif
/*
*----------------------------------------------------------------------
*
* ReflectWatch --
*
* This function is invoked to tell the channel what events the I/O
|
| ︙ | ︙ | |||
1650 1651 1652 1653 1654 1655 1656 |
*/
static void
ReflectWatch(
ClientData clientData,
int mask)
{
| | | 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 |
*/
static void
ReflectWatch(
ClientData clientData,
int mask)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
Tcl_Obj *maskObj;
/*
* We restrict the interest to what the channel can support. IOW there
* will never be write events for a channel which is not writable.
* Analoguously for read events and non-readable channels.
*/
|
| ︙ | ︙ | |||
1722 1723 1724 1725 1726 1727 1728 |
*/
static int
ReflectBlock(
ClientData clientData,
int nonblocking)
{
| | | 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 |
*/
static int
ReflectBlock(
ClientData clientData,
int nonblocking)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
Tcl_Obj *blockObj;
int errorNum; /* EINVAL or EOK (success). */
Tcl_Obj *resObj; /* Result data for 'blocking' */
/*
* Are we in the correct thread?
*/
|
| ︙ | ︙ | |||
1789 1790 1791 1792 1793 1794 1795 |
*/
static void
ReflectThread(
ClientData clientData,
int action)
{
| | | 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 |
*/
static void
ReflectThread(
ClientData clientData,
int action)
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
switch (action) {
case TCL_CHANNEL_THREAD_INSERT:
rcPtr->owner = Tcl_GetCurrentThread();
break;
case TCL_CHANNEL_THREAD_REMOVE:
rcPtr->owner = NULL;
|
| ︙ | ︙ | |||
1828 1829 1830 1831 1832 1833 1834 |
static int
ReflectSetOption(
ClientData clientData, /* Channel to query */
Tcl_Interp *interp, /* Interpreter to leave error messages in */
const char *optionName, /* Name of requested option */
const char *newValue) /* The new value */
{
| | | 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 |
static int
ReflectSetOption(
ClientData clientData, /* Channel to query */
Tcl_Interp *interp, /* Interpreter to leave error messages in */
const char *optionName, /* Name of requested option */
const char *newValue) /* The new value */
{
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
Tcl_Obj *optionObj, *valueObj;
int result; /* Result code for 'configure' */
Tcl_Obj *resObj; /* Result data for 'configure' */
/*
* Are we in the correct thread?
*/
|
| ︙ | ︙ | |||
1905 1906 1907 1908 1909 1910 1911 |
Tcl_DString *dsPtr) /* String to place the result into */
{
/*
* This code is special. It has regular passing of Tcl result, and errors.
* The bypass functions are not required.
*/
| | | | 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 |
Tcl_DString *dsPtr) /* String to place the result into */
{
/*
* This code is special. It has regular passing of Tcl result, and errors.
* The bypass functions are not required.
*/
ReflectedChannel *rcPtr = (ReflectedChannel *)clientData;
Tcl_Obj *optionObj;
Tcl_Obj *resObj; /* Result data for 'configure' */
int listc, result = TCL_OK;
Tcl_Obj **listv;
MethodName method;
/*
* Are we in the correct thread?
*/
#if TCL_THREADS
if (rcPtr->thread != Tcl_GetCurrentThread()) {
ForwardedOperation opcode;
ForwardParam p;
p.getOpt.name = optionName;
p.getOpt.value = dsPtr;
if (optionName == NULL) {
opcode = ForwardedGetOptAll;
|
| ︙ | ︙ | |||
2005 2006 2007 2008 2009 2010 2011 |
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Expected list with even number of "
"elements, got %d element%s instead", listc,
(listc == 1 ? "" : "s")));
goto error;
} else {
| | | 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 |
Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"Expected list with even number of "
"elements, got %d element%s instead", listc,
(listc == 1 ? "" : "s")));
goto error;
} else {
int len;
const char *str = TclGetStringFromObj(resObj, &len);
if (len) {
TclDStringAppendLiteral(dsPtr, " ");
Tcl_DStringAppend(dsPtr, str, len);
}
goto ok;
|
| ︙ | ︙ | |||
2121 2122 2123 2124 2125 2126 2127 |
*----------------------------------------------------------------------
*/
static Tcl_Obj *
DecodeEventMask(
int mask)
{
| | | 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 |
*----------------------------------------------------------------------
*/
static Tcl_Obj *
DecodeEventMask(
int mask)
{
const char *eventStr;
Tcl_Obj *evObj;
switch (mask & RANDW) {
case RANDW:
eventStr = "read write";
break;
case TCL_READABLE:
|
| ︙ | ︙ | |||
2170 2171 2172 2173 2174 2175 2176 |
NewReflectedChannel(
Tcl_Interp *interp,
Tcl_Obj *cmdpfxObj,
int mode,
Tcl_Obj *handleObj)
{
ReflectedChannel *rcPtr;
| | | | | 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 |
NewReflectedChannel(
Tcl_Interp *interp,
Tcl_Obj *cmdpfxObj,
int mode,
Tcl_Obj *handleObj)
{
ReflectedChannel *rcPtr;
int mn = 0;
rcPtr = (ReflectedChannel *)ckalloc(sizeof(ReflectedChannel));
/* rcPtr->chan: Assigned by caller. Dummy data here. */
rcPtr->chan = NULL;
rcPtr->interp = interp;
rcPtr->dead = 0;
rcPtr->readTimer = 0;
rcPtr->writeTimer = 0;
#if TCL_THREADS
rcPtr->thread = Tcl_GetCurrentThread();
#endif
rcPtr->mode = mode;
rcPtr->interest = 0; /* Initially no interest registered */
/* ASSERT: cmdpfxObj is a Tcl List */
rcPtr->cmd = TclListObjCopy(NULL, cmdpfxObj);
Tcl_IncrRefCount(rcPtr->cmd);
rcPtr->methods = Tcl_NewListObj(METH_WRITE + 1, NULL);
while (mn <= (int)METH_WRITE) {
Tcl_ListObjAppendElement(NULL, rcPtr->methods,
Tcl_NewStringObj(methodNames[mn++], -1));
}
Tcl_IncrRefCount(rcPtr->methods);
rcPtr->name = handleObj;
Tcl_IncrRefCount(rcPtr->name);
return rcPtr;
|
| ︙ | ︙ | |||
2259 2260 2261 2262 2263 2264 2265 |
}
if (rcPtr->methods) {
Tcl_DecrRefCount(rcPtr->methods);
}
if (rcPtr->cmd) {
Tcl_DecrRefCount(rcPtr->cmd);
}
| | | 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 |
}
if (rcPtr->methods) {
Tcl_DecrRefCount(rcPtr->methods);
}
if (rcPtr->cmd) {
Tcl_DecrRefCount(rcPtr->cmd);
}
ckfree(rcPtr);
}
/*
*----------------------------------------------------------------------
*
* InvokeTclMethod --
*
|
| ︙ | ︙ | |||
2380 2381 2382 2383 2384 2385 2386 |
* the full state of the result, including additional options.
*
* This is complex and ugly, and would be completely unnecessary
* if we only added support for a TCL_FORBID_EXCEPTIONS flag.
*/
if (result != TCL_ERROR) {
| | | 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 |
* the full state of the result, including additional options.
*
* This is complex and ugly, and would be completely unnecessary
* if we only added support for a TCL_FORBID_EXCEPTIONS flag.
*/
if (result != TCL_ERROR) {
int cmdLen;
const char *cmdString = TclGetStringFromObj(cmd, &cmdLen);
Tcl_IncrRefCount(cmd);
Tcl_ResetResult(rcPtr->interp);
Tcl_SetObjResult(rcPtr->interp, Tcl_ObjPrintf(
"chan handler returned bad code: %d", result));
Tcl_LogCommandInfo(rcPtr->interp, cmdString, cmdString,
|
| ︙ | ︙ | |||
2492 2493 2494 2495 2496 2497 2498 |
*----------------------------------------------------------------------
*/
static ReflectedChannelMap *
GetReflectedChannelMap(
Tcl_Interp *interp)
{
| | | | < | 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 |
*----------------------------------------------------------------------
*/
static ReflectedChannelMap *
GetReflectedChannelMap(
Tcl_Interp *interp)
{
ReflectedChannelMap *rcmPtr = (ReflectedChannelMap *)Tcl_GetAssocData(interp, RCMKEY, NULL);
if (rcmPtr == NULL) {
rcmPtr = (ReflectedChannelMap *)ckalloc(sizeof(ReflectedChannelMap));
Tcl_InitHashTable(&rcmPtr->map, TCL_STRING_KEYS);
Tcl_SetAssocData(interp, RCMKEY, DeleteReflectedChannelMap, rcmPtr);
}
return rcmPtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2550 2551 2552 2553 2554 2555 2556 |
}
static void
DeleteReflectedChannelMap(
ClientData clientData, /* The per-interpreter data structure. */
Tcl_Interp *interp) /* The interpreter being deleted. */
{
| | | 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 |
}
static void
DeleteReflectedChannelMap(
ClientData clientData, /* The per-interpreter data structure. */
Tcl_Interp *interp) /* The interpreter being deleted. */
{
ReflectedChannelMap *rcmPtr = (ReflectedChannelMap *)clientData;
/* The map */
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
ReflectedChannel *rcPtr;
Tcl_Channel chan;
#if TCL_THREADS
ForwardingResult *resultPtr;
|
| ︙ | ︙ | |||
2577 2578 2579 2580 2581 2582 2583 |
* DeleteThreadReflectedChannelMap(), just restricted to the channels of
* this interp.
*/
for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) {
| | | | | 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 |
* DeleteThreadReflectedChannelMap(), just restricted to the channels of
* this interp.
*/
for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) {
chan = (Tcl_Channel)Tcl_GetHashValue(hPtr);
rcPtr = (ReflectedChannel *)Tcl_GetChannelInstanceData(chan);
MarkDead(rcPtr);
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(&rcmPtr->map);
ckfree(&rcmPtr->map);
#if TCL_THREADS
/*
* The origin interpreter for one or more reflected channels is gone.
*/
/*
|
| ︙ | ︙ | |||
2623 2624 2625 2626 2627 2628 2629 |
* teardown. Such results are ignored. See ticket [b47b176adf] for the
* identical race condition in Tcl 8.6 IORTrans.
*/
evPtr = resultPtr->evPtr;
/*
| | | | 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 |
* teardown. Such results are ignored. See ticket [b47b176adf] for the
* identical race condition in Tcl 8.6 IORTrans.
*/
evPtr = resultPtr->evPtr;
/*
* Basic crash safety until this routine can get revised [3411310]
*/
if (evPtr == NULL) {
continue;
}
paramPtr = evPtr->param;
if (!evPtr) {
continue;
|
| ︙ | ︙ | |||
2655 2656 2657 2658 2659 2660 2661 |
* interpreter. They have already been marked as dead.
*/
rcmPtr = GetThreadReflectedChannelMap();
for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
| | | | 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 |
* interpreter. They have already been marked as dead.
*/
rcmPtr = GetThreadReflectedChannelMap();
for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
chan = (Tcl_Channel)Tcl_GetHashValue(hPtr);
rcPtr = (ReflectedChannel *)Tcl_GetChannelInstanceData(chan);
if (rcPtr->interp != interp) {
/*
* Ignore entries for other interpreters.
*/
continue;
|
| ︙ | ︙ | |||
2696 2697 2698 2699 2700 2701 2702 |
static ReflectedChannelMap *
GetThreadReflectedChannelMap(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->rcmPtr) {
| | | 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 |
static ReflectedChannelMap *
GetThreadReflectedChannelMap(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->rcmPtr) {
tsdPtr->rcmPtr = (ReflectedChannelMap *)ckalloc(sizeof(ReflectedChannelMap));
Tcl_InitHashTable(&tsdPtr->rcmPtr->map, TCL_STRING_KEYS);
Tcl_CreateThreadExitHandler(DeleteThreadReflectedChannelMap, NULL);
}
return tsdPtr->rcmPtr;
}
|
| ︙ | ︙ | |||
2724 2725 2726 2727 2728 2729 2730 | * Deletes the hash table of channels. * *---------------------------------------------------------------------- */ static void DeleteThreadReflectedChannelMap( | | | 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 |
* Deletes the hash table of channels.
*
*----------------------------------------------------------------------
*/
static void
DeleteThreadReflectedChannelMap(
TCL_UNUSED(ClientData))
{
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
Tcl_ThreadId self = Tcl_GetCurrentThread();
ReflectedChannelMap *rcmPtr; /* The map */
ForwardingResult *resultPtr;
|
| ︙ | ︙ | |||
2773 2774 2775 2776 2777 2778 2779 |
* teardown. Such results are ignored. See ticket [b47b176adf] for the
* identical race condition in Tcl 8.6 IORTrans.
*/
evPtr = resultPtr->evPtr;
/*
| | | | 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 |
* teardown. Such results are ignored. See ticket [b47b176adf] for the
* identical race condition in Tcl 8.6 IORTrans.
*/
evPtr = resultPtr->evPtr;
/*
* Basic crash safety until this routine can get revised [3411310]
*/
if (evPtr == NULL ) {
continue;
}
paramPtr = evPtr->param;
if (!evPtr) {
continue;
|
| ︙ | ︙ | |||
2813 2814 2815 2816 2817 2818 2819 |
* through the channels, remove all, mark them as dead.
*/
rcmPtr = GetThreadReflectedChannelMap();
for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) {
| | | | | 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 |
* through the channels, remove all, mark them as dead.
*/
rcmPtr = GetThreadReflectedChannelMap();
for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) {
Tcl_Channel chan = (Tcl_Channel)Tcl_GetHashValue(hPtr);
ReflectedChannel *rcPtr = (ReflectedChannel *)Tcl_GetChannelInstanceData(chan);
MarkDead(rcPtr);
Tcl_DeleteHashEntry(hPtr);
}
ckfree(rcmPtr);
}
static void
ForwardOpToHandlerThread(
ReflectedChannel *rcPtr, /* Channel instance */
ForwardedOperation op, /* Forwarded driver operation */
const void *param) /* Arguments */
|
| ︙ | ︙ | |||
2859 2860 2861 2862 2863 2864 2865 |
return;
}
/*
* Create and initialize the event and data structures.
*/
| | | | 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 |
return;
}
/*
* Create and initialize the event and data structures.
*/
evPtr = (ForwardingEvent *)ckalloc(sizeof(ForwardingEvent));
resultPtr = (ForwardingResult *)ckalloc(sizeof(ForwardingResult));
evPtr->event.proc = ForwardProc;
evPtr->resultPtr = resultPtr;
evPtr->op = op;
evPtr->rcPtr = rcPtr;
evPtr->param = (ForwardParam *) param;
|
| ︙ | ︙ | |||
2942 2943 2944 2945 2946 2947 2948 |
* returning the success code.
*
* Note: The event structure has already been deleted.
*/
Tcl_DeleteThreadExitHandler(SrcExitProc, evPtr);
| | | | 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 |
* returning the success code.
*
* Note: The event structure has already been deleted.
*/
Tcl_DeleteThreadExitHandler(SrcExitProc, evPtr);
ckfree(resultPtr);
}
static int
ForwardProc(
Tcl_Event *evGPtr,
TCL_UNUSED(int) /* mask */)
{
/*
* HANDLER thread.
* The receiver part for the operations coming from the OWNER thread.
* See ForwardOpToHandlerThread() for the transmitter.
*
|
| ︙ | ︙ | |||
3042 3043 3044 3045 3046 3047 3048 |
int code = ErrnoReturn(rcPtr, resObj);
if (code < 0) {
paramPtr->base.code = code;
} else {
ForwardSetObjError(paramPtr, resObj);
}
| | | | | | | 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 |
int code = ErrnoReturn(rcPtr, resObj);
if (code < 0) {
paramPtr->base.code = code;
} else {
ForwardSetObjError(paramPtr, resObj);
}
paramPtr->input.toRead = -1;
} else {
/*
* Process a regular result.
*/
int bytec; /* Number of returned bytes */
unsigned char *bytev; /* Array of returned bytes */
bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
if (paramPtr->input.toRead < bytec) {
ForwardSetStaticError(paramPtr, msg_read_toomuch);
paramPtr->input.toRead = -1;
} else {
if (bytec > 0) {
memcpy(paramPtr->input.buf, bytev, bytec);
}
paramPtr->input.toRead = bytec;
}
}
Tcl_Release(rcPtr);
Tcl_DecrRefCount(toReadObj);
|
| ︙ | ︙ | |||
3237 3238 3239 3240 3241 3242 3243 |
resObj = MarshallError(interp);
ForwardSetObjError(paramPtr, resObj);
} else if ((listc % 2) == 1) {
/*
* Odd number of elements is wrong. [x].
*/
| | | | 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 |
resObj = MarshallError(interp);
ForwardSetObjError(paramPtr, resObj);
} else if ((listc % 2) == 1) {
/*
* Odd number of elements is wrong. [x].
*/
char *buf = (char *)ckalloc(200);
sprintf(buf,
"{Expected list with even number of elements, got %d %s instead}",
listc, (listc == 1 ? "element" : "elements"));
ForwardSetDynamicError(paramPtr, buf);
} else {
int len;
const char *str = TclGetStringFromObj(resObj, &len);
if (len) {
TclDStringAppendLiteral(paramPtr->getOpt.value, " ");
Tcl_DStringAppend(paramPtr->getOpt.value, str, len);
}
}
|
| ︙ | ︙ | |||
3294 3295 3296 3297 3298 3299 3300 |
return 1;
}
static void
SrcExitProc(
ClientData clientData)
{
| | | 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 |
return 1;
}
static void
SrcExitProc(
ClientData clientData)
{
ForwardingEvent *evPtr = (ForwardingEvent *)clientData;
ForwardingResult *resultPtr;
ForwardParam *paramPtr;
/*
* NOTE (2): Can this handler be called with the originator blocked?
*/
|
| ︙ | ︙ | |||
3343 3344 3345 3346 3347 3348 3349 |
}
static void
ForwardSetObjError(
ForwardParam *paramPtr,
Tcl_Obj *obj)
{
| | | | 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 |
}
static void
ForwardSetObjError(
ForwardParam *paramPtr,
Tcl_Obj *obj)
{
int len;
const char *msgStr = TclGetStringFromObj(obj, &len);
len++;
ForwardSetDynamicError(paramPtr, ckalloc(len));
memcpy(paramPtr->base.msgStr, msgStr, len);
}
#endif
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
* indent-tabs-mode: nil
* End:
*/
|
Changes to generic/tclIORTrans.c.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 | #ifndef EINVAL #define EINVAL 9 #endif #ifndef EOK #define EOK 0 #endif | < < < < | > > | > > > > | | | | 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 |
#ifndef EINVAL
#define EINVAL 9
#endif
#ifndef EOK
#define EOK 0
#endif
/*
* Signatures of all functions used in the C layer of the reflection.
*/
static int ReflectClose(ClientData clientData,
Tcl_Interp *interp, int flags);
static int ReflectInput(ClientData clientData, char *buf,
int toRead, int *errorCodePtr);
static int ReflectOutput(ClientData clientData, const char *buf,
int toWrite, int *errorCodePtr);
static void ReflectWatch(ClientData clientData, int mask);
static int ReflectBlock(ClientData clientData, int mode);
static Tcl_WideInt ReflectSeekWide(ClientData clientData,
Tcl_WideInt offset, int mode, int *errorCodePtr);
#ifndef TCL_NO_DEPRECATED
static int ReflectSeek(ClientData clientData, long offset,
int mode, int *errorCodePtr);
#endif
static int ReflectGetOption(ClientData clientData,
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
static int ReflectSetOption(ClientData clientData,
Tcl_Interp *interp, const char *optionName,
const char *newValue);
static int ReflectHandle(ClientData clientData, int direction,
ClientData *handle);
static int ReflectNotify(ClientData clientData, int mask);
/*
* The C layer channel type/driver definition used by the reflection.
*/
static const Tcl_ChannelType tclRTransformType = {
"tclrtransform", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel. */
TCL_CLOSE2PROC, /* Close channel, clean instance data. */
ReflectInput, /* Handle read request. */
ReflectOutput, /* Handle write request. */
#ifndef TCL_NO_DEPRECATED
ReflectSeek, /* Move location of access point. */
#else
NULL, /* Move location of access point. */
#endif
ReflectSetOption, /* Set options. */
ReflectGetOption, /* Get options. */
ReflectWatch, /* Initialize notifier. */
ReflectHandle, /* Get OS handle from the channel. */
ReflectClose, /* No close2 support. NULL'able. */
ReflectBlock, /* Set blocking/nonblocking. */
NULL, /* Flush channel. Not used by core.
* NULL'able. */
ReflectNotify, /* Handle events. */
ReflectSeekWide, /* Move access point (64 bit). */
NULL, /* thread action */
NULL /* truncate */
};
/*
* Structure of the buffer to hold transform results to be consumed by higher
* layers upon reading from the channel, plus the functions to manage such.
*/
typedef struct {
unsigned char *buf; /* Reference to the buffer area. */
int allocated; /* Allocated size of the buffer area. */
int used; /* Number of bytes in the buffer,
* <= allocated. */
} ResultBuffer;
#define ResultLength(r) ((r)->used)
/* static int ResultLength(ResultBuffer *r); */
static void ResultClear(ResultBuffer *r);
|
| ︙ | ︙ | |||
266 267 268 269 270 271 272 |
* has no "subtype" and just uses ForwardParamBase, as listed above.)
*/
struct ForwardParamTransform {
ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
char *buf; /* I: Bytes to transform,
* O: Bytes in transform result */
| | | 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 |
* has no "subtype" and just uses ForwardParamBase, as listed above.)
*/
struct ForwardParamTransform {
ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
char *buf; /* I: Bytes to transform,
* O: Bytes in transform result */
int size; /* I: #bytes to transform,
* O: #bytes in the transform result */
};
struct ForwardParamLimit {
ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
int max; /* O: Character read limit */
};
|
| ︙ | ︙ | |||
362 363 364 365 366 367 368 |
ForwardedOperation op, const void *param);
static int ForwardProc(Tcl_Event *evPtr, int mask);
static void SrcExitProc(ClientData clientData);
#define FreeReceivedError(p) \
do { \
if ((p)->base.mustFree) { \
| | | 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 |
ForwardedOperation op, const void *param);
static int ForwardProc(Tcl_Event *evPtr, int mask);
static void SrcExitProc(ClientData clientData);
#define FreeReceivedError(p) \
do { \
if ((p)->base.mustFree) { \
ckfree((p)->base.msgStr); \
} \
} while (0)
#define PassReceivedErrorInterp(i,p) \
do { \
if ((i) != NULL) { \
Tcl_SetChannelErrorInterp((i), \
Tcl_NewStringObj((p)->base.msgStr, -1)); \
|
| ︙ | ︙ | |||
497 498 499 500 501 502 503 | * Creates a new channel. * *---------------------------------------------------------------------- */ int TclChanPushObjCmd( | | | 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 |
* Creates a new channel.
*
*----------------------------------------------------------------------
*/
int
TclChanPushObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
ReflectedTransform *rtPtr; /* Instance data of the new (transform)
* channel. */
Tcl_Obj *chanObj; /* Handle of parent channel */
|
| ︙ | ︙ | |||
616 617 618 619 620 621 622 |
methods = 0;
while (listc > 0) {
if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames,
"method", TCL_EXACT, &methIndex) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned %s",
TclGetString(cmdObj),
| | | 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 |
methods = 0;
while (listc > 0) {
if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames,
"method", TCL_EXACT, &methIndex) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned %s",
TclGetString(cmdObj),
Tcl_GetString(Tcl_GetObjResult(interp))));
Tcl_DecrRefCount(resObj);
goto error;
}
methods |= FLAG(methIndex);
listc--;
}
|
| ︙ | ︙ | |||
742 743 744 745 746 747 748 | * latter implies that arbitrary side effects are possible. * *---------------------------------------------------------------------- */ int TclChanPopObjCmd( | | | 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 |
* latter implies that arbitrary side effects are possible.
*
*----------------------------------------------------------------------
*/
int
TclChanPopObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
/*
* Syntax: chan pop CHANNEL
* [0] [1] [2]
|
| ︙ | ︙ | |||
879 880 881 882 883 884 885 |
*
*----------------------------------------------------------------------
*/
static int
ReflectClose(
ClientData clientData,
| | > | > > > > | 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 |
*
*----------------------------------------------------------------------
*/
static int
ReflectClose(
ClientData clientData,
Tcl_Interp *interp,
int flags)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
int errorCode, errorCodeSet = 0;
int result = TCL_OK; /* Result code for 'close' */
Tcl_Obj *resObj; /* Result data for 'close' */
ReflectedTransformMap *rtmPtr;
/* Map of reflected transforms with handlers
* in this interp. */
Tcl_HashEntry *hPtr; /* Entry in the above map */
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
if (TclInThreadExit()) {
/*
* This call comes from TclFinalizeIOSystem. There are no
* interpreters, and therefore we cannot call upon the handler command
* anymore. Threading is irrelevant as well. We simply clean up all
* our C level data structures and leave the Tcl level to the other
|
| ︙ | ︙ | |||
1010 1011 1012 1013 1014 1015 1016 |
*
* NOTE: The channel may have been removed from the map already via
* the per-interp DeleteReflectedTransformMap exit-handler.
*/
if (!rtPtr->dead) {
rtmPtr = GetReflectedTransformMap(rtPtr->interp);
| | | 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 |
*
* NOTE: The channel may have been removed from the map already via
* the per-interp DeleteReflectedTransformMap exit-handler.
*/
if (!rtPtr->dead) {
rtmPtr = GetReflectedTransformMap(rtPtr->interp);
hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
if (hPtr) {
Tcl_DeleteHashEntry(hPtr);
}
/*
* In a threaded interpreter we manage a per-thread map as well,
* to allow us to survive if the script level pulls the rug out
|
| ︙ | ︙ | |||
1057 1058 1059 1060 1061 1062 1063 |
static int
ReflectInput(
ClientData clientData,
char *buf,
int toRead,
int *errorCodePtr)
{
| | | 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 |
static int
ReflectInput(
ClientData clientData,
char *buf,
int toRead,
int *errorCodePtr)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
int gotBytes, copied, readBytes;
Tcl_Obj *bufObj;
/*
* The following check can be done before thread redirection, because we
* are reading from an item which is readonly, i.e. will never change
* during the lifetime of the channel.
|
| ︙ | ︙ | |||
1250 1251 1252 1253 1254 1255 1256 |
static int
ReflectOutput(
ClientData clientData,
const char *buf,
int toWrite,
int *errorCodePtr)
{
| | | 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 |
static int
ReflectOutput(
ClientData clientData,
const char *buf,
int toWrite,
int *errorCodePtr)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
/*
* The following check can be done before thread redirection, because we
* are reading from an item which is readonly, i.e. will never change
* during the lifetime of the channel.
*/
|
| ︙ | ︙ | |||
1323 1324 1325 1326 1327 1328 1329 |
static Tcl_WideInt
ReflectSeekWide(
ClientData clientData,
Tcl_WideInt offset,
int seekMode,
int *errorCodePtr)
{
| | < < < < < < < < < < < < | 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 |
static Tcl_WideInt
ReflectSeekWide(
ClientData clientData,
Tcl_WideInt offset,
int seekMode,
int *errorCodePtr)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
Channel *parent = (Channel *) rtPtr->parent;
Tcl_WideInt curPos; /* Position on the device. */
/*
* Check if we can leave out involving the Tcl level, i.e. transformation
* handler. This is true for tell requests, and transformations which
* support neither flush, nor drain. For these cases we can pass the
* request down and the result back up unchanged.
*/
|
| ︙ | ︙ | |||
1382 1383 1384 1385 1386 1387 1388 |
/*
* Now seek to the new position in the channel as requested by the
* caller. Note that we prefer the wideSeekProc if that is available and
* non-NULL...
*/
| | | < < | | | | | | | > > > > > > > > > > | 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 |
/*
* Now seek to the new position in the channel as requested by the
* caller. Note that we prefer the wideSeekProc if that is available and
* non-NULL...
*/
if (Tcl_ChannelWideSeekProc(parent->typePtr) == NULL) {
#ifndef TCL_NO_DEPRECATED
if (offset < LONG_MIN || offset > LONG_MAX) {
*errorCodePtr = EOVERFLOW;
curPos = -1;
} else {
curPos = Tcl_ChannelSeekProc(parent->typePtr)(
parent->instanceData, offset, seekMode,
errorCodePtr);
}
#else
*errorCodePtr = EINVAL;
curPos = -1;
#endif
} else {
curPos = Tcl_ChannelWideSeekProc(parent->typePtr)(parent->instanceData, offset,
seekMode, errorCodePtr);
}
if (curPos == -1) {
Tcl_SetErrno(*errorCodePtr);
}
*errorCodePtr = EOK;
Tcl_Release(rtPtr);
return curPos;
}
#ifndef TCL_NO_DEPRECATED
static int
ReflectSeek(
ClientData clientData,
long offset,
int seekMode,
int *errorCodePtr)
{
/*
* This function can be invoked from a transformation which is based on
* standard seeking, i.e. non-wide. Because of this we have to implement
* it, a dummy is not enough. We simply delegate the call to the wide
* routine.
*/
return ReflectSeekWide(clientData, offset, seekMode,
errorCodePtr);
}
#endif
/*
*----------------------------------------------------------------------
*
* ReflectWatch --
*
* This function is invoked to tell the channel what events the I/O
|
| ︙ | ︙ | |||
1443 1444 1445 1446 1447 1448 1449 |
*/
static void
ReflectWatch(
ClientData clientData,
int mask)
{
| | | 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 |
*/
static void
ReflectWatch(
ClientData clientData,
int mask)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
Tcl_DriverWatchProc *watchProc;
watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(rtPtr->parent));
watchProc(Tcl_GetChannelInstanceData(rtPtr->parent), mask);
/*
* Management of the internal timer.
|
| ︙ | ︙ | |||
1494 1495 1496 1497 1498 1499 1500 |
*/
static int
ReflectBlock(
ClientData clientData,
int nonblocking)
{
| | | 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 |
*/
static int
ReflectBlock(
ClientData clientData,
int nonblocking)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
/*
* Transformations simply record the blocking mode in their C level
* structure for use by --> ReflectInput. The Tcl level doesn't see this
* information or change. As such thread forwarding is not required.
*/
|
| ︙ | ︙ | |||
1529 1530 1531 1532 1533 1534 1535 |
static int
ReflectSetOption(
ClientData clientData, /* Channel to query */
Tcl_Interp *interp, /* Interpreter to leave error messages in */
const char *optionName, /* Name of requested option */
const char *newValue) /* The new value */
{
| | | 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 |
static int
ReflectSetOption(
ClientData clientData, /* Channel to query */
Tcl_Interp *interp, /* Interpreter to leave error messages in */
const char *optionName, /* Name of requested option */
const char *newValue) /* The new value */
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
/*
* Transformations have no options. Thus the call is passed down unchanged
* to the parent channel for processing. Its results are passed back
* unchanged as well. This all happens in the thread we are in. As the Tcl
* level is not involved there is no need for thread forwarding.
*/
|
| ︙ | ︙ | |||
1571 1572 1573 1574 1575 1576 1577 |
static int
ReflectGetOption(
ClientData clientData, /* Channel to query */
Tcl_Interp *interp, /* Interpreter to leave error messages in */
const char *optionName, /* Name of reuqested option */
Tcl_DString *dsPtr) /* String to place the result into */
{
| | | 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 |
static int
ReflectGetOption(
ClientData clientData, /* Channel to query */
Tcl_Interp *interp, /* Interpreter to leave error messages in */
const char *optionName, /* Name of reuqested option */
Tcl_DString *dsPtr) /* String to place the result into */
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
/*
* Transformations have no options. Thus the call is passed down unchanged
* to the parent channel for processing. Its results are passed back
* unchanged as well. This all happens in the thread we are in. As the Tcl
* level is not involved there is no need for thread forwarding.
*
|
| ︙ | ︙ | |||
1619 1620 1621 1622 1623 1624 1625 |
static int
ReflectHandle(
ClientData clientData,
int direction,
ClientData *handlePtr)
{
| | | 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 |
static int
ReflectHandle(
ClientData clientData,
int direction,
ClientData *handlePtr)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
/*
* Transformations have no handle of their own. As such we simply query
* the parent channel for it. This way the qery will ripple down through
* all transformations until reaches the base channel. Which then returns
* its handle, or fails. The former will then ripple up the stack.
*
|
| ︙ | ︙ | |||
1654 1655 1656 1657 1658 1659 1660 |
*/
static int
ReflectNotify(
ClientData clientData,
int mask)
{
| | | 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 |
*/
static int
ReflectNotify(
ClientData clientData,
int mask)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
/*
* An event occured in the underlying channel.
*
* We delete our timer. It was not fired, yet we are here, so the channel
* below generated such an event and we don't have to. The renewal of the
* interest after the execution of channel handlers will eventually cause
|
| ︙ | ︙ | |||
1702 1703 1704 1705 1706 1707 1708 |
* DUPLICATE of 'DecodeEventMask' in tclIORChan.c
*/
static Tcl_Obj *
DecodeEventMask(
int mask)
{
| | | 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 |
* DUPLICATE of 'DecodeEventMask' in tclIORChan.c
*/
static Tcl_Obj *
DecodeEventMask(
int mask)
{
const char *eventStr;
Tcl_Obj *evObj;
switch (mask & RANDW) {
case RANDW:
eventStr = "read write";
break;
case TCL_READABLE:
|
| ︙ | ︙ | |||
1746 1747 1748 1749 1750 1751 1752 |
*----------------------------------------------------------------------
*/
static ReflectedTransform *
NewReflectedTransform(
Tcl_Interp *interp,
Tcl_Obj *cmdpfxObj,
| | | | 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 |
*----------------------------------------------------------------------
*/
static ReflectedTransform *
NewReflectedTransform(
Tcl_Interp *interp,
Tcl_Obj *cmdpfxObj,
TCL_UNUSED(int) /*mode*/,
Tcl_Obj *handleObj,
Tcl_Channel parentChan)
{
ReflectedTransform *rtPtr;
int listc;
Tcl_Obj **listv;
int i;
rtPtr = (ReflectedTransform *)ckalloc(sizeof(ReflectedTransform));
/* rtPtr->chan: Assigned by caller. Dummy data here. */
/* rtPtr->methods: Assigned by caller. Dummy data here. */
rtPtr->chan = NULL;
rtPtr->methods = 0;
#if TCL_THREADS
|
| ︙ | ︙ | |||
1802 1803 1804 1805 1806 1807 1808 |
*
* listv [0] [listc-1] | [listc] [listc+1] |
* argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2]
* cmd ... pfx | method chan | detail1 detail2
*/
rtPtr->argc = listc + 2;
| | | 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 |
*
* listv [0] [listc-1] | [listc] [listc+1] |
* argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2]
* cmd ... pfx | method chan | detail1 detail2
*/
rtPtr->argc = listc + 2;
rtPtr->argv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (listc+4));
/*
* Duplicate object references.
*/
for (i=0; i<listc ; i++) {
Tcl_Obj *word = rtPtr->argv[i] = listv[i];
|
| ︙ | ︙ | |||
1910 1911 1912 1913 1914 1915 1916 |
ReflectedTransform *rtPtr)
{
TimerKill(rtPtr);
ResultClear(&rtPtr->result);
FreeReflectedTransformArgs(rtPtr);
| | | | 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 |
ReflectedTransform *rtPtr)
{
TimerKill(rtPtr);
ResultClear(&rtPtr->result);
FreeReflectedTransformArgs(rtPtr);
ckfree(rtPtr->argv);
ckfree(rtPtr);
}
/*
*----------------------------------------------------------------------
*
* InvokeTclMethod --
*
|
| ︙ | ︙ | |||
2037 2038 2039 2040 2041 2042 2043 |
* the full state of the result, including additional options.
*
* This is complex and ugly, and would be completely unnecessary
* if we only added support for a TCL_FORBID_EXCEPTIONS flag.
*/
if (result != TCL_ERROR) {
Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv);
| | | 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 |
* the full state of the result, including additional options.
*
* This is complex and ugly, and would be completely unnecessary
* if we only added support for a TCL_FORBID_EXCEPTIONS flag.
*/
if (result != TCL_ERROR) {
Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv);
int cmdLen;
const char *cmdString = TclGetStringFromObj(cmd, &cmdLen);
Tcl_IncrRefCount(cmd);
Tcl_ResetResult(rtPtr->interp);
Tcl_SetObjResult(rtPtr->interp, Tcl_ObjPrintf(
"chan handler returned bad code: %d", result));
Tcl_LogCommandInfo(rtPtr->interp, cmdString, cmdString, cmdLen);
|
| ︙ | ︙ | |||
2107 2108 2109 2110 2111 2112 2113 |
*----------------------------------------------------------------------
*/
static ReflectedTransformMap *
GetReflectedTransformMap(
Tcl_Interp *interp)
{
| | | | 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 |
*----------------------------------------------------------------------
*/
static ReflectedTransformMap *
GetReflectedTransformMap(
Tcl_Interp *interp)
{
ReflectedTransformMap *rtmPtr = (ReflectedTransformMap *)Tcl_GetAssocData(interp, RTMKEY, NULL);
if (rtmPtr == NULL) {
rtmPtr = (ReflectedTransformMap *)ckalloc(sizeof(ReflectedTransformMap));
Tcl_InitHashTable(&rtmPtr->map, TCL_STRING_KEYS);
Tcl_SetAssocData(interp, RTMKEY,
(Tcl_InterpDeleteProc *) DeleteReflectedTransformMap, rtmPtr);
}
return rtmPtr;
}
|
| ︙ | ︙ | |||
2165 2166 2167 2168 2169 2170 2171 |
* systems point of view and will not get closed. Therefore mark all as
* dead so that any future access will cause a proper error. For channels
* in a different thread we actually do the same as
* DeleteThreadReflectedTransformMap(), just restricted to the channels of
* this interp.
*/
| | | | | | 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 |
* systems point of view and will not get closed. Therefore mark all as
* dead so that any future access will cause a proper error. For channels
* in a different thread we actually do the same as
* DeleteThreadReflectedTransformMap(), just restricted to the channels of
* this interp.
*/
rtmPtr = (ReflectedTransformMap *)clientData;
for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
rtPtr = (ReflectedTransform *)Tcl_GetHashValue(hPtr);
rtPtr->dead = 1;
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(&rtmPtr->map);
ckfree(&rtmPtr->map);
#if TCL_THREADS
/*
* The origin interpreter for one or more reflected channels is gone.
*/
/*
* Get the map of all channels handled by the current thread. This is a
* ReflectedTransformMap, but on a per-thread basis, not per-interp. Go
* through the channels and remove all which were handled by this
* interpreter. They have already been marked as dead.
*/
rtmPtr = GetThreadReflectedTransformMap();
for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
rtPtr = (ReflectedTransform *)Tcl_GetHashValue(hPtr);
if (rtPtr->interp != interp) {
/*
* Ignore entries for other interpreters.
*/
continue;
|
| ︙ | ︙ | |||
2273 2274 2275 2276 2277 2278 2279 |
static ReflectedTransformMap *
GetThreadReflectedTransformMap(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->rtmPtr) {
| | | 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 |
static ReflectedTransformMap *
GetThreadReflectedTransformMap(void)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->rtmPtr) {
tsdPtr->rtmPtr = (ReflectedTransformMap *)ckalloc(sizeof(ReflectedTransformMap));
Tcl_InitHashTable(&tsdPtr->rtmPtr->map, TCL_STRING_KEYS);
Tcl_CreateThreadExitHandler(DeleteThreadReflectedTransformMap, NULL);
}
return tsdPtr->rtmPtr;
}
|
| ︙ | ︙ | |||
2301 2302 2303 2304 2305 2306 2307 | * Deletes the hash table of channels. * *---------------------------------------------------------------------- */ static void DeleteThreadReflectedTransformMap( | | | 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 |
* Deletes the hash table of channels.
*
*----------------------------------------------------------------------
*/
static void
DeleteThreadReflectedTransformMap(
TCL_UNUSED(ClientData))
{
Tcl_HashSearch hSearch; /* Search variable. */
Tcl_HashEntry *hPtr; /* Search variable. */
Tcl_ThreadId self = Tcl_GetCurrentThread();
ReflectedTransformMap *rtmPtr; /* The map */
ForwardingResult *resultPtr;
|
| ︙ | ︙ | |||
2325 2326 2327 2328 2329 2330 2331 |
* through the channels, remove all, mark them as dead.
*/
rtmPtr = GetThreadReflectedTransformMap();
for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
| | | | 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 |
* through the channels, remove all, mark them as dead.
*/
rtmPtr = GetThreadReflectedTransformMap();
for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
ReflectedTransform *rtPtr = (ReflectedTransform *)Tcl_GetHashValue(hPtr);
rtPtr->dead = 1;
FreeReflectedTransformArgs(rtPtr);
Tcl_DeleteHashEntry(hPtr);
}
ckfree(rtmPtr);
/*
* Go through the list of pending results and cancel all whose events were
* destined for this thread. While this is in progress we block any
* other access to the list of pending results.
*/
|
| ︙ | ︙ | |||
2408 2409 2410 2411 2412 2413 2414 |
return;
}
/*
* Create and initialize the event and data structures.
*/
| | | | 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 |
return;
}
/*
* Create and initialize the event and data structures.
*/
evPtr = (ForwardingEvent *)ckalloc(sizeof(ForwardingEvent));
resultPtr = (ForwardingResult *)ckalloc(sizeof(ForwardingResult));
evPtr->event.proc = ForwardProc;
evPtr->resultPtr = resultPtr;
evPtr->op = op;
evPtr->rtPtr = rtPtr;
evPtr->param = (ForwardParam *) param;
|
| ︙ | ︙ | |||
2489 2490 2491 2492 2493 2494 2495 |
*
* Note: The event structure has already been deleted by the destination
* notifier, after it serviced the event.
*/
Tcl_DeleteThreadExitHandler(SrcExitProc, evPtr);
| | | | 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 |
*
* Note: The event structure has already been deleted by the destination
* notifier, after it serviced the event.
*/
Tcl_DeleteThreadExitHandler(SrcExitProc, evPtr);
ckfree(resultPtr);
}
static int
ForwardProc(
Tcl_Event *evGPtr,
TCL_UNUSED(int) /*mask*/)
{
/*
* Notes regarding access to the referenced data.
*
* In principle the data belongs to the originating thread (see
* evPtr->src), however this thread is currently blocked at (*), i.e.
* quiescent. Because of this we can treat the data as belonging to us,
|
| ︙ | ︙ | |||
2586 2587 2588 2589 2590 2591 2592 |
case ForwardedInput: {
Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *)
paramPtr->transform.buf, paramPtr->transform.size);
Tcl_IncrRefCount(bufObj);
if (InvokeTclMethod(rtPtr, "read", bufObj, NULL, &resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
| | | | | | | | | | | | | | | | | | 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 |
case ForwardedInput: {
Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *)
paramPtr->transform.buf, paramPtr->transform.size);
Tcl_IncrRefCount(bufObj);
if (InvokeTclMethod(rtPtr, "read", bufObj, NULL, &resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
paramPtr->transform.size = -1;
} else {
/*
* Process a regular return. Contains the transformation result.
* Sent it back to the request originator.
*/
int bytec; /* Number of returned bytes */
unsigned char *bytev;
/* Array of returned bytes */
bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
paramPtr->transform.size = bytec;
if (bytec > 0) {
paramPtr->transform.buf = (char *)ckalloc(bytec);
memcpy(paramPtr->transform.buf, bytev, bytec);
} else {
paramPtr->transform.buf = NULL;
}
}
Tcl_DecrRefCount(bufObj);
break;
}
case ForwardedOutput: {
Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *)
paramPtr->transform.buf, paramPtr->transform.size);
Tcl_IncrRefCount(bufObj);
if (InvokeTclMethod(rtPtr, "write", bufObj, NULL, &resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
paramPtr->transform.size = -1;
} else {
/*
* Process a regular return. Contains the transformation result.
* Sent it back to the request originator.
*/
int bytec; /* Number of returned bytes */
unsigned char *bytev;
/* Array of returned bytes */
bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
paramPtr->transform.size = bytec;
if (bytec > 0) {
paramPtr->transform.buf = (char *)ckalloc(bytec);
memcpy(paramPtr->transform.buf, bytev, bytec);
} else {
paramPtr->transform.buf = NULL;
}
}
Tcl_DecrRefCount(bufObj);
break;
}
case ForwardedDrain:
if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
paramPtr->transform.size = -1;
} else {
/*
* Process a regular return. Contains the transformation result.
* Sent it back to the request originator.
*/
int bytec; /* Number of returned bytes */
unsigned char *bytev; /* Array of returned bytes */
bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
paramPtr->transform.size = bytec;
if (bytec > 0) {
paramPtr->transform.buf = (char *)ckalloc(bytec);
memcpy(paramPtr->transform.buf, bytev, bytec);
} else {
paramPtr->transform.buf = NULL;
}
}
break;
case ForwardedFlush:
if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj) != TCL_OK) {
ForwardSetObjError(paramPtr, resObj);
paramPtr->transform.size = -1;
} else {
/*
* Process a regular return. Contains the transformation result.
* Sent it back to the request originator.
*/
int bytec; /* Number of returned bytes */
unsigned char *bytev;
/* Array of returned bytes */
bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
paramPtr->transform.size = bytec;
if (bytec > 0) {
paramPtr->transform.buf = (char *)ckalloc(bytec);
memcpy(paramPtr->transform.buf, bytev, bytec);
} else {
paramPtr->transform.buf = NULL;
}
}
break;
|
| ︙ | ︙ | |||
2752 2753 2754 2755 2756 2757 2758 |
return 1;
}
static void
SrcExitProc(
ClientData clientData)
{
| | | 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 |
return 1;
}
static void
SrcExitProc(
ClientData clientData)
{
ForwardingEvent *evPtr = (ForwardingEvent *)clientData;
ForwardingResult *resultPtr;
ForwardParam *paramPtr;
/*
* NOTE (2): Can this handler be called with the originator blocked?
*/
|
| ︙ | ︙ | |||
2801 2802 2803 2804 2805 2806 2807 |
}
static void
ForwardSetObjError(
ForwardParam *paramPtr,
Tcl_Obj *obj)
{
| | | | 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 |
}
static void
ForwardSetObjError(
ForwardParam *paramPtr,
Tcl_Obj *obj)
{
int len;
const char *msgStr = TclGetStringFromObj(obj, &len);
len++;
ForwardSetDynamicError(paramPtr, ckalloc(len));
memcpy(paramPtr->base.msgStr, msgStr, len);
}
#endif /* TCL_THREADS */
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2892 2893 2894 2895 2896 2897 2898 |
*----------------------------------------------------------------------
*/
static void
TimerRun(
ClientData clientData)
{
| | | 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 |
*----------------------------------------------------------------------
*/
static void
TimerRun(
ClientData clientData)
{
ReflectedTransform *rtPtr = (ReflectedTransform *)clientData;
rtPtr->timer = NULL;
Tcl_NotifyChannel(rtPtr->chan, TCL_READABLE);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2950 2951 2952 2953 2954 2955 2956 |
{
rPtr->used = 0;
if (!rPtr->allocated) {
return;
}
| | | 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 |
{
rPtr->used = 0;
if (!rPtr->allocated) {
return;
}
ckfree(rPtr->buf);
rPtr->buf = NULL;
rPtr->allocated = 0;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2985 2986 2987 2988 2989 2990 2991 |
/*
* Extension of the internal buffer is required.
* NOTE: Currently linear. Should be doubling to amortize.
*/
if (rPtr->allocated == 0) {
rPtr->allocated = toWrite + RB_INCREMENT;
| | | | 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 |
/*
* Extension of the internal buffer is required.
* NOTE: Currently linear. Should be doubling to amortize.
*/
if (rPtr->allocated == 0) {
rPtr->allocated = toWrite + RB_INCREMENT;
rPtr->buf = UCHARP(ckalloc(rPtr->allocated));
} else {
rPtr->allocated += toWrite + RB_INCREMENT;
rPtr->buf = UCHARP(ckrealloc((char *) rPtr->buf,
rPtr->allocated));
}
}
/*
* Now copy data.
*/
|
| ︙ | ︙ | |||
3033 3034 3035 3036 3037 3038 3039 |
if (rPtr->used == 0) {
/*
* Nothing to copy in the case of an empty buffer.
*/
copied = 0;
| | | | 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 |
if (rPtr->used == 0) {
/*
* Nothing to copy in the case of an empty buffer.
*/
copied = 0;
} else if (rPtr->used == toRead) {
/*
* We have just enough. Copy everything to the caller.
*/
memcpy(buf, rPtr->buf, toRead);
rPtr->used = 0;
copied = toRead;
} else if (rPtr->used > toRead) {
/*
* The internal buffer contains more than requested. Copy the
* requested subset to the caller, and shift the remaining bytes down.
*/
memcpy(buf, rPtr->buf, toRead);
memmove(rPtr->buf, rPtr->buf + toRead, rPtr->used - toRead);
|
| ︙ | ︙ | |||
3076 3077 3078 3079 3080 3081 3082 |
static int
TransformRead(
ReflectedTransform *rtPtr,
int *errorCodePtr,
Tcl_Obj *bufObj)
{
Tcl_Obj *resObj;
| | | | | | | 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 |
static int
TransformRead(
ReflectedTransform *rtPtr,
int *errorCodePtr,
Tcl_Obj *bufObj)
{
Tcl_Obj *resObj;
int bytec; /* Number of returned bytes */
unsigned char *bytev; /* Array of returned bytes */
/*
* Are we in the correct thread?
*/
#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
p.transform.buf = (char *) Tcl_GetByteArrayFromObj(bufObj,
&(p.transform.size));
ForwardOpToOwnerThread(rtPtr, ForwardedInput, &p);
if (p.base.code != TCL_OK) {
PassReceivedError(rtPtr->chan, &p);
*errorCodePtr = EINVAL;
return 0;
}
*errorCodePtr = EOK;
ResultAdd(&rtPtr->result, UCHARP(p.transform.buf), p.transform.size);
ckfree(p.transform.buf);
return 1;
}
#endif /* TCL_THREADS */
/* ASSERT: rtPtr->method & FLAG(METH_READ) */
/* ASSERT: rtPtr->mode & TCL_READABLE */
if (InvokeTclMethod(rtPtr, "read", bufObj, NULL, &resObj) != TCL_OK) {
Tcl_SetChannelError(rtPtr->chan, resObj);
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
*errorCodePtr = EINVAL;
return 0;
}
bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
ResultAdd(&rtPtr->result, bytev, bytec);
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
return 1;
}
static int
TransformWrite(
ReflectedTransform *rtPtr,
int *errorCodePtr,
unsigned char *buf,
int toWrite)
{
Tcl_Obj *bufObj;
Tcl_Obj *resObj;
int bytec; /* Number of returned bytes */
unsigned char *bytev; /* Array of returned bytes */
int res;
/*
* Are we in the correct thread?
*/
|
| ︙ | ︙ | |||
3157 3158 3159 3160 3161 3162 3163 | *errorCodePtr = EINVAL; return 0; } *errorCodePtr = EOK; res = Tcl_WriteRaw(rtPtr->parent, (char *) p.transform.buf, p.transform.size); | | | | | | | | 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 |
*errorCodePtr = EINVAL;
return 0;
}
*errorCodePtr = EOK;
res = Tcl_WriteRaw(rtPtr->parent, (char *) p.transform.buf,
p.transform.size);
ckfree(p.transform.buf);
} else
#endif /* TCL_THREADS */
{
/* ASSERT: rtPtr->method & FLAG(METH_WRITE) */
/* ASSERT: rtPtr->mode & TCL_WRITABLE */
bufObj = Tcl_NewByteArrayObj((unsigned char *) buf, toWrite);
Tcl_IncrRefCount(bufObj);
if (InvokeTclMethod(rtPtr, "write", bufObj, NULL, &resObj) != TCL_OK) {
*errorCodePtr = EINVAL;
Tcl_SetChannelError(rtPtr->chan, resObj);
Tcl_DecrRefCount(bufObj);
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
return 0;
}
*errorCodePtr = EOK;
bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
res = Tcl_WriteRaw(rtPtr->parent, (char *) bytev, bytec);
Tcl_DecrRefCount(bufObj);
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
}
if (res < 0) {
*errorCodePtr = Tcl_GetErrno();
return 0;
}
return 1;
}
static int
TransformDrain(
ReflectedTransform *rtPtr,
int *errorCodePtr)
{
Tcl_Obj *resObj;
int bytec; /* Number of returned bytes */
unsigned char *bytev; /* Array of returned bytes */
/*
* Are we in the correct thread?
*/
#if TCL_THREADS
if (rtPtr->thread != Tcl_GetCurrentThread()) {
ForwardParam p;
ForwardOpToOwnerThread(rtPtr, ForwardedDrain, &p);
if (p.base.code != TCL_OK) {
PassReceivedError(rtPtr->chan, &p);
*errorCodePtr = EINVAL;
return 0;
}
*errorCodePtr = EOK;
ResultAdd(&rtPtr->result, UCHARP(p.transform.buf), p.transform.size);
ckfree(p.transform.buf);
} else
#endif /* TCL_THREADS */
{
if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj)!=TCL_OK) {
Tcl_SetChannelError(rtPtr->chan, resObj);
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
*errorCodePtr = EINVAL;
return 0;
}
bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
ResultAdd(&rtPtr->result, bytev, bytec);
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
}
rtPtr->readIsDrained = 1;
return 1;
}
static int
TransformFlush(
ReflectedTransform *rtPtr,
int *errorCodePtr,
int op)
{
Tcl_Obj *resObj;
int bytec; /* Number of returned bytes */
unsigned char *bytev; /* Array of returned bytes */
int res;
/*
* Are we in the correct thread?
*/
|
| ︙ | ︙ | |||
3274 3275 3276 3277 3278 3279 3280 |
*errorCodePtr = EOK;
if (op == FLUSH_WRITE) {
res = Tcl_WriteRaw(rtPtr->parent, (char *) p.transform.buf,
p.transform.size);
} else {
res = 0;
}
| | | | 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 |
*errorCodePtr = EOK;
if (op == FLUSH_WRITE) {
res = Tcl_WriteRaw(rtPtr->parent, (char *) p.transform.buf,
p.transform.size);
} else {
res = 0;
}
ckfree(p.transform.buf);
} else
#endif /* TCL_THREADS */
{
if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj)!=TCL_OK) {
Tcl_SetChannelError(rtPtr->chan, resObj);
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
*errorCodePtr = EINVAL;
return 0;
}
if (op == FLUSH_WRITE) {
bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
res = Tcl_WriteRaw(rtPtr->parent, (char *) bytev, bytec);
} else {
res = 0;
}
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
}
|
| ︙ | ︙ | |||
3385 3386 3387 3388 3389 3390 3391 |
return 0;
}
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
Tcl_RestoreInterpState(rtPtr->interp, sr);
return 1;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < | 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 |
return 0;
}
Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
Tcl_RestoreInterpState(rtPtr->interp, sr);
return 1;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclIOSock.c.
| ︙ | ︙ | |||
26 27 28 29 30 31 32 |
static const char *
gai_strerror(
int code)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->initialized) {
| | > | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
static const char *
gai_strerror(
int code)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->initialized) {
Tcl_DStringSetLength(&tsdPtr->errorMsg, 0);
} else {
Tcl_DStringInit(&tsdPtr->errorMsg);
tsdPtr->initialized = 1;
}
Tcl_WCharToUtfDString(gai_strerrorW(code), -1, &tsdPtr->errorMsg);
return Tcl_DStringValue(&tsdPtr->errorMsg);
}
#endif
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
219 220 221 222 223 224 225 |
/*
* We found some problems when using AI_ADDRCONFIG, e.g. on systems that
* have no networking besides the loopback interface and want to resolve
* localhost. See [Bugs 3385024, 3382419, 3382431]. As the advantage of
* using AI_ADDRCONFIG is probably low even in situations where it works,
* we'll leave it out for now. After all, it is just an optimisation.
*
| | | 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 |
/*
* We found some problems when using AI_ADDRCONFIG, e.g. on systems that
* have no networking besides the loopback interface and want to resolve
* localhost. See [Bugs 3385024, 3382419, 3382431]. As the advantage of
* using AI_ADDRCONFIG is probably low even in situations where it works,
* we'll leave it out for now. After all, it is just an optimisation.
*
* Missing on: OpenBSD, NetBSD.
* Causes failure when used on AIX 5.1 and HP-UX
*/
#if defined(AI_ADDRCONFIG) && !defined(_AIX) && !defined(__hpux)
hints.ai_flags |= AI_ADDRCONFIG;
#endif /* AI_ADDRCONFIG && !_AIX && !__hpux */
#endif /* 0 */
|
| ︙ | ︙ |
Changes to generic/tclIOUtil.c.
1 2 3 | /* * tclIOUtil.c -- * | < < | | | < | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | /* * tclIOUtil.c -- * * Provides an interface for managing filesystems in Tcl, and also for * creating a filesystem interface in Tcl arbitrary facilities. All * filesystem operations are performed via this interface. Vince Darley * is the primary author. Other signifiant contributors are Karl * Lehenbauer, Mark Diekhans and Peter da Silva. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * Copyright (c) 2001-2004 Vincent Darley. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. |
| ︙ | ︙ | |||
29 30 31 32 33 34 35 | #include <sys/statfs.h> #endif #endif /* * struct FilesystemRecord -- * | < | | | | | | < < < < < | > > | > > > | | | < < < < | < < < < < < < | < < < | < < < > > > > | > > | | > > > | | | | | | < < | 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 |
#include <sys/statfs.h>
#endif
#endif
/*
* struct FilesystemRecord --
*
* An item in a linked list of registered filesystems
*/
typedef struct FilesystemRecord {
ClientData clientData; /* Client-specific data for the filesystem
* (can be NULL) */
const Tcl_Filesystem *fsPtr;/* Pointer to filesystem dispatch table. */
struct FilesystemRecord *nextPtr;
/* The next registered filesystem, or NULL to
* indicate the end of the list. */
struct FilesystemRecord *prevPtr;
/* The previous filesystem, or NULL to indicate
* the ned of the list */
} FilesystemRecord;
/*
*/
typedef struct {
int initialized;
size_t cwdPathEpoch; /* Compared with the global cwdPathEpoch to
* determine whether cwdPathPtr is stale.
*/
size_t filesystemEpoch;
Tcl_Obj *cwdPathPtr; /* A private copy of cwdPathPtr. Updated when
* the value is accessed and cwdPathEpoch has
* changed.
*/
ClientData cwdClientData;
FilesystemRecord *filesystemList;
size_t claims;
} ThreadSpecificData;
/*
* Forward declarations.
*/
static Tcl_NRPostProc EvalFileCallback;
static FilesystemRecord*FsGetFirstFilesystem(void);
static void FsThrExitProc(ClientData cd);
static Tcl_Obj * FsListMounts(Tcl_Obj *pathPtr, const char *pattern);
static void FsAddMountsToGlobResult(Tcl_Obj *resultPtr,
Tcl_Obj *pathPtr, const char *pattern,
Tcl_GlobTypeData *types);
static void FsUpdateCwd(Tcl_Obj *cwdObj, ClientData clientData);
static void FsRecacheFilesystemList(void);
static void Claim(void);
static void Disclaim(void);
static void * DivertFindSymbol(Tcl_Interp *interp,
Tcl_LoadHandle loadHandle, const char *symbol);
static void DivertUnloadFile(Tcl_LoadHandle loadHandle);
/*
* Functions that provide native filesystem support. They are private and
* should be used only here. They should be called instead of calling Tclp...
* native filesystem functions. Others should use the Tcl_FS... functions
* which ensure correct and complete virtual filesystem support.
*/
static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator;
static Tcl_FSFreeInternalRepProc NativeFreeInternalRep;
static Tcl_FSFileAttrStringsProc NativeFileAttrStrings;
static Tcl_FSFileAttrsGetProc NativeFileAttrsGet;
static Tcl_FSFileAttrsSetProc NativeFileAttrsSet;
/*
* Functions that support the native filesystem functions listed above. They
* are the same for win/unix, and not in tclInt.h because they are and should
* be used only here.
*/
MODULE_SCOPE const char *const tclpFileAttrStrings[];
MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[];
/*
* These these functions are not static either because routines in the native
* (win/unix) directories call them or they are actually implemented in those
* directories. They should be called from outside Tcl's native filesystem
* routines. If we ever built the native filesystem support into a separate
* code library, this could actually be enforced.
*/
Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType;
Tcl_FSInternalToNormalizedProc TclpNativeToNormalized;
Tcl_FSStatProc TclpObjStat;
Tcl_FSAccessProc TclpObjAccess;
Tcl_FSMatchInDirectoryProc TclpMatchInDirectory;
Tcl_FSChdirProc TclpObjChdir;
Tcl_FSLstatProc TclpObjLstat;
Tcl_FSCopyFileProc TclpObjCopyFile;
Tcl_FSDeleteFileProc TclpObjDeleteFile;
Tcl_FSRenameFileProc TclpObjRenameFile;
Tcl_FSCreateDirectoryProc TclpObjCreateDirectory;
Tcl_FSCopyDirectoryProc TclpObjCopyDirectory;
Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory;
Tcl_FSLinkProc TclpObjLink;
Tcl_FSListVolumesProc TclpObjListVolumes;
/*
* The native filesystem dispatch table. This could me made public but it
* should only be accessed by the functions it points to, or perhaps
* subordinate helper functions.
*/
const Tcl_Filesystem tclNativeFilesystem = {
"native",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_2,
TclNativePathInFilesystem,
|
| ︙ | ︙ | |||
180 181 182 183 184 185 186 |
TclpObjRemoveDirectory,
TclpObjDeleteFile,
TclpObjCopyFile,
TclpObjRenameFile,
TclpObjCopyDirectory,
TclpObjLstat,
/* Needs casts since we're using version_2. */
| | | | | | < < < | > | < < | < | > | | < | | | | < > < | > | | 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 |
TclpObjRemoveDirectory,
TclpObjDeleteFile,
TclpObjCopyFile,
TclpObjRenameFile,
TclpObjCopyDirectory,
TclpObjLstat,
/* Needs casts since we're using version_2. */
(Tcl_FSLoadFileProc *)(void *) TclpDlopen,
(Tcl_FSGetCwdProc *) TclpGetNativeCwd,
TclpObjChdir
};
/*
* An initial record in the linked list for the native filesystem. Remains at
* the tail of the list and is never freed. Currently the native filesystem is
* hard-coded. It may make sense to modify this to accomodate unconventional
* uses of Tcl that provide no native filesystem.
*/
static FilesystemRecord nativeFilesystemRecord = {
NULL,
&tclNativeFilesystem,
NULL,
NULL
};
/*
* Incremented each time the linked list of filesystems is modified. For
* multithreaded builds, invalidates all cached filesystem internal
* representations.
*/
static size_t theFilesystemEpoch = 1;
/*
* The linked list of filesystems. To minimize locking each thread maintains a
* local copy of this list.
*
*/
static FilesystemRecord *filesystemList = &nativeFilesystemRecord;
TCL_DECLARE_MUTEX(filesystemMutex)
/*
* A files-system indepent sense of the current directory.
*/
static Tcl_Obj *cwdPathPtr = NULL;
static size_t cwdPathEpoch = 0; /* The pathname of the current directory */
static ClientData cwdClientData = NULL;
TCL_DECLARE_MUTEX(cwdMutex)
static Tcl_ThreadDataKey fsDataKey;
/*
* When a temporary copy of a file is created on the native filesystem in order
* to load the file, an FsDivertLoad structure is created to track both the
* actual unloadProc/clientData combination which was used, and the original and
* modified filenames. This makes it possible to correctly undo the entire
* operation in order to unload the library.
*/
typedef struct {
Tcl_LoadHandle loadHandle;
Tcl_FSUnloadFileProc *unloadProcPtr;
Tcl_Obj *divertedFile;
const Tcl_Filesystem *divertedFilesystem;
ClientData divertedFileNativeRep;
} FsDivertLoad;
/*
* Obsolete string-based APIs that should be removed in a future release,
* perhaps in Tcl 9.
*/
/* Obsolete */
int
Tcl_Stat(
const char *path, /* Pathname of file to stat (in current CP). */
struct stat *oldStyleBuf) /* Filled with results of stat call. */
{
int ret;
Tcl_StatBuf buf;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
Tcl_IncrRefCount(pathPtr);
|
| ︙ | ︙ | |||
323 324 325 326 327 328 329 | oldStyleBuf->st_ino = (ino_t) buf.st_ino; oldStyleBuf->st_dev = buf.st_dev; oldStyleBuf->st_rdev = buf.st_rdev; oldStyleBuf->st_nlink = buf.st_nlink; oldStyleBuf->st_uid = buf.st_uid; oldStyleBuf->st_gid = buf.st_gid; oldStyleBuf->st_size = (off_t) buf.st_size; | | | | | > | | | < | 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 |
oldStyleBuf->st_ino = (ino_t) buf.st_ino;
oldStyleBuf->st_dev = buf.st_dev;
oldStyleBuf->st_rdev = buf.st_rdev;
oldStyleBuf->st_nlink = buf.st_nlink;
oldStyleBuf->st_uid = buf.st_uid;
oldStyleBuf->st_gid = buf.st_gid;
oldStyleBuf->st_size = (off_t) buf.st_size;
oldStyleBuf->st_atime = Tcl_GetAccessTimeFromStat(&buf);
oldStyleBuf->st_mtime = Tcl_GetModificationTimeFromStat(&buf);
oldStyleBuf->st_ctime = Tcl_GetChangeTimeFromStat(&buf);
#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
oldStyleBuf->st_blksize = buf.st_blksize;
#endif
#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
#ifdef HAVE_BLKCNT_T
oldStyleBuf->st_blocks = (blkcnt_t) buf.st_blocks;
#else
oldStyleBuf->st_blocks = (unsigned long) buf.st_blocks;
#endif
#endif
}
return ret;
}
/* Obsolete */
int
Tcl_Access(
const char *path, /* Pathname of file to access (in current CP).
*/
int mode) /* Permission setting. */
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
Tcl_IncrRefCount(pathPtr);
ret = Tcl_FSAccess(pathPtr,mode);
Tcl_DecrRefCount(pathPtr);
return ret;
}
/* Obsolete */
Tcl_Channel
Tcl_OpenFileChannel(
Tcl_Interp *interp, /* Interpreter for error reporting. May be
* NULL. */
const char *path, /* Pathname of file to open. */
const char *modeString, /* A list of POSIX open modes or a string such
* as "rw". */
int permissions) /* The modes to use if creating a new file. */
{
Tcl_Channel ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
Tcl_IncrRefCount(pathPtr);
ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions);
Tcl_DecrRefCount(pathPtr);
|
| ︙ | ︙ | |||
409 410 411 412 413 414 415 |
TclDStringAppendObj(cwdPtr, cwd);
Tcl_DecrRefCount(cwd);
return Tcl_DStringValue(cwdPtr);
}
int
Tcl_EvalFile(
| | | > | | | | | | | 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 |
TclDStringAppendObj(cwdPtr, cwd);
Tcl_DecrRefCount(cwd);
return Tcl_DStringValue(cwdPtr);
}
int
Tcl_EvalFile(
Tcl_Interp *interp, /* Interpreter in which to evaluate the script. */
const char *fileName) /* Pathname of the file containing the script.
* Performs Tilde-substitution on this
* pathaname. */
{
int ret;
Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1);
Tcl_IncrRefCount(pathPtr);
ret = Tcl_FSEvalFile(interp, pathPtr);
Tcl_DecrRefCount(pathPtr);
return ret;
}
/*
* The basic filesystem implementation.
*/
static void
FsThrExitProc(
ClientData cd)
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)cd;
FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL;
/*
* Discard the cwd copy.
*/
if (tsdPtr->cwdPathPtr != NULL) {
Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
tsdPtr->cwdPathPtr = NULL;
}
if (tsdPtr->cwdClientData != NULL) {
NativeFreeInternalRep(tsdPtr->cwdClientData);
}
/*
* Discard the filesystems cache.
*/
fsRecPtr = tsdPtr->filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr->nextPtr;
fsRecPtr->fsPtr = NULL;
ckfree(fsRecPtr);
fsRecPtr = tmpFsRecPtr;
}
tsdPtr->filesystemList = NULL;
tsdPtr->initialized = 0;
}
int
|
| ︙ | ︙ | |||
476 477 478 479 480 481 482 |
}
}
/*
*----------------------------------------------------------------------
*
* TclFSCwdPointerEquals --
| < | | | < > > | | < < > > | 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 |
}
}
/*
*----------------------------------------------------------------------
*
* TclFSCwdPointerEquals --
* Determine whether the given pathname is equal to the current working
* directory.
*
* Results:
* 1 if equal, 0 otherwise.
*
* Side effects:
* Updates TSD if needed.
*
* Stores a pointer to the current directory in *pathPtrPtr if it is not
* already there and the current directory is not NULL.
*
* If *pathPtrPtr is not null its reference count is decremented
* before it is replaced.
*----------------------------------------------------------------------
*/
int
TclFSCwdPointerEquals(
Tcl_Obj **pathPtrPtr)
{
|
| ︙ | ︙ | |||
535 536 537 538 539 540 541 |
if (pathPtrPtr == NULL) {
return (tsdPtr->cwdPathPtr == NULL);
}
if (tsdPtr->cwdPathPtr == *pathPtrPtr) {
return 1;
} else {
| | | | | 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 |
if (pathPtrPtr == NULL) {
return (tsdPtr->cwdPathPtr == NULL);
}
if (tsdPtr->cwdPathPtr == *pathPtrPtr) {
return 1;
} else {
int len1, len2;
const char *str1, *str2;
str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1);
str2 = TclGetStringFromObj(*pathPtrPtr, &len2);
if ((len1 == len2) && !memcmp(str1, str2, len1)) {
/*
* The values are equal but the objects are different. Cache the
* current structure in place of the old one.
*/
Tcl_DecrRefCount(*pathPtrPtr);
*pathPtrPtr = tsdPtr->cwdPathPtr;
Tcl_IncrRefCount(*pathPtrPtr);
return 1;
} else {
|
| ︙ | ︙ | |||
586 587 588 589 590 591 592 |
fsRecPtr = filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr;
fsRecPtr = fsRecPtr->nextPtr;
}
/*
| | | | | 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 |
fsRecPtr = filesystemList;
while (fsRecPtr != NULL) {
tmpFsRecPtr = fsRecPtr;
fsRecPtr = fsRecPtr->nextPtr;
}
/*
* Refill the cache, honouring the order.
*/
list = NULL;
fsRecPtr = tmpFsRecPtr;
while (fsRecPtr != NULL) {
tmpFsRecPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord));
*tmpFsRecPtr = *fsRecPtr;
tmpFsRecPtr->nextPtr = list;
tmpFsRecPtr->prevPtr = NULL;
list = tmpFsRecPtr;
fsRecPtr = fsRecPtr->prevPtr;
}
tsdPtr->filesystemList = list;
tsdPtr->filesystemEpoch = theFilesystemEpoch;
Tcl_MutexUnlock(&filesystemMutex);
while (toFree) {
FilesystemRecord *next = toFree->nextPtr;
toFree->fsPtr = NULL;
ckfree(toFree);
toFree = next;
}
/*
* Make sure the above gets released on thread exit.
*/
|
| ︙ | ︙ | |||
633 634 635 636 637 638 639 |
&& (tsdPtr->filesystemEpoch != theFilesystemEpoch))) {
FsRecacheFilesystemList();
}
return tsdPtr->filesystemList;
}
/*
| | | | 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 |
&& (tsdPtr->filesystemEpoch != theFilesystemEpoch))) {
FsRecacheFilesystemList();
}
return tsdPtr->filesystemList;
}
/*
* The epoch can is changed when a filesystems is added or removed, when
* "system encoding" changes, and when env(HOME) changes.
*/
int
TclFSEpochOk(
size_t filesystemEpoch)
{
return (filesystemEpoch == 0 || filesystemEpoch == theFilesystemEpoch);
|
| ︙ | ︙ | |||
669 670 671 672 673 674 675 |
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
return tsdPtr->filesystemEpoch;
}
/*
| | | | | 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 |
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
return tsdPtr->filesystemEpoch;
}
/*
* If non-NULL, take posession of clientData and free it later.
*/
static void
FsUpdateCwd(
Tcl_Obj *cwdObj,
ClientData clientData)
{
int len;
const char *str = NULL;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
if (cwdObj != NULL) {
str = TclGetStringFromObj(cwdObj, &len);
}
Tcl_MutexLock(&cwdMutex);
if (cwdPathPtr != NULL) {
Tcl_DecrRefCount(cwdPathPtr);
}
if (cwdClientData != NULL) {
NativeFreeInternalRep(cwdClientData);
}
if (cwdObj == NULL) {
cwdPathPtr = NULL;
cwdClientData = NULL;
} else {
/*
* This must be stored as a string obj!
*/
cwdPathPtr = Tcl_NewStringObj(str, len);
Tcl_IncrRefCount(cwdPathPtr);
cwdClientData = TclNativeDupInternalRep(clientData);
}
|
| ︙ | ︙ | |||
734 735 736 737 738 739 740 | } /* *---------------------------------------------------------------------- * * TclFinalizeFilesystem -- * | | | | | | | | > | 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 |
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeFilesystem --
*
* Clean up the filesystem. After this, any call to a Tcl_FS... function
* fails.
*
* If TclResetFilesystem is called later, it restores the filesystem to a
* pristine state.
*
* Results:
* None.
*
* Side effects:
* Frees memory allocated for the filesystem.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeFilesystem(void)
{
FilesystemRecord *fsRecPtr;
/*
* Assume that only one thread is active. Otherwise mutexes would be needed
* around this code.
* TO DO: This assumption is false, isn't it?
*/
if (cwdPathPtr != NULL) {
Tcl_DecrRefCount(cwdPathPtr);
cwdPathPtr = NULL;
cwdPathEpoch = 0;
}
|
| ︙ | ︙ | |||
779 780 781 782 783 784 785 |
*/
fsRecPtr = filesystemList;
while (fsRecPtr != NULL) {
FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr;
/*
| | | | | | 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 |
*/
fsRecPtr = filesystemList;
while (fsRecPtr != NULL) {
FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr;
/*
* The native filesystem is static, so don't free it.
*/
if (fsRecPtr != &nativeFilesystemRecord) {
ckfree(fsRecPtr);
}
fsRecPtr = tmpFsRecPtr;
}
if (++theFilesystemEpoch == 0) {
++theFilesystemEpoch;
}
filesystemList = NULL;
/*
* filesystemList is now NULL. Any attempt to use the filesystem is likely
* to fail.
*/
#ifdef _WIN32
TclWinEncodingsCleanup();
#endif
}
|
| ︙ | ︙ | |||
832 833 834 835 836 837 838 | } /* *---------------------------------------------------------------------- * * Tcl_FSRegister -- * | | < | > | < < < < > | < | | | | | > | | < < < < < < < < < < < < < | | | < | | | | < | < > | | | > | | < < < | < | < < < | < < < < < < < < > | < > < < < > < < < < < < < > | | | | | > | > > > | | | | | | | > | | < | < > | < | | < | | | < | | < | 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 |
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSRegister --
*
* Prepends to the list of registered fileystems a new FilesystemRecord
* for the given Tcl_Filesystem, which is added even if it is already in
* the list. To determine whether the filesystem is already in the list,
* use Tcl_FSData().
*
* Functions that use the list generally process it from head to tail and
* use the first filesystem that is suitable. Therefore, when adding a
* diagnostic filsystem (one which simply reports all fs activity), it
* must be at the head of the list. I.e. it must be the last one
* registered.
*
* Results:
* TCL_OK, or TCL_ERROR if memory for a new node in the list could
* not be allocated.
*
* Side effects:
* Allocates memory for a filesystem record and modifies the list of
* registered filesystems.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSRegister(
ClientData clientData, /* Client-specific data for this filesystem. */
const Tcl_Filesystem *fsPtr)/* The filesystem record for the new fs. */
{
FilesystemRecord *newFilesystemPtr;
if (fsPtr == NULL) {
return TCL_ERROR;
}
newFilesystemPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord));
newFilesystemPtr->clientData = clientData;
newFilesystemPtr->fsPtr = fsPtr;
Tcl_MutexLock(&filesystemMutex);
newFilesystemPtr->nextPtr = filesystemList;
newFilesystemPtr->prevPtr = NULL;
if (filesystemList) {
filesystemList->prevPtr = newFilesystemPtr;
}
filesystemList = newFilesystemPtr;
/*
* Increment the filesystem epoch counter since existing pathnames might
* conceivably now belong to different filesystems.
*/
if (++theFilesystemEpoch == 0) {
++theFilesystemEpoch;
}
Tcl_MutexUnlock(&filesystemMutex);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSUnregister --
*
* Removes the record for given filesystem from the list of registered
* filesystems. Refuses to remove the built-in (native) filesystem. This
* might be changed in the future to allow a smaller Tcl core in which the
* native filesystem is not used at all, e.g. initializing Tcl over a
* network connection.
*
* Results:
* TCL_OK if the function pointer was successfully removed, or TCL_ERROR
* otherwise.
*
* Side effects:
* The list of registered filesystems is updated. Memory for the
* corresponding FilesystemRecord is eventually freed.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSUnregister(
const Tcl_Filesystem *fsPtr)/* The filesystem record to remove. */
{
int retVal = TCL_ERROR;
FilesystemRecord *fsRecPtr;
Tcl_MutexLock(&filesystemMutex);
/*
* Traverse filesystemList in search of the record whose
* 'fsPtr' member matches 'fsPtr' and remove that record from the list.
* Do not revmoe the record for the native filesystem.
*/
fsRecPtr = filesystemList;
while ((retVal == TCL_ERROR) && (fsRecPtr != &nativeFilesystemRecord)) {
if (fsRecPtr->fsPtr == fsPtr) {
if (fsRecPtr->prevPtr) {
fsRecPtr->prevPtr->nextPtr = fsRecPtr->nextPtr;
} else {
filesystemList = fsRecPtr->nextPtr;
}
if (fsRecPtr->nextPtr) {
fsRecPtr->nextPtr->prevPtr = fsRecPtr->prevPtr;
}
/*
* Each cached pathname could now belong to a different filesystem,
* so increment the filesystem epoch counter to ensure that cached
* information about the removed filesystem is not used.
*/
if (++theFilesystemEpoch == 0) {
++theFilesystemEpoch;
}
ckfree(fsRecPtr);
retVal = TCL_OK;
} else {
fsRecPtr = fsRecPtr->nextPtr;
}
}
Tcl_MutexUnlock(&filesystemMutex);
return retVal;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSMatchInDirectory --
*
* Search in the given pathname for files matching the given pattern.
* Used by [glob]. Processes just one pattern for one directory. Callers
* such as TclGlob and DoGlob implement manage the searching of multiple
* directories in cases such as
* glob -dir $dir -join * pkgIndex.tcl
*
* Results:
*
* TCL_OK, or TCL_ERROR
*
* Side effects:
* resultPtr is populated, or in the case of an TCL_ERROR, an error message is
* set in the interpreter.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSMatchInDirectory(
Tcl_Interp *interp, /* Interpreter to receive error messages, or
* NULL */
Tcl_Obj *resultPtr, /* List that results are added to. */
Tcl_Obj *pathPtr, /* Pathname of directory to search. If NULL,
* the current working directory is used. */
const char *pattern, /* Pattern to match. If NULL, pathPtr must be
* a fully-specified pathname of a single
* file/directory which already exists and is
* of the correct type. */
Tcl_GlobTypeData *types) /* Specifies acceptable types.
* May be NULL. The directory flag is
* particularly significant. */
{
const Tcl_Filesystem *fsPtr;
Tcl_Obj *cwd, *tmpResultPtr, **elemsPtr;
int resLength, i, ret = -1;
if (types != NULL && (types->type & TCL_GLOB_TYPE_MOUNT)) {
/*
* Currently external callers may not query mounts, which would be a
* valuable future step. This is the only routine that knows about
* mounts, so we're being called recursively by ourself. Return no
* matches.
*/
return TCL_OK;
}
if (pathPtr != NULL) {
fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
} else {
fsPtr = NULL;
}
if (fsPtr != NULL) {
/*
* A corresponding filesystem was found. Search within it.
*/
if (fsPtr->matchInDirectoryProc == NULL) {
Tcl_SetErrno(ENOENT);
return -1;
}
ret = fsPtr->matchInDirectoryProc(interp, resultPtr, pathPtr, pattern,
types);
if (ret == TCL_OK && pattern != NULL) {
FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types);
}
return ret;
}
if (pathPtr != NULL && TclGetString(pathPtr)[0] != '\0') {
/*
* There is a pathname but it belongs to no known filesystem. Mayday!
*/
Tcl_SetErrno(ENOENT);
return -1;
}
/*
* The pathname is empty or NULL so search in the current working
* directory. matchInDirectoryProc prefixes each result with this
* directory, so trim it from each result. Deal with this here in the
* generic code because otherwise every filesystem implementation of
* Tcl_FSMatchInDirectory has to do it.
*/
cwd = Tcl_FSGetCwd(NULL);
if (cwd == NULL) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"glob couldn't determine the current working directory",
|
| ︙ | ︙ | |||
1114 1115 1116 1117 1118 1119 1120 |
Tcl_IncrRefCount(tmpResultPtr);
ret = fsPtr->matchInDirectoryProc(interp, tmpResultPtr, cwd, pattern,
types);
if (ret == TCL_OK) {
FsAddMountsToGlobResult(tmpResultPtr, cwd, pattern, types);
/*
| | < < | | | | | | | | | | | | 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 |
Tcl_IncrRefCount(tmpResultPtr);
ret = fsPtr->matchInDirectoryProc(interp, tmpResultPtr, cwd, pattern,
types);
if (ret == TCL_OK) {
FsAddMountsToGlobResult(tmpResultPtr, cwd, pattern, types);
/*
* resultPtr and tmpResultPtr are guaranteed to be distinct.
*/
ret = Tcl_ListObjGetElements(interp, tmpResultPtr,
&resLength, &elemsPtr);
for (i=0 ; ret==TCL_OK && i<resLength ; i++) {
ret = Tcl_ListObjAppendElement(interp, resultPtr,
TclFSMakePathRelative(interp, elemsPtr[i], cwd));
}
}
TclDecrRefCount(tmpResultPtr);
}
Tcl_DecrRefCount(cwd);
return ret;
}
/*
*----------------------------------------------------------------------
*
* FsAddMountsToGlobResult --
* Adds any mounted pathnames to a set of results so that simple things
* like 'glob *' merge mounts and listings correctly. Used by the
* Tcl_FSMatchInDirectory.
*
* Results:
* None.
*
* Side effects:
* Stores a result in resultPtr.
*
*----------------------------------------------------------------------
*/
static void
FsAddMountsToGlobResult(
Tcl_Obj *resultPtr, /* The current list of matching pathnames. Must
* not be shared. */
Tcl_Obj *pathPtr, /* The directory that was searched. */
const char *pattern, /* Pattern to match mounts against. */
Tcl_GlobTypeData *types) /* Acceptable types. May be NULL. The
* directory flag is particularly significant.
*/
{
int mLength, gLength, i;
int dir = (types == NULL || (types->type & TCL_GLOB_TYPE_DIR));
Tcl_Obj *mounts = FsListMounts(pathPtr, pattern);
if (mounts == NULL) {
return;
|
| ︙ | ︙ | |||
1199 1200 1201 1202 1203 1204 1205 |
gLength--;
}
break; /* Break out of for loop. */
}
}
if (!found && dir) {
Tcl_Obj *norm;
| | | | | > > | < | < | | | | < | | | | | < > | | | | | | > | < < | < > | | < > | < < | | | < < | < > | < | | < | > | < < | | | | < > | | | | < < < | > | > > > > | | | | | | | | | | | > | | | < < | | | | | | | | | | | > | < < < | < < | | > | | > > > | < | | | | | | | | | < | | | | 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 |
gLength--;
}
break; /* Break out of for loop. */
}
}
if (!found && dir) {
Tcl_Obj *norm;
int len, mlen;
/*
* mElt is normalized and lies inside pathPtr so
* add to the result the right representation of mElt,
* i.e. the representation relative to pathPtr.
*/
norm = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (norm != NULL) {
const char *path, *mount;
mount = TclGetStringFromObj(mElt, &mlen);
path = TclGetStringFromObj(norm, &len);
if (path[len-1] == '/') {
/*
* Deal with the root of the volume.
*/
len--;
}
len++; /* account for '/' in the mElt [Bug 1602539] */
mElt = TclNewFSPathObj(pathPtr, mount + len, mlen - len);
Tcl_ListObjAppendElement(NULL, resultPtr, mElt);
}
/*
* Not comparing mounts to mounts, so no need to increment gLength
*/
}
}
endOfMounts:
Tcl_DecrRefCount(mounts);
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSMountsChanged --
*
* Announecs that mount points have changed or that the system encoding
* has changed.
*
* Results:
* None.
*
* Side effects:
* The shared 'theFilesystemEpoch' is incremented, invalidating every
* exising cached internal representation of a pathname. Avoid calling
* Tcl_FSMountsChanged whenever possible. It must be called when:
*
* (1) A filesystem is registered or unregistered. This is only necessary
* if the new filesystem accepts file pathnames as-is. Normally the
* filesystem is really a shell which doesn't yet have any mount points
* established and so its 'pathInFilesystem' routine always fails.
* However, for safety, Tcl calls 'Tcl_FSMountsChanged' each time a
* filesystem is registered or unregistered.
*
* (2) An additional mount point is established inside an existing
* filesystem (except for the native file system; see note below).
*
* (3) A filesystem changes the list of available volumes (except for the
* native file system; see note below).
*
* (4) The mapping from a string representation of a file to a full,
* normalized pathname changes. For example, if 'env(HOME)' is modified,
* then any pathname containing '~' maps to a different item, possibly in
* a different filesystem.
*
* Tcl has no control over (2) and (3), so each registered filesystem must
* call Tcl_FSMountsChnaged in each of those circumstances.
*
* The reason for the exception in 2,3 for the native filesystem is that
* the native filesystem claims every file without determining whether
* whether the file exists, or even whether the pathname makes sense.
*
*----------------------------------------------------------------------
*/
void
Tcl_FSMountsChanged(
TCL_UNUSED(const Tcl_Filesystem *) /*fsPtr*/)
/*
* fsPtr is currently unused. In the future it might invalidate files for
* a particular filesystem, or take some other more advanced action.
*/
{
/*
* Increment the filesystem epoch to invalidate every existing cached
* internal representation.
*/
Tcl_MutexLock(&filesystemMutex);
if (++theFilesystemEpoch == 0) {
++theFilesystemEpoch;
}
Tcl_MutexUnlock(&filesystemMutex);
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSData --
*
* Retrieves the clientData member of the given filesystem.
*
* Results:
* A clientData value, or NULL if the given filesystem is not registered.
* The clientData value itself may also be NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
ClientData
Tcl_FSData(
const Tcl_Filesystem *fsPtr) /* The filesystem to find in the list of
* registered filesystems. */
{
ClientData retVal = NULL;
FilesystemRecord *fsRecPtr = FsGetFirstFilesystem();
/*
* Find the filesystem in and retrieve its clientData.
*/
while ((retVal == NULL) && (fsRecPtr != NULL)) {
if (fsRecPtr->fsPtr == fsPtr) {
retVal = fsRecPtr->clientData;
}
fsRecPtr = fsRecPtr->nextPtr;
}
return retVal;
}
/*
*---------------------------------------------------------------------------
*
* TclFSNormalizeToUniquePath --
*
* Converts the given pathname, containing no ../, ./ components, into a
* unique pathname for the given platform. On Unix the resulting pathname
* is free of symbolic links/aliases, and on Windows it is the long
* case-preserving form.
*
*
* Results:
* Stores the resulting pathname in pathPtr and returns the offset of the
* last byte processed in pathPtr.
*
* Side effects:
* None (beyond the memory allocation for the result).
*
* Special notes:
* If the filesystem-specific normalizePathProcs can re-introduce ../, ./
* components into the pathname, this function does not return the correct
* result. This may be possible with symbolic links on unix.
*
*
*---------------------------------------------------------------------------
*/
int
TclFSNormalizeToUniquePath(
Tcl_Interp *interp, /* Used for error messages. */
Tcl_Obj *pathPtr, /* An Pathname to normalize in-place. Must be
* unshared. */
int startAt) /* Offset the string of pathPtr to start at.
* Must either be 0 or offset of a directory
* separator at the end of a pathname part that
* is already normalized, I.e. not the index of
* the byte just after the separator. */
{
FilesystemRecord *fsRecPtr, *firstFsRecPtr;
int i;
int isVfsPath = 0;
const char *path;
/*
* Pathnames starting with a UNC prefix and ending with a colon character
* are reserved for VFS use. These names can not conflict with real UNC
* pathnames per https://msdn.microsoft.com/en-us/library/gg465305.aspx and
* rfc3986's definition of reg-name.
*
* We check these first to avoid useless calls to the native filesystem's
* normalizePathProc.
*/
path = Tcl_GetStringFromObj(pathPtr, &i);
if ( (i >= 3) && ( (path[0] == '/' && path[1] == '/')
|| (path[0] == '\\' && path[1] == '\\') ) ) {
for ( i = 2; ; i++) {
if (path[i] == '\0') break;
if (path[i] == path[0]) break;
}
--i;
if (path[i] == ':') isVfsPath = 1;
}
/*
* Call the the normalizePathProc routine of each registered filesystem.
*/
firstFsRecPtr = FsGetFirstFilesystem();
Claim();
if (!isVfsPath) {
/*
* Find and call the native filesystem handler first if there is one
* because the root of Tcl's filesystem is always a native filesystem
* (i.e., '/' on unix is native).
*/
for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
continue;
}
/*
* TODO: Always call the normalizePathProc here because it should
* always exist.
*/
if (fsRecPtr->fsPtr->normalizePathProc != NULL) {
startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr,
startAt);
}
break;
}
}
for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
if (fsRecPtr->fsPtr == &tclNativeFilesystem) {
/*
* Skip the native system this time through.
*/
continue;
}
if (fsRecPtr->fsPtr->normalizePathProc != NULL) {
startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr,
startAt);
}
/*
* This efficiency check could be added:
* if (retVal == length-of(pathPtr)) {break;}
* but there's not much benefit.
*/
}
Disclaim();
return startAt;
}
/*
*---------------------------------------------------------------------------
*
* TclGetOpenMode --
*
* Obsolete. A limited version of TclGetOpenModeEx() which exists only to
* satisfy any extensions imprudently using it via Tcl's internal stubs
* table.
*
* Results:
* See TclGetOpenModeEx().
*
* Side effects:
* See TclGetOpenModeEx().
*
*---------------------------------------------------------------------------
*/
int
TclGetOpenMode(
Tcl_Interp *interp, /* Interpreter to use for error reporting. May
* be NULL. */
const char *modeString, /* e.g. "r+" or "RDONLY CREAT". */
int *seekFlagPtr) /* Sets this to 1 to tell the caller to seek to
EOF after opening the file, and
* 0 otherwise. */
{
int binary = 0;
return TclGetOpenModeEx(interp, modeString, seekFlagPtr, &binary);
}
/*
*---------------------------------------------------------------------------
*
* TclGetOpenModeEx --
*
* Computes a POSIX mode mask for opening a file.
*
* Results:
* The mode to pass to "open", or -1 if an error occurs.
*
* Side effects:
* Sets *seekFlagPtr to 1 to tell the caller to
* seek to EOF after opening the file, or to 0 otherwise.
*
* Sets *binaryPtr to 1 to tell the caller to configure the channel as a
* binary channel, or to 0 otherwise.
*
* If there is an error and interp is not NULL, sets interpreter result to
* an error message.
*
* Special note:
* Based on a prototype implementation contributed by Mark Diekhans.
*
*---------------------------------------------------------------------------
*/
int
TclGetOpenModeEx(
Tcl_Interp *interp, /* Interpreter, possibly NULL, to use for
* error reporting. */
const char *modeString, /* Mode string, e.g. "r+" or "RDONLY CREAT" */
int *seekFlagPtr, /* Sets this to 1 to tell the the caller to seek to
* EOF after opening the file, and 0 otherwise. */
int *binaryPtr) /* Sets this to 1 to tell the caller to
* configure the channel for binary
* operations after opening the file. */
{
int mode, modeArgc, c, i, gotRW;
const char **modeArgv, *flag;
#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)
/*
* Check for the simpler fopen-like access modes like "r" which are
* distinguished from the POSIX access modes by the presence of a
* lower-case first letter.
*/
*seekFlagPtr = 0;
*binaryPtr = 0;
mode = 0;
/*
* Guard against wide characters before using byte-oriented routines.
*/
if (!(modeString[0] & 0x80)
&& islower(UCHAR(modeString[0]))) { /* INTL: ISO only. */
switch (modeString[0]) {
case 'r':
mode = O_RDONLY;
break;
case 'w':
mode = O_WRONLY|O_CREAT|O_TRUNC;
break;
case 'a':
/*
* Add O_APPEND for proper automatic seek-to-end-on-write by the
* OS. [Bug 680143]
*/
mode = O_WRONLY|O_CREAT|O_APPEND;
*seekFlagPtr = 1;
break;
default:
goto error;
}
i = 1;
while (i<3 && modeString[i]) {
if (modeString[i] == modeString[i-1]) {
goto error;
}
switch (modeString[i++]) {
case '+':
/*
* Remove O_APPEND so that the seek command works. [Bug
* 1773127]
*/
mode &= ~(O_RDONLY|O_WRONLY|O_APPEND);
mode |= O_RDWR;
break;
case 'b':
*binaryPtr = 1;
|
| ︙ | ︙ | |||
1616 1617 1618 1619 1620 1621 1622 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"illegal access mode \"%s\"", modeString));
}
return -1;
}
/*
| | < | < | 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"illegal access mode \"%s\"", modeString));
}
return -1;
}
/*
* The access modes are specified as a list of POSIX modes like O_CREAT.
*
* Tcl_SplitList must work correctly when interp is NULL.
*/
if (Tcl_SplitList(interp, modeString, &modeArgc, &modeArgv) != TCL_OK) {
if (interp != NULL) {
Tcl_AddErrorInfo(interp,
"\n while processing open access modes \"");
Tcl_AddErrorInfo(interp, modeString);
|
| ︙ | ︙ | |||
1663 1664 1665 1666 1667 1668 1669 |
mode |= O_NOCTTY;
#else
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"access mode \"%s\" not supported by this system",
flag));
}
| | | | | | > | > | | | | | | > | | | > | | < | | | | | | | > | < | | | | | | < | > | | | | | | > | | | | | | | | | | > | < | | | | | | | | | < | > | | | | | < | | | | | | | | | | | | | | < < | | | < > | < < | > | > > | < | | | > | > > | < | | | | | | | < | | | > > | | < | < < | | | | | | > > > | < | < | | | | | < | | | | | | | > > | | | | | | | | | | | | | | > > | | < < < < | < > | 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 |
mode |= O_NOCTTY;
#else
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"access mode \"%s\" not supported by this system",
flag));
}
ckfree(modeArgv);
return -1;
#endif
} else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) {
#ifdef O_NONBLOCK
mode |= O_NONBLOCK;
#else
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"access mode \"%s\" not supported by this system",
flag));
}
ckfree(modeArgv);
return -1;
#endif
} else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) {
mode |= O_TRUNC;
} else if ((c == 'B') && (strcmp(flag, "BINARY") == 0)) {
*binaryPtr = 1;
} else {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invalid access mode \"%s\": must be RDONLY, WRONLY, "
"RDWR, APPEND, BINARY, CREAT, EXCL, NOCTTY, NONBLOCK,"
" or TRUNC", flag));
}
ckfree(modeArgv);
return -1;
}
}
ckfree(modeArgv);
if (!gotRW) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"access mode must include either RDONLY, WRONLY, or RDWR",
-1));
}
return -1;
}
return mode;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSEvalFile, Tcl_FSEvalFileEx, TclNREvalFile --
*
* Reads a file and evaluates it as a script.
*
* Tcl_FSEvalFile is Tcl_FSEvalFileEx without the encoding argument.
*
* TclNREvalFile is an NRE-enabled version of Tcl_FSEvalFileEx.
*
* Results:
* A standard Tcl result, which is either the result of executing the
* file or an error indicating why the file couldn't be read.
*
* Side effects:
* Arbitrary, depending on the contents of the script. While the script
* is evaluated iPtr->scriptFile is a reference to pathPtr, and after the
* evaluation completes, has its original value restored again.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSEvalFile(
Tcl_Interp *interp, /* Interpreter that evaluates the script. */
Tcl_Obj *pathPtr) /* Pathname of file containing the script.
* Tilde-substitution is performed on this
* pathname. */
{
return Tcl_FSEvalFileEx(interp, pathPtr, NULL);
}
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 system encoding. */
{
int length, result = TCL_ERROR;
Tcl_StatBuf statBuf;
Tcl_Obj *oldScriptFile;
Interp *iPtr;
const char *string;
Tcl_Channel chan;
Tcl_Obj *objPtr;
if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
return result;
}
if (Tcl_FSStat(pathPtr, &statBuf) == -1) {
Tcl_SetErrno(errno);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
return result;
}
chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644);
if (chan == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
return result;
}
/*
* The eof character is \32 (^Z). This is standard on Windows, and Tcl
* 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 don't touch it, leaving things up to the system encoding. If
* the encoding is unknown report an error.
*/
if (encodingName != NULL) {
if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
!= TCL_OK) {
Tcl_Close(interp,chan);
return result;
}
}
objPtr = Tcl_NewObj();
Tcl_IncrRefCount(objPtr);
/*
* Read first character of stream to check for utf-8 BOM
*/
if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
goto end;
}
string = Tcl_GetString(objPtr);
/*
* If first character is not a BOM, append the remaining characters.
* Otherwise, replace them. [Bug 3466099]
*/
if (Tcl_ReadChars(chan, objPtr, -1,
memcmp(string, "\xef\xbb\xbf", 3)) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
goto end;
}
if (Tcl_Close(interp, chan) != TCL_OK) {
goto end;
}
iPtr = (Interp *) interp;
oldScriptFile = iPtr->scriptFile;
iPtr->scriptFile = pathPtr;
Tcl_IncrRefCount(iPtr->scriptFile);
string = TclGetStringFromObj(objPtr, &length);
/*
* TIP #280: Open a frame for the evaluated script.
*/
iPtr->evalFlags |= TCL_EVAL_FILE;
result = TclEvalEx(interp, string, length, 0, 1, NULL, string);
/*
* Restore the original iPtr->scriptFile value, but because the value may
* have hanged during evaluation, don't assume it currently points to
* pathPtr.
*/
if (iPtr->scriptFile != NULL) {
Tcl_DecrRefCount(iPtr->scriptFile);
}
iPtr->scriptFile = oldScriptFile;
if (result == TCL_RETURN) {
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
/*
* Record information about where the error occurred.
*/
const char *pathString = TclGetStringFromObj(pathPtr, &length);
int limit = 150;
int overflow = (length > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (file \"%.*s%s\" line %d)",
(overflow ? limit : length), pathString,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
end:
Tcl_DecrRefCount(objPtr);
return result;
}
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 system encoding. */
{
Tcl_StatBuf statBuf;
Tcl_Obj *oldScriptFile, *objPtr;
Interp *iPtr;
Tcl_Channel chan;
const char *string;
if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
return TCL_ERROR;
}
if (Tcl_FSStat(pathPtr, &statBuf) == -1) {
Tcl_SetErrno(errno);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
return TCL_ERROR;
}
chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644);
if (chan == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
return TCL_ERROR;
}
TclPkgFileSeen(interp, Tcl_GetString(pathPtr));
/*
* The eof character is \32 (^Z). This is standard on Windows, and Tcl
* 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 don't touch it, leaving things up to the system encoding. If
* the encoding is unknown report an error.
*/
if (encodingName != NULL) {
if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
!= TCL_OK) {
Tcl_Close(interp,chan);
return TCL_ERROR;
}
}
objPtr = Tcl_NewObj();
Tcl_IncrRefCount(objPtr);
/*
* Read first character of stream to check for utf-8 BOM
*/
if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
}
string = Tcl_GetString(objPtr);
/*
* If first character is not a BOM, append the remaining characters.
* Otherwise, replace them. [Bug 3466099]
*/
if (Tcl_ReadChars(chan, objPtr, -1,
memcmp(string, "\xef\xbb\xbf", 3)) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
}
if (Tcl_Close(interp, chan) != TCL_OK) {
Tcl_DecrRefCount(objPtr);
return TCL_ERROR;
}
iPtr = (Interp *) interp;
oldScriptFile = iPtr->scriptFile;
iPtr->scriptFile = pathPtr;
Tcl_IncrRefCount(iPtr->scriptFile);
/*
* TIP #280: Open a frame for the evaluated script.
*/
iPtr->evalFlags |= TCL_EVAL_FILE;
TclNRAddCallback(interp, EvalFileCallback, oldScriptFile, pathPtr, objPtr,
NULL);
return TclNREvalObjEx(interp, objPtr, 0, NULL, INT_MIN);
}
static int
EvalFileCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *oldScriptFile = (Tcl_Obj *)data[0];
Tcl_Obj *pathPtr = (Tcl_Obj *)data[1];
Tcl_Obj *objPtr = (Tcl_Obj *)data[2];
/*
* Restore the original iPtr->scriptFile value, but because the value may
* have hanged during evaluation, don't assume it currently points to
* pathPtr.
*/
if (iPtr->scriptFile != NULL) {
Tcl_DecrRefCount(iPtr->scriptFile);
}
iPtr->scriptFile = oldScriptFile;
if (result == TCL_RETURN) {
result = TclUpdateReturnInfo(iPtr);
} else if (result == TCL_ERROR) {
/*
* Record information about where the error occurred.
*/
int length;
const char *pathString = TclGetStringFromObj(pathPtr, &length);
const int limit = 150;
int overflow = (length > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (file \"%.*s%s\" line %d)",
(overflow ? limit : length), pathString,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
Tcl_DecrRefCount(objPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetErrno --
*
* Currently the global variable "errno", but could in the future change
* to something else.
*
* Results:
* The current Tcl error number.
*
* Side effects:
* None. The value of the Tcl error code variable is only defined if it
* was set by a previous call to Tcl_SetErrno.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetErrno(void)
{
/*
* On some platforms errno is thread-local, as implemented by the C
* library.
*/
return errno;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetErrno --
*
* Sets the Tcl error code to the given value. On some saner platforms
* this is implemented in the C library as a thread-local value , but this
* is *really* unsafe to assume!
*
* Results:
* None.
*
* Side effects:
* Modifies the the Tcl error code value.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetErrno(
int err) /* The new value. */
{
/*
* On some platforms, errno is implemented by the C library as a thread
* local value
*/
errno = err;
}
/*
*----------------------------------------------------------------------
*
* Tcl_PosixError --
*
* Typically called after a UNIX kernel call returns an error. Sets the
* interpreter errorCode to machine-parsable information about the error.
*
* Results:
* A human-readable sring describing the error.
*
* Side effects:
* Sets the errorCode value of the interpreter.
*
*----------------------------------------------------------------------
*/
const char *
Tcl_PosixError(
Tcl_Interp *interp) /* Interpreter to set the errorCode of */
{
const char *id, *msg;
msg = Tcl_ErrnoMsg(errno);
id = Tcl_ErrnoId();
if (interp) {
Tcl_SetErrorCode(interp, "POSIX", id, msg, NULL);
}
return msg;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSStat --
* Calls 'statProc' of the filesystem corresponding to pathPtr.
*
* Replaces the standard library routines stat.
*
*
* Results:
* See stat documentation.
*
* Side effects:
* See stat documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSStat(
Tcl_Obj *pathPtr, /* Pathname of the file to call stat on (in
* current CP). */
Tcl_StatBuf *buf) /* A buffer to hold the results of the call to
* stat. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL && fsPtr->statProc != NULL) {
return fsPtr->statProc(pathPtr, buf);
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSLstat --
* Calls the 'lstatProc' of the filesystem corresponding to pathPtr.
*
* Replaces the library version of lstat. If the filesystem doesn't
* provide lstatProc but does provide statProc, Tcl falls back to
* statProc.
*
* Results:
* See lstat documentation.
*
* Side effects:
* See lstat documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSLstat(
Tcl_Obj *pathPtr, /* Pathname of the file to call stat on (in
current CP). */
Tcl_StatBuf *buf) /* Filled with results of that call to stat. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
if (fsPtr->lstatProc != NULL) {
return fsPtr->lstatProc(pathPtr, buf);
}
if (fsPtr->statProc != NULL) {
return fsPtr->statProc(pathPtr, buf);
}
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSAccess --
*
* Calls 'accessProc' of the filesystem corresponding to pathPtr.
*
* Replaces the library version of access.
*
* Results:
* See access documentation.
*
* Side effects:
* See access documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSAccess(
Tcl_Obj *pathPtr, /* Pathname of file to access (in current CP). */
int mode) /* Permission setting. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL && fsPtr->accessProc != NULL) {
return fsPtr->accessProc(pathPtr, mode);
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSOpenFileChannel --
*
* Calls 'openfileChannelProc' of the filesystem corresponding to
* pathPtr.
*
* Results:
* The new channel, or NULL if the named file could not be opened.
*
* Side effects:
* Opens a channel, possibly creating the corresponding the file on the
* filesystem.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_FSOpenFileChannel(
Tcl_Interp *interp, /* Interpreter for error reporting, or NULL */
Tcl_Obj *pathPtr, /* Pathname of file to open. */
const char *modeString, /* A list of POSIX open modes or a string such
* as "rw". */
int permissions) /* What modes to use if opening the file
involves creating it. */
{
const Tcl_Filesystem *fsPtr;
Tcl_Channel retVal = NULL;
if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
/*
* Return the correct error message.
*/
return NULL;
}
fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL && fsPtr->openFileChannelProc != NULL) {
int mode, seekFlag, binary;
/*
* Parse the mode to determine whether to seek at the outset
* and/or set the channel into binary mode.
*/
mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary);
if (mode == -1) {
return NULL;
}
/*
* Open the file.
*/
retVal = fsPtr->openFileChannelProc(interp, pathPtr, mode,
permissions);
if (retVal == NULL) {
return NULL;
}
/*
* Seek and/or set binary mode as determined above.
*/
if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt) 0, SEEK_END)
< (Tcl_WideInt) 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not seek to end of file while opening \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
}
Tcl_Close(NULL, retVal);
return NULL;
}
if (binary) {
Tcl_SetChannelOption(interp, retVal, "-translation", "binary");
}
return retVal;
}
/*
* File doesn't belong to any filesystem that can open it.
*/
Tcl_SetErrno(ENOENT);
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSUtime --
*
* Calls 'uTimeProc' of the filesystem corresponding to the given
* pathname.
*
* Replaces the library version of utime.
*
* Results:
* See utime documentation.
*
* Side effects:
* See utime documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSUtime(
Tcl_Obj *pathPtr, /* Pathaname of file to call uTimeProc on */
struct utimbuf *tval) /* Specifies the access/modification
* times to use. Should not be modified. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL && fsPtr->utimeProc != NULL) {
return fsPtr->utimeProc(pathPtr, tval);
}
/* TODO: set errno here? Tcl_SetErrno(ENOENT); */
return -1;
}
/*
*----------------------------------------------------------------------
*
* NativeFileAttrStrings --
*
* Implements the platform-dependent 'file attributes' subcommand for the
* native filesystem, for listing the set of possible attribute strings.
* Part of Tcl's native filesystem support. Placed here because it is used
* under both Unix and Windows.
*
* Results:
* An array of strings
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static const char *const *
NativeFileAttrStrings(
TCL_UNUSED(Tcl_Obj *),
TCL_UNUSED(Tcl_Obj **))
{
return tclpFileAttrStrings;
}
/*
*----------------------------------------------------------------------
*
* NativeFileAttrsGet --
*
* Implements the platform-dependent 'file attributes' subcommand for the
* native filesystem for 'get' operations. Part of Tcl's native
* filesystem support. Defined here because it is used under both Unix
* and Windows.
*
* Results:
* Standard Tcl return code.
*
* If there was no error, stores in objPtrRef a pointer to a new object
* having a refCount of zero and holding the result. The caller should
* store it somewhere, e.g. as the Tcl result, or decrement its refCount
* to free it.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
NativeFileAttrsGet(
Tcl_Interp *interp, /* The interpreter for error reporting. */
int index, /* index of the attribute command. */
Tcl_Obj *pathPtr, /* Pathname of the file */
Tcl_Obj **objPtrRef) /* Where to store the a pointer to the result. */
{
return tclpFileAttrProcs[index].getProc(interp, index, pathPtr,objPtrRef);
}
/*
*----------------------------------------------------------------------
*
* NativeFileAttrsSet --
*
* Implements the platform-dependent 'file attributes' subcommand for the
* native filesystem for 'set' operations. A part of Tcl's native
* filesystem support, it is defined here because it is used under both
* Unix and Windows.
*
* Results:
* A standard Tcl return code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
NativeFileAttrsSet(
Tcl_Interp *interp, /* The interpreter for error reporting. */
int index, /* index of the attribute command. */
Tcl_Obj *pathPtr, /* Pathname of the file */
Tcl_Obj *objPtr) /* The value to set. */
{
return tclpFileAttrProcs[index].setProc(interp, index, pathPtr, objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSFileAttrStrings --
*
* Implements part of the hookable 'file attributes'
* subcommand.
*
* Calls 'fileAttrStringsProc' of the filesystem corresponding to the
* given pathname.
*
* Results:
* Returns an array of strings, or returns NULL and stores in objPtrRef
* a pointer to a new Tcl list having a refCount of zero, and containing
* the file attribute strings.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
|
| ︙ | ︙ | |||
2486 2487 2488 2489 2490 2491 2492 | } /* *---------------------------------------------------------------------- * * TclFSFileAttrIndex -- * | | | > > | < | | | 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 |
}
/*
*----------------------------------------------------------------------
*
* TclFSFileAttrIndex --
*
* Given an attribute name, determines the index of the attribute in the
* attribute table.
*
* Results:
* A standard Tcl result code.
*
* If there is no error, stores the index in *indexPtr.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclFSFileAttrIndex(
Tcl_Obj *pathPtr, /* Pathname of the file. */
const char *attributeName, /* The name of the attribute. */
int *indexPtr) /* A place to store the result. */
{
Tcl_Obj *listObj = NULL;
const char *const *attrTable;
/*
* Get the attribute table for the file.
*/
|
| ︙ | ︙ | |||
2563 2564 2565 2566 2567 2568 2569 | } /* *---------------------------------------------------------------------- * * Tcl_FSFileAttrsGet -- * | | > | | | > > | < < | | | | | > > | | | | | | | | | | | | < | < | < < | < < < | | < < < > > | | | > | 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 |
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSFileAttrsGet --
*
* Implements read access for the hookable 'file attributes' subcommand.
*
* Calls 'fileAttrsGetProc' of the filesystem corresponding to the given
* pathname.
*
* Results:
* A standard Tcl return code.
*
* On success, stores in objPtrRef a pointer to a new Tcl_Obj having a
* refCount of zero, and containing the result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSFileAttrsGet(
Tcl_Interp *interp, /* The interpreter for error reporting. */
int index, /* The index of the attribute command. */
Tcl_Obj *pathPtr, /* The pathname of the file. */
Tcl_Obj **objPtrRef) /* A place to store the result. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL && fsPtr->fileAttrsGetProc != NULL) {
return fsPtr->fileAttrsGetProc(interp, index, pathPtr, objPtrRef);
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSFileAttrsSet --
*
* Implements write access for the hookable 'file
* attributes' subcommand.
*
* Calls 'fileAttrsSetProc' for the filesystem corresponding to the given
* pathname.
*
* Results:
* A standard Tcl return code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSFileAttrsSet(
Tcl_Interp *interp, /* The interpreter for error reporting. */
int index, /* The index of the attribute command. */
Tcl_Obj *pathPtr, /* The pathname of the file. */
Tcl_Obj *objPtr) /* A place to store the result. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL && fsPtr->fileAttrsSetProc != NULL) {
return fsPtr->fileAttrsSetProc(interp, index, pathPtr, objPtr);
}
Tcl_SetErrno(ENOENT);
return -1;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSGetCwd --
*
* Replaces the library version of getcwd().
*
* Most virtual filesystems do not implement cwdProc. Tcl maintains its
* own record of the current directory which it keeps synchronized with
* the filesystem corresponding to the pathname of the current directory
* if the filesystem provides a cwdProc (the native filesystem does).
*
* If Tcl's current directory is not in the native filesystem, Tcl's
* current directory and the current directory of the process are
* different. To avoid confusion, extensions should call Tcl_FSGetCwd to
* obtain the current directory from Tcl rather than from the operating
* system.
*
* Results:
* Returns a pointer to a Tcl_Obj having a refCount of 1 and containing
* the current thread's local copy of the global cwdPathPtr value.
*
* Returns NULL if the current directory could not be determined, and
* leaves an error message in the interpreter's result.
*
* Side effects:
* Various objects may be freed and allocated.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSGetCwd(
Tcl_Interp *interp)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey);
if (TclFSCwdPointerEquals(NULL)) {
FilesystemRecord *fsRecPtr;
Tcl_Obj *retVal = NULL;
/*
* This is the first time this routine has been called. Call
* 'getCwdProc' for each registered filsystems until one returns
* something other than NULL, which is a pointer to the pathname of the
* current directory.
*/
fsRecPtr = FsGetFirstFilesystem();
Claim();
for (; (retVal == NULL) && (fsRecPtr != NULL);
fsRecPtr = fsRecPtr->nextPtr) {
ClientData retCd;
|
| ︙ | ︙ | |||
2706 2707 2708 2709 2710 2711 2712 |
proc2 = (TclFSGetCwdProc2 *) fsRecPtr->fsPtr->getCwdProc;
retCd = proc2(NULL);
if (retCd != NULL) {
Tcl_Obj *norm;
/*
| | | | | | < < | > | > > | | > | < < | < | < | | > | | | < | | > > > > > | | | | > > | | < | < < < | < < | 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 |
proc2 = (TclFSGetCwdProc2 *) fsRecPtr->fsPtr->getCwdProc;
retCd = proc2(NULL);
if (retCd != NULL) {
Tcl_Obj *norm;
/*
* Found the pathname of the current directory.
*/
retVal = fsRecPtr->fsPtr->internalToNormalizedProc(retCd);
Tcl_IncrRefCount(retVal);
norm = TclFSNormalizeAbsolutePath(interp,retVal);
if (norm != NULL) {
/*
* Assign to global storage the pathname of the current directory
* and copy it into thread-local storage as well.
*
* At system startup multiple threads could in principle
* call this function simultaneously, which is a little
* peculiar, but should be fine given the mutex locks in
* FSUPdateCWD. Once some value is assigned to the global
* variable the 'else' branch below is always taken, which
* is simpler.
*/
FsUpdateCwd(norm, retCd);
Tcl_DecrRefCount(norm);
} else {
fsRecPtr->fsPtr->freeInternalRepProc(retCd);
}
Tcl_DecrRefCount(retVal);
retVal = NULL;
Disclaim();
goto cdDidNotChange;
} else if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error getting working directory name: %s",
Tcl_PosixError(interp)));
}
}
Disclaim();
if (retVal != NULL) {
/*
* On some platforms the pathname of the current directory might
* not be normalized. For efficiency, ensure that it is
* normalized. For the sake of efficiency, we want a completely
* normalized current working directory at all times.
*/
Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal);
if (norm != NULL) {
/*
* We found a current working directory, which is now in our
* global storage. We must make a copy. Norm already has a
* refCount of 1.
*
* 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.
*/
ClientData cd = (ClientData) Tcl_FSGetNativePath(norm);
FsUpdateCwd(norm, TclNativeDupInternalRep(cd));
Tcl_DecrRefCount(norm);
}
Tcl_DecrRefCount(retVal);
} else {
/*
* retVal is NULL. There is no current directory, which could be
* problematic.
*/
}
} else {
/*
* There is a thread-local value for the pathname of the current
* directory. Give corresponding filesystem a chance update the value
* if it is out-of-date. This allows an error to be thrown if, for
* example, the permissions on the current working directory have
* changed.
*/
const Tcl_Filesystem *fsPtr =
Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr);
ClientData retCd = NULL;
Tcl_Obj *retVal, *norm;
if (fsPtr == NULL || fsPtr->getCwdProc == NULL) {
/*
* There is no corresponding filesystem or the filesystem does not
* have a getCwd routine. Just assume current local value is ok.
*/
goto cdDidNotChange;
}
if (fsPtr->version == TCL_FILESYSTEM_VERSION_1) {
retVal = fsPtr->getCwdProc(interp);
} else {
/*
|
| ︙ | ︙ | |||
2828 2829 2830 2831 2832 2833 2834 | * Looks like a new current directory. */ retVal = fsPtr->internalToNormalizedProc(retCd); Tcl_IncrRefCount(retVal); } | > | | > > | | < < < < < > | < | | < | > | | | | | | | | < < > > > > | | | | < | > > > | 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 |
* Looks like a new current directory.
*/
retVal = fsPtr->internalToNormalizedProc(retCd);
Tcl_IncrRefCount(retVal);
}
if (retVal == NULL) {
/*
* The current directory could not not determined. Reset the
* current direcory to ensure, for example, that 'pwd' does actually
* throw the correct error in Tcl. This is tested for in the test
* suite on unix.
*/
FsUpdateCwd(NULL, NULL);
goto cdDidNotChange;
}
norm = TclFSNormalizeAbsolutePath(interp, retVal);
if (norm == NULL) {
/*
* 'norm' shouldn't ever be NULL, but we are careful.
*/
/* Do nothing */
if (retCd != NULL) {
fsPtr->freeInternalRepProc(retCd);
}
} else if (norm == tsdPtr->cwdPathPtr) {
goto cdEqual;
} else {
/*
* Determine whether the filesystem's answer is the same as the
* cached local value. Since both 'norm' and 'tsdPtr->cwdPathPtr'
* are normalized pathnames, do something more efficient than
* calling 'Tcl_FSEqualPaths', and in addition avoid a nasty
* infinite loop bug when trying to normalize tsdPtr->cwdPathPtr.
*/
int len1, len2;
const char *str1, *str2;
str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1);
str2 = TclGetStringFromObj(norm, &len2);
if ((len1 == len2) && (strcmp(str1, str2) == 0)) {
/*
* The pathname values are equal so retain the old pathname
* object which is probably already shared and free the
* normalized pathname that was just produced.
*/
cdEqual:
Tcl_DecrRefCount(norm);
if (retCd != NULL) {
fsPtr->freeInternalRepProc(retCd);
}
} else {
/*
* The pathname of the current directory is not the same as
* this thread's local cached value. Replace the local value.
*/
FsUpdateCwd(norm, retCd);
Tcl_DecrRefCount(norm);
}
}
Tcl_DecrRefCount(retVal);
}
cdDidNotChange:
if (tsdPtr->cwdPathPtr != NULL) {
Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
}
return tsdPtr->cwdPathPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSChdir --
*
* Replaces the library version of chdir().
*
* Calls 'chdirProc' of the filesystem that corresponds to the given
* pathname.
*
* Results:
* See chdir() documentation.
*
* Side effects:
* See chdir() documentation.
*
* On success stores in cwdPathPtr the pathname of the new current
* directory.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSChdir(
Tcl_Obj *pathPtr)
|
| ︙ | ︙ | |||
2938 2939 2940 2941 2942 2943 2944 |
return retVal;
}
fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
if (fsPtr->chdirProc != NULL) {
/*
| < | | < < < < < < < | > > > > > > | < < | < | | < < < < < < < < < < < < < < < < < < < | > | < | | < < < < < < < < < < < < < < < > | > > > > > > > > > > > > > > > > > > > > > > > > | | > | | < > > > > > | | | < < < < < < < < | | | | | | | | | | | | | < < < < < < < < < < < | | | < > | | < | | | > | | | | | | | | | < < < < < < < < < | < | > | | < < < > < < > > | > > > > > | > > > | | | | | | | | | | < | | | < | | > > | | | | | | | < | | > > > > | | < < < < | | | < | | < < < < | | < | | | < | | | | < < | < < | | | | | < | | | < | | | > | | | | | < < < | > | | < | < | < | | | | < | | | > | | < | | < < | | | | | | | | | | > > > | | < < < | | | < | | | < < | > < | | | < > | | < | < < > | < | | | | < < | | | > > | | < | | < < | | | | | | | | > | | < | | < | < | | | | | > | > > | | | > > | | | | < | | < < | < < < < < | | < | > > > > < | | | | | | | < < | 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 |
return retVal;
}
fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL) {
if (fsPtr->chdirProc != NULL) {
/*
* If this fails Tcl_SetErrno() has already been called.
*/
retVal = fsPtr->chdirProc(pathPtr);
} else {
/*
* Fallback to stat-based implementation.
*/
Tcl_StatBuf buf;
if ((Tcl_FSStat(pathPtr, &buf) == 0) && (S_ISDIR(buf.st_mode))
&& (Tcl_FSAccess(pathPtr, R_OK) == 0)) {
/*
* stat was successful, and the file is a directory and is
* readable. Can proceed to change the current directory.
*/
retVal = 0;
} else {
/*
* 'Tcl_SetErrno()' has already been called.
*/
}
}
} else {
Tcl_SetErrno(ENOENT);
}
if (retVal == 0) {
/* Assume that the cwd was actually changed to the normalized value
* just calculated, and cache that information. */
/*
* If the filesystem epoch changed recently, the normalized pathname or
* its internal handle may be different from what was found above.
* This can easily be the case with scripted documents . Therefore get
* the normalized pathname again. The correct value will have been
* cached as a result of the Tcl_FSGetFileSystemForPath call, above.
*/
Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normDirName == NULL) {
/* Not really true, but what else to do? */
Tcl_SetErrno(ENOENT);
return -1;
}
if (fsPtr == &tclNativeFilesystem) {
ClientData cd;
ClientData oldcd = tsdPtr->cwdClientData;
/*
* Assume that the native filesystem has a getCwdProc and that it
* is at version 2.
*/
TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2 *) fsPtr->getCwdProc;
cd = proc2(oldcd);
if (cd != oldcd) {
/*
* Call getCwdProc() and store the resulting internal handle to
* compare things with it later. This might might not be
* exactly the same string as that of the fully normalized
* pathname. For example, for the Windows internal handle the
* separator is the backslash character. On Unix it might well
* be true that the internal handle is the fully normalized
* pathname and one could simply use:
* cd = Tcl_FSGetNativePath(pathPtr);
* but this can't be guaranteed in the general case. In fact,
* the internal handle could be any value the filesystem
* decides to use to identify a node.
*/
FsUpdateCwd(normDirName, cd);
}
} else {
/*
* Tcl_FSGetCwd() synchronizes the file-global cwdPathPtr if
* needed. However, if there is no 'getCwdProc', cwdPathPtr must be
* updated right now because there won't be another chance. This
* block of code is currently executed whether or not the
* filesystem provides a getCwdProc, but it should in principle
* work to only call this block if fsPtr->getCwdProc == NULL.
*/
FsUpdateCwd(normDirName, NULL);
}
if (oldFsPtr != NULL && fsPtr != oldFsPtr) {
/*
* The filesystem of the current directory is not the same as the
* filesystem of the previous current directory. Invalidate All
* FsPath objects.
*/
Tcl_FSMountsChanged(NULL);
}
} else {
/*
* The current directory is now changed or an error occurred and an
* error message is now set. Just continue.
*/
}
return retVal;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSLoadFile --
*
* Loads a dynamic shared object by passing the given pathname unmodified
* to Tcl_LoadFile, and provides pointers to the functions named by 'sym1'
* and 'sym2', and another pointer to a function that unloads the object.
*
* Results:
* A standard Tcl completion code. If an error occurs, sets the
* interpreter's result to an error message.
*
* Side effects:
* A dynamic shared object is loaded into memory. This may later be
* unloaded by passing the handlePtr to *unloadProcPtr.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSLoadFile(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Pathname of the file containing the dynamic shared object.
*/
const char *sym1, const char *sym2,
/* Names of two functions to find in the
* dynamic shared object. */
Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr,
/* Places to store pointers to the functions
* named by sym1 and sym2. */
Tcl_LoadHandle *handlePtr, /* A place to store the token for the loaded
* object. Can be passed to
* (*unloadProcPtr)() to unload the file. */
TCL_UNUSED(Tcl_FSUnloadFileProc **))
{
const char *symbols[3];
void *procPtrs[2];
int res;
symbols[0] = sym1;
symbols[1] = sym2;
symbols[2] = NULL;
res = Tcl_LoadFile(interp, pathPtr, symbols, 0, procPtrs, handlePtr);
if (res == TCL_OK) {
*proc1Ptr = (Tcl_PackageInitProc *) procPtrs[0];
*proc2Ptr = (Tcl_PackageInitProc *) procPtrs[1];
} else {
*proc1Ptr = *proc2Ptr = NULL;
}
return res;
}
/*
*----------------------------------------------------------------------
*
* Tcl_LoadFile --
*
* Load a dynamic shared object by calling 'loadFileProc' of the
* filesystem corresponding to the given pathname, and then finds within
* the loaded object the functions named in symbols[].
*
* The given pathname is passed unmodified to `loadFileProc`, which
* decides how to resolve it. On POSIX systems the native filesystem
* passes the given pathname to dlopen(), which resolves the filename
* according to its own set of rules. This behaviour is not very
* compatible with virtual filesystems, and has other problems as
* documented for [load], so it is recommended to use an absolute
* pathname.
*
* Results:
* A standard Tcl completion code. If an error occurs, sets the
* interpreter result to an error message.
*
* Side effects:
* Memory is allocated for the new object. May be freed by calling
* TclFS_UnloadFile.
*
*----------------------------------------------------------------------
*/
/*
* Modern HPUX allows the unlink (no ETXTBSY error) yet somehow trashes some
* internal data structures, preventing any additional dynamic shared objects
* from getting properly loaded. Only the first is ok. Work around the issue
* by not unlinking, i.e., emulating the behaviour of the older HPUX which
* denied removal.
*
* Doing the unlink is also an issue within docker containers, whose AUFS
* bungles this as well, see
* https://github.com/dotcloud/docker/issues/1911
*
*/
static int
skipUnlink(
Tcl_Obj *shlibFile)
{
/*
* Unlinking is not performed in the following cases:
*
* 1. The operating system is HPUX.
*
* 2. If the environment variable TCL_TEMPLOAD_NO_UNLINK is present and
* set to true (an integer > 0)
*
* 3. TCL_TEMPLOAD_NO_UNLINK is not true (an integer > 0) and AUFS filesystem can be detected (using statfs, if available).
*
*/
#ifdef hpux
(void)shlibFile;
return 1;
#else
char *skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK");
if (skipstr && (skipstr[0] != '\0')) {
return atoi(skipstr);
}
#ifndef TCL_TEMPLOAD_NO_UNLINK
(void)shlibFile;
#else
/* At built time TCL_TEMPLOAD_NO_UNLINK can be set manually to control whether
* this automatic overriding of unlink is included.
*/
#ifndef NO_FSTATFS
{
struct statfs fs;
/*
* Have fstatfs. May not have the AUFS super magic ... Indeed our build
* box is too old to have it directly in the headers. Define taken from
* http://mooon.googlecode.com/svn/trunk/linux_include/linux/aufs_type.h
* http://aufs.sourceforge.net/
* Better reference will be gladly accepted.
*/
#ifndef AUFS_SUPER_MAGIC
/* AUFS_SUPER_MAGIC can disable/override the AUFS detection, i.e. for
* testing if a newer AUFS does not have the bug any more.
*/
#define AUFS_SUPER_MAGIC ('a' << 24 | 'u' << 16 | 'f' << 8 | 's')
#endif /* AUFS_SUPER_MAGIC */
if ((statfs(Tcl_GetString(shlibFile), &fs) == 0)
&& (fs.f_type == AUFS_SUPER_MAGIC)) {
return 1;
}
}
#endif /* ... NO_FSTATFS */
#endif /* ... TCL_TEMPLOAD_NO_UNLINK */
/*
* No HPUX, environment variable override, or AUFS detected. Perform
* unlink.
*/
return 0;
#endif /* hpux */
}
int
Tcl_LoadFile(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Pathname of the file containing the dynamic
* shared object. */
const char *const symbols[],/* A null-terminated array of names of
* functions to find in the loaded object. */
int flags, /* Flags */
void *procVPtrs, /* A place to store pointers to the functions
* named by symbols[]. */
Tcl_LoadHandle *handlePtr) /* A place to hold a token for the loaded object.
* Can be used by TclpFindSymbol. */
{
void **procPtrs = (void **) procVPtrs;
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
const Tcl_Filesystem *copyFsPtr;
Tcl_FSUnloadFileProc *unloadProcPtr;
Tcl_Obj *copyToPtr;
Tcl_LoadHandle newLoadHandle = NULL;
Tcl_LoadHandle divertedLoadHandle = NULL;
Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL;
FsDivertLoad *tvdlPtr;
int retVal;
int i;
if (fsPtr == NULL) {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
if (fsPtr->loadFileProc != NULL) {
int retVal = ((Tcl_FSLoadFileProc2 *)(void *)(fsPtr->loadFileProc))
(interp, pathPtr, handlePtr, &unloadProcPtr, flags);
if (retVal == TCL_OK) {
if (*handlePtr == NULL) {
return TCL_ERROR;
}
if (interp) {
Tcl_ResetResult(interp);
}
goto resolveSymbols;
}
if (Tcl_GetErrno() != EXDEV) {
return retVal;
}
}
/*
* The filesystem doesn't support 'load'. Fall to the following:
*/
/*
* Make sure the file is accessible.
*/
if (Tcl_FSAccess(pathPtr, R_OK) != 0) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load library \"%s\": %s",
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
#ifdef TCL_LOAD_FROM_MEMORY
/*
* The platform supports loading a dynamic shared object from memory.
* Create a sufficiently large buffer, read the file into it, and then load
* the dynamic shared object from the buffer:
*/
{
int ret, size;
void *buffer;
Tcl_StatBuf statBuf;
Tcl_Channel data;
ret = Tcl_FSStat(pathPtr, &statBuf);
if (ret < 0) {
goto mustCopyToTempAnyway;
}
size = (int) statBuf.st_size;
/*
* Tcl_Read takes an int: Determine whether the file size is wide.
*/
if (size != (Tcl_WideInt) statBuf.st_size) {
goto mustCopyToTempAnyway;
}
data = Tcl_FSOpenFileChannel(interp, pathPtr, "rb", 0666);
if (!data) {
goto mustCopyToTempAnyway;
}
buffer = TclpLoadMemoryGetBuffer(interp, size);
if (!buffer) {
Tcl_Close(interp, data);
goto mustCopyToTempAnyway;
}
ret = Tcl_Read(data, (char *)buffer, size);
Tcl_Close(interp, data);
ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr,
&unloadProcPtr, flags);
if (ret == TCL_OK && *handlePtr != NULL) {
goto resolveSymbols;
}
}
mustCopyToTempAnyway:
if (interp) {
Tcl_ResetResult(interp);
}
#endif /* TCL_LOAD_FROM_MEMORY */
/*
* Get a temporary filename, first to copy the file into, and then to load.
*/
copyToPtr = TclpTempFileNameForLibrary(interp, pathPtr);
if (copyToPtr == NULL) {
return TCL_ERROR;
}
Tcl_IncrRefCount(copyToPtr);
copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr);
if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) {
/*
* Tcl_FSLoadFile isn't available for the filesystem of the temporary
* file. In order to avoid a possible infinite loop, do not attempt to
* load further.
*/
/*
* Try to delete the file we probably created and then exit.
*/
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"couldn't load from current filesystem", -1));
}
return TCL_ERROR;
}
if (TclCrossFilesystemCopy(interp, pathPtr, copyToPtr) != TCL_OK) {
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
return TCL_ERROR;
}
#ifndef _WIN32
/*
* It might be necessary on some systems to set the appropriate permissions
* on the file. On Unix we could loop over the file attributes and set any
* that are called "-permissions" to 0700, but just do it directly instead:
*/
{
int index;
Tcl_Obj *perm;
TclNewLiteralStringObj(perm, "0700");
Tcl_IncrRefCount(perm);
if (TclFSFileAttrIndex(copyToPtr, "-permissions", &index) == TCL_OK) {
Tcl_FSFileAttrsSet(NULL, index, copyToPtr, perm);
}
Tcl_DecrRefCount(perm);
}
#endif
/*
* The cross-filesystem copy may have stored the number of bytes in the
* result, so reset the result now.
*/
if (interp) {
Tcl_ResetResult(interp);
}
retVal = Tcl_LoadFile(interp, copyToPtr, symbols, flags, procPtrs,
&newLoadHandle);
if (retVal != TCL_OK) {
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
return retVal;
}
/*
* Try to delete the file immediately. Some operatings systems allow this,
* and it avoids leaving the copy laying around after exit.
*/
if (!skipUnlink(copyToPtr) &&
(Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) {
Tcl_DecrRefCount(copyToPtr);
/*
* Tell the caller all the details: The package list maintained by
* 'load' stores the original (vfs) pathname, the handle of object
* loaded from the temporary file, and the unloadProcPtr.
*/
*handlePtr = newLoadHandle;
if (interp) {
Tcl_ResetResult(interp);
}
return TCL_OK;
}
/*
* Divert the unloading in order to unload and cleanup the temporary file.
*/
tvdlPtr = (FsDivertLoad *)ckalloc(sizeof(FsDivertLoad));
/*
* Remember three pieces of information in order to clean up the diverted
* load completely on platforms which allow proper unloading of code.
*/
tvdlPtr->loadHandle = newLoadHandle;
tvdlPtr->unloadProcPtr = newUnloadProcPtr;
if (copyFsPtr != &tclNativeFilesystem) {
/* refCount of copyToPtr is already incremented. */
tvdlPtr->divertedFile = copyToPtr;
/*
* This is the filesystem for the temporary file the object was loaded
* from. A reference to copyToPtr is already stored in
* tvdlPtr->divertedFile, so need need to increment the refCount again.
*/
tvdlPtr->divertedFilesystem = copyFsPtr;
tvdlPtr->divertedFileNativeRep = NULL;
} else {
/*
* Grab the native representation.
*/
tvdlPtr->divertedFileNativeRep = TclNativeDupInternalRep(
Tcl_FSGetInternalRep(copyToPtr, copyFsPtr));
/*
* Don't keeep a reference to the Tcl_Obj or the native filesystem.
*/
tvdlPtr->divertedFile = NULL;
tvdlPtr->divertedFilesystem = NULL;
Tcl_DecrRefCount(copyToPtr);
}
copyToPtr = NULL;
divertedLoadHandle = (Tcl_LoadHandle)ckalloc(sizeof(struct Tcl_LoadHandle_));
divertedLoadHandle->clientData = tvdlPtr;
divertedLoadHandle->findSymbolProcPtr = DivertFindSymbol;
divertedLoadHandle->unloadFileProcPtr = DivertUnloadFile;
*handlePtr = divertedLoadHandle;
if (interp) {
Tcl_ResetResult(interp);
}
return retVal;
resolveSymbols:
/*
* handlePtr now contains a token for the loaded object.
* Resolve the symbols.
*/
if (symbols != NULL) {
for (i=0 ; symbols[i] != NULL; i++) {
procPtrs[i] = Tcl_FindSymbol(interp, *handlePtr, symbols[i]);
if (procPtrs[i] == NULL) {
/*
* At least one symbol in the list was not found. Unload the
* file and return an error code. Tcl_FindSymbol should have
* already left an appropriate error message.
*/
(*handlePtr)->unloadFileProcPtr(*handlePtr);
*handlePtr = NULL;
return TCL_ERROR;
}
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* DivertFindSymbol --
*
* Find a symbol in a shared library loaded by making a copying a file
* from the virtual filesystem to a native filesystem.
*
*----------------------------------------------------------------------
*/
static void *
DivertFindSymbol(
Tcl_Interp *interp, /* The relevant interpreter. */
Tcl_LoadHandle loadHandle, /* A handle to the diverted module. */
const char *symbol) /* The name of symbol to resolve. */
{
FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle->clientData;
Tcl_LoadHandle originalHandle = tvdlPtr->loadHandle;
return originalHandle->findSymbolProcPtr(interp, originalHandle, symbol);
}
/*
*----------------------------------------------------------------------
*
* DivertUnloadFile --
*
* Unloads an object that was loaded from a temporary file copied from the
* virtual filesystem the native filesystem.
*
*----------------------------------------------------------------------
*/
static void
DivertUnloadFile(
Tcl_LoadHandle loadHandle) /* A handle for the loaded object. */
{
FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle->clientData;
Tcl_LoadHandle originalHandle;
if (tvdlPtr == NULL) {
/*
* tvdlPtr was provided by Tcl_LoadFile so it should not be NULL here.
*/
return;
}
originalHandle = tvdlPtr->loadHandle;
/*
* Call the real 'unloadfile' proc. This must be called first so that the
* shared library is actually unloaded by the OS. Otherwise, the following
* 'delete' may fail because the shared library is still in use.
*/
originalHandle->unloadFileProcPtr(originalHandle);
/*
* Determine which filesystem contains the temporary copy of the file.
*/
if (tvdlPtr->divertedFilesystem == NULL) {
/*
* Use the function for the native filsystem, which works works even at
* this late stage.
*/
TclpDeleteFile(tvdlPtr->divertedFileNativeRep);
NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep);
} else {
/*
* Remove the temporary file. If encodings have been cleaned up
* already, this may crash.
*/
if (tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile)
!= TCL_OK) {
/*
* This may have happened because Tcl is exiting, and encodings may
* have already been deleted or something else the filesystem
* depends on may be gone.
*
* TO DO: Figure out how to delete this file more robustly, or
* give the filesystem the information it needs to delete the file
* more robustly. One problem might be that the filesystem cannot
* extract the information it needs from the above pathname object
* because Tcl's entire filesystem apparatus (the code in this
* file) has been finalized and there is no way to get the native
* handle of the file.
*/
}
/*
* This also decrements the refCount of the Tcl_Filesystem
* corresponding to this file. which might cause the filesystem to be
* deallocated if Tcl is exiting.
*/
Tcl_DecrRefCount(tvdlPtr->divertedFile);
}
ckfree(tvdlPtr);
ckfree(loadHandle);
}
/*
*----------------------------------------------------------------------
*
* Tcl_FindSymbol --
*
* Find a symbol in a loaded object.
*
* Previously filesystem-specific, but has been made portable by having
* TclpDlopen return a structure that includes procedure pointers.
*
* Results:
* Returns a pointer to the symbol if found. Otherwise, sets
* an error message in the interpreter result and returns NULL.
*
*----------------------------------------------------------------------
*/
void *
Tcl_FindSymbol(
Tcl_Interp *interp, /* The relevant interpreter. */
Tcl_LoadHandle loadHandle, /* A handle for the loaded object. */
const char *symbol) /* The name name of the symbol to resolve. */
{
return loadHandle->findSymbolProcPtr(interp, loadHandle, symbol);
}
/*
*----------------------------------------------------------------------
*
* Tcl_FSUnloadFile --
*
* Unloads a loaded object if unloading is supported for the object.
*
*----------------------------------------------------------------------
*/
int
Tcl_FSUnloadFile(
Tcl_Interp *interp, /* The relevant interpreter. */
Tcl_LoadHandle handle) /* A handle for the object to unload. */
{
if (handle->unloadFileProcPtr == NULL) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"cannot unload: filesystem does not support unloading",
-1));
}
return TCL_ERROR;
}
if (handle->unloadFileProcPtr != NULL) {
handle->unloadFileProcPtr(handle);
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclFSUnloadTempFile --
*
* Unloads an object loaded via temporary file from a virtual filesystem
* to a native filesystem.
*
* Results:
* None.
*
* Side effects:
* Frees resources for the loaded object and deletes the temporary file.
*
*----------------------------------------------------------------------
*/
void
TclFSUnloadTempFile(
Tcl_LoadHandle loadHandle) /* A handle for the object, as provided by a
* previous call to Tcl_FSLoadFile(). */
{
FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle;
if (tvdlPtr == NULL) {
/*
* tvdlPtr was provided by Tcl_LoadFile so it should not be NULL here.
*/
return;
}
if (tvdlPtr->unloadProcPtr != NULL) {
/*
* 'unloadProcPtr' must be called first so that the shared library is
* actually unloaded by the OS. Otherwise, the following 'delete' may
* well fail because the shared library is still in use.
*/
tvdlPtr->unloadProcPtr(tvdlPtr->loadHandle);
}
if (tvdlPtr->divertedFilesystem == NULL) {
/*
* Call the function for the native fileystem, which works even at this
* late stage.
*/
TclpDeleteFile(tvdlPtr->divertedFileNativeRep);
NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep);
} else {
/*
* Remove the temporary file that was created. If encodings have
* already been freed because the interpreter is exiting this may
* crash.
*/
if (tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile)
!= TCL_OK) {
/*
* This may have happened because Tcl is exiting and encodings may
* have already been deleted, or something else the filesystem
* depends on may be gone.
*
* TO DO: Figure out how to delete this file more robustly, or
* give the filesystem the information it needs to delete the file
* more robustly. One problem might be that the filesystem cannot
* extract the information it needs from the above pathname object
* because Tcl's entire filesystem apparatus (the code in this
* file) has been finalized and there is no way to get the native
* handle of the file.
*/
}
/*
* This also decrements the refCount of the Tcl_Filesystem
* corresponding to this file. which might case filesystem to be freed
* if Tcl is exiting.
*/
Tcl_DecrRefCount(tvdlPtr->divertedFile);
}
ckfree(tvdlPtr);
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSLink --
*
* Creates or inspects a link by calling 'linkProc' of the filesystem
* corresponding to the given pathname. Replaces the library version of
* readlink().
*
* Results:
* If toPtr is NULL, a Tcl_Obj containing the value the symbolic link for
* 'pathPtr', or NULL if a symbolic link was not accessible. The caller
* should Tcl_DecrRefCount on the result to release it. Otherwise NULL.
*
* In this case the result has no additional reference count and need not
* be freed. The actual action to perform is given by the 'linkAction'
* flags, which is a combination of:
*
* TCL_CREATE_SYMBOLIC_LINK
* TCL_CREATE_HARD_LINK
*
* Most filesystems do not support linking across to different
* filesystems, so this function usually fails if the filesystem
* corresponding to toPtr is not the same as the filesystem corresponding
* to pathPtr.
*
* Side effects:
* Creates or sets a link if toPtr is not NULL.
*
* See readlink().
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSLink(
Tcl_Obj *pathPtr, /* Pathaname of file. */
Tcl_Obj *toPtr, /*
* NULL or the pathname of a file to link to.
*/
int linkAction) /* Action to perform. */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr != NULL && fsPtr->linkProc != NULL) {
return fsPtr->linkProc(pathPtr, toPtr, linkAction);
}
/*
* If S_IFLNK isn't defined the machine doesn't support symbolic links, so
* the file can't possibly be a symbolic link. Generate an EINVAL error,
* which is what happens on machines that do support symbolic links when
* readlink is called for a file that isn't a symbolic link.
*/
#ifndef S_IFLNK
errno = EINVAL; /* TODO: Change to Tcl_SetErrno()? */
#else
Tcl_SetErrno(ENOENT);
#endif /* S_IFLNK */
return NULL;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSListVolumes --
*
* Lists the currently mounted volumes by calling `listVolumesProc` of
* each registered filesystem, and combining the results to form a list of
* volumes.
*
* Results:
* The list of volumes, in an object which has refCount 0.
*
* Side effects:
* None
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSListVolumes(void)
{
FilesystemRecord *fsRecPtr;
Tcl_Obj *resultPtr = Tcl_NewObj();
/*
* Call each "listVolumes" function of each registered filesystem in
* succession. A non-NULL return value indicates the particular function
* has succeeded.
*/
fsRecPtr = FsGetFirstFilesystem();
Claim();
while (fsRecPtr != NULL) {
if (fsRecPtr->fsPtr->listVolumesProc != NULL) {
Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc();
if (thisFsVolumes != NULL) {
Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes);
/* The refCount of each list returned by a `listVolumesProc` is
* already incremented. Do not hang onto the list, though. It
* belongs to the filesystem. Add its contents to * the result
* we are building, and then decrement the refCount. */
Tcl_DecrRefCount(thisFsVolumes);
}
}
fsRecPtr = fsRecPtr->nextPtr;
}
Disclaim();
return resultPtr;
}
/*
*---------------------------------------------------------------------------
*
* FsListMounts --
*
* Lists the mounts mathing the given pattern in the given directory.
*
* Results:
* A list, having a refCount of 0, of the matching mounts, or NULL if no
* search was performed because no filesystem provided a search routine.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static Tcl_Obj *
FsListMounts(
Tcl_Obj *pathPtr, /* Pathname of directory to search. */
const char *pattern) /* Pattern to match against. */
{
FilesystemRecord *fsRecPtr;
Tcl_GlobTypeData mountsOnly = { TCL_GLOB_TYPE_MOUNT, 0, NULL, NULL };
Tcl_Obj *resultPtr = NULL;
/*
* Call the matchInDirectory function of each registered filesystem,
* passing it 'mountsOnly'. Results accumulate in resultPtr.
*/
fsRecPtr = FsGetFirstFilesystem();
Claim();
while (fsRecPtr != NULL) {
if (fsRecPtr->fsPtr != &tclNativeFilesystem &&
fsRecPtr->fsPtr->matchInDirectoryProc != NULL) {
|
| ︙ | ︙ | |||
3982 3983 3984 3985 3986 3987 3988 | } /* *--------------------------------------------------------------------------- * * Tcl_FSSplitPath -- * | | < < | < < < > | > | | | < | < | | | | | | | 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 |
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSSplitPath --
*
* Splits a pathname into its components.
*
* Results:
* A list with refCount of zero.
*
* Side effects:
* If lenPtr is not null, sets it to the number of elements in the result.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSSplitPath(
Tcl_Obj *pathPtr, /* The pathname to split. */
int *lenPtr) /* A place to hold the number of pathname
* elements. */
{
Tcl_Obj *result = NULL; /* Just to squelch gcc warnings. */
const Tcl_Filesystem *fsPtr;
char separator = '/';
int driveNameLength;
const char *p;
/*
* Perform platform-specific splitting.
*/
if (TclFSGetPathType(pathPtr, &fsPtr,
&driveNameLength) == TCL_PATH_ABSOLUTE) {
if (fsPtr == &tclNativeFilesystem) {
return TclpNativeSplitPath(pathPtr, lenPtr);
}
} else {
return TclpNativeSplitPath(pathPtr, lenPtr);
}
/* Assume each separator is a single character. */
if (fsPtr->filesystemSeparatorProc != NULL) {
Tcl_Obj *sep = fsPtr->filesystemSeparatorProc(pathPtr);
if (sep != NULL) {
Tcl_IncrRefCount(sep);
separator = Tcl_GetString(sep)[0];
Tcl_DecrRefCount(sep);
}
}
/*
* 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.
*/
result = Tcl_NewObj();
p = Tcl_GetString(pathPtr);
Tcl_ListObjAppendElement(NULL, result,
Tcl_NewStringObj(p, driveNameLength));
p += driveNameLength;
/*
* Add the remaining pathname elements to the list.
*/
for (;;) {
const char *elementStart = p;
int length;
while ((*p != '\0') && (*p != separator)) {
|
| ︙ | ︙ | |||
4075 4076 4077 4078 4079 4080 4081 |
Tcl_ListObjAppendElement(NULL, result, nextElt);
}
if (*p++ == '\0') {
break;
}
}
| < < < < | | | < < < > | | | | | | < | < < > | | | | 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 |
Tcl_ListObjAppendElement(NULL, result, nextElt);
}
if (*p++ == '\0') {
break;
}
}
if (lenPtr != NULL) {
TclListObjLength(NULL, result, lenPtr);
}
return result;
}
/*
*----------------------------------------------------------------------
*
* TclGetPathType --
*
* Helper function used by TclFSGetPathType and TclJoinPath.
*
* Results:
* One of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
* TCL_PATH_VOLUME_RELATIVE.
*
* Side effects:
* See **filesystemPtrptr, *driveNameLengthPtr and **driveNameRef,
*
*----------------------------------------------------------------------
*/
Tcl_PathType
TclGetPathType(
Tcl_Obj *pathPtr, /* Pathname to determine type of. */
const Tcl_Filesystem **filesystemPtrPtr,
/* If not NULL, a place in which to store a
* pointer to the filesystem for this pathname
* if it is absolute. */
int *driveNameLengthPtr, /* If not NULL, a place in which to store the
* length of the volume name. */
Tcl_Obj **driveNameRef) /* If not NULL, for an absolute pathname, a
* place to store a pointer to an object with a
* refCount of 1, and whose value is the name
* of the volume. */
{
int pathLen;
const char *path = TclGetStringFromObj(pathPtr, &pathLen);
Tcl_PathType type;
type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr,
driveNameLengthPtr, driveNameRef);
if (type != TCL_PATH_ABSOLUTE) {
|
| ︙ | ︙ | |||
4141 4142 4143 4144 4145 4146 4147 | } /* *---------------------------------------------------------------------- * * TclFSNonnativePathType -- * | | | | | | | | | | | | | | | | > | | < < < | | | | | < | | | | | | | < | | | | < | | | | | | | | | | > | | | < | 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 |
}
/*
*----------------------------------------------------------------------
*
* TclFSNonnativePathType --
*
* Helper function used by TclGetPathType. Checks whether the given
* pathname starts with a string which corresponds to a file volume in
* some registered filesystem other than the native one. For speed and
* historical reasons the native filesystem has special hard-coded checks
* dotted here and there in the filesystem code.
*
* Results:
* One of TCL_PATH_ABSOLUTE or TCL_PATH_RELATIVE. The filesystem
* reference will be set if and only if it is non-NULL and the function's
* return value is TCL_PATH_ABSOLUTE.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_PathType
TclFSNonnativePathType(
const char *path, /* Pathname to determine the type of. */
int pathLen, /* Length of the pathname. */
const Tcl_Filesystem **filesystemPtrPtr,
/* If not NULL, a place to store a pointer to
* the filesystem for this pathname when it is
* an absolute pathname. */
int *driveNameLengthPtr, /* If not NULL, a place to store the length of
* the volume name if the pathname is absolute.
*/
Tcl_Obj **driveNameRef) /* If not NULL, a place to store a pointer to
* an object having its its refCount already
* incremented, and contining the name of the
* volume if the pathname is absolute. */
{
FilesystemRecord *fsRecPtr;
Tcl_PathType type = TCL_PATH_RELATIVE;
/*
* Determine whether the given pathname is an absolute pathname on some
* filesystem other than the native filesystem.
*/
fsRecPtr = FsGetFirstFilesystem();
Claim();
while (fsRecPtr != NULL) {
/*
* Skip the the native filesystem because otherwise some of the tests
* in the Tcl testsuite might fail because some of the tests
* artificially change the current platform (between win, unix) but the
* list of volumes obtained by calling fsRecPtr->fsPtr->listVolumesProc
* reflects the current (real) platform only. In particular, on Unix
* '/' matchs the beginning of certain absolute Windows pathnames
* starting '//' and those tests go wrong.
*
* There is another reason to skip the native filesystem: Since the
* tclFilename.c code has nice fast 'absolute path' checkers, there is
* no reason to waste time doing that in this frequently-called
* function. It is better to save the overhead of the native
* filesystem continuously returning a list of volumes.
*/
if ((fsRecPtr->fsPtr != &tclNativeFilesystem)
&& (fsRecPtr->fsPtr->listVolumesProc != NULL)) {
int numVolumes;
Tcl_Obj *thisFsVolumes = fsRecPtr->fsPtr->listVolumesProc();
if (thisFsVolumes != NULL) {
if (Tcl_ListObjLength(NULL, thisFsVolumes, &numVolumes)
!= TCL_OK) {
/*
* This is VERY bad; the listVolumesProc didn't return a
* valid list. Set numVolumes to -1 to skip the loop below
* and just return with the current value of 'type'.
*
* It would be better to signal an error here, but
* Tcl_Panic seems a bit excessive.
*/
numVolumes = -1;
}
while (numVolumes > 0) {
Tcl_Obj *vol;
int len;
const char *strVol;
numVolumes--;
Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol);
strVol = TclGetStringFromObj(vol,&len);
if (pathLen < len) {
continue;
}
if (strncmp(strVol, path, (size_t) len) == 0) {
type = TCL_PATH_ABSOLUTE;
if (filesystemPtrPtr != NULL) {
*filesystemPtrPtr = fsRecPtr->fsPtr;
}
if (driveNameLengthPtr != NULL) {
*driveNameLengthPtr = len;
}
if (driveNameRef != NULL) {
*driveNameRef = vol;
Tcl_IncrRefCount(vol);
}
break;
}
}
Tcl_DecrRefCount(thisFsVolumes);
if (type == TCL_PATH_ABSOLUTE) {
/*
* No need to to examine additional filesystems.
*/
break;
}
}
}
fsRecPtr = fsRecPtr->nextPtr;
}
Disclaim();
return type;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSRenameFile --
*
* If the two pathnames correspond to the same filesystem, call
* 'renameFileProc' of that filesystem. Otherwise return the POSIX error
* 'EXDEV', and -1.
*
* Results:
* A standard Tcl error code if a rename function was called, or -1
* otherwise.
*
* Side effects:
* A file may be renamed.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSRenameFile(
Tcl_Obj *srcPathPtr, /* The pathname of a file or directory to be
renamed. */
Tcl_Obj *destPathPtr) /* The new pathname for the file. */
{
int retVal = -1;
const Tcl_Filesystem *fsPtr, *fsPtr2;
fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
|
| ︙ | ︙ | |||
4313 4314 4315 4316 4317 4318 4319 | } /* *--------------------------------------------------------------------------- * * Tcl_FSCopyFile -- * | | | < | < | | > | > | | | 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 |
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSCopyFile --
*
* If both pathnames correspond to the same filesystem, calls
* 'copyFileProc' of that filesystem.
*
* In the native filesystems, 'copyFileProc' copies a link itself, not the
* thing the link points to.
*
* Results:
* A standard Tcl return code if a copyFileProc was called, or -1
* otherwise.
*
* Side effects:
* A file might be copied. The POSIX error 'EXDEV' is set if a copy
* function was not called.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSCopyFile(
Tcl_Obj *srcPathPtr, /* The pathname of file to be copied. */
Tcl_Obj *destPathPtr) /* The new pathname to copy the file to. */
{
int retVal = -1;
const Tcl_Filesystem *fsPtr, *fsPtr2;
fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
|
| ︙ | ︙ | |||
4355 4356 4357 4358 4359 4360 4361 | } /* *--------------------------------------------------------------------------- * * TclCrossFilesystemCopy -- * | | | < | | | | | | | | | | | | | | | 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 |
}
/*
*---------------------------------------------------------------------------
*
* TclCrossFilesystemCopy --
*
* Helper for Tcl_FSCopyFile and Tcl_FSLoadFile. Copies a file from one
* filesystem to another, overwiting any file that already exists.
*
* Results:
* A standard Tcl return code.
*
* Side effects:
* A file may be copied.
*
*---------------------------------------------------------------------------
*/
int
TclCrossFilesystemCopy(
Tcl_Interp *interp, /* For error messages. */
Tcl_Obj *source, /* Pathname of file to be copied. */
Tcl_Obj *target) /* Pathname to copy the file to. */
{
int result = TCL_ERROR;
int prot = 0666;
Tcl_Channel in, out;
Tcl_StatBuf sourceStatBuf;
struct utimbuf tval;
out = Tcl_FSOpenFileChannel(interp, target, "wb", prot);
if (out == NULL) {
/*
* Failed to open an output channel. Bail out.
*/
goto done;
}
in = Tcl_FSOpenFileChannel(interp, source, "rb", prot);
if (in == NULL) {
/*
* Could not open an input channel. Why didn't the caller check this?
*/
Tcl_Close(interp, out);
goto done;
}
/*
* Copy the file synchronously. TO DO: Maybe add an asynchronous option
* to support virtual filesystems that are slow (e.g. network sockets).
*/
if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) {
result = TCL_OK;
}
/*
* If the copy failed, assume that copy channel left an error message.
*/
Tcl_Close(interp, in);
Tcl_Close(interp, out);
/*
* Set modification date of copied file.
*/
if (Tcl_FSLstat(source, &sourceStatBuf) == 0) {
tval.actime = Tcl_GetAccessTimeFromStat(&sourceStatBuf);
tval.modtime = Tcl_GetModificationTimeFromStat(&sourceStatBuf);
Tcl_FSUtime(target, &tval);
}
done:
return result;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSDeleteFile --
*
* Calls 'deleteFileProc' of the filesystem corresponding to the given
* pathname.
*
* Results:
* A standard Tcl return code.
*
* Side effects:
* A file may be deleted.
*
*---------------------------------------------------------------------------
*/
|
| ︙ | ︙ | |||
4463 4464 4465 4466 4467 4468 4469 | } /* *--------------------------------------------------------------------------- * * Tcl_FSCreateDirectory -- * | | | | | > | 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 |
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSCreateDirectory --
*
* Calls 'createDirectoryProc' of the filesystem corresponding to the
* given pathname.
*
* Results:
* A standard Tcl return code, or -1 if no createDirectoryProc is found.
*
* Side effects:
* A directory may be created. POSIX error 'ENOENT' is set if no
* createDirectoryProc is found.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSCreateDirectory(
Tcl_Obj *pathPtr) /* Pathname of directory to create (UTF-8). */
|
| ︙ | ︙ | |||
4493 4494 4495 4496 4497 4498 4499 | } /* *--------------------------------------------------------------------------- * * Tcl_FSCopyDirectory -- * | | | < | | > | > | | | > > | | | 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 |
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSCopyDirectory --
*
* If both pathnames correspond to the the same filesystem, calls
* 'copyDirectoryProc' of that filesystem.
*
* Results:
* A standard Tcl return code, or -1 if no 'copyDirectoryProc' is found.
*
* Side effects:
* A directory may be copied. POSIX error 'EXDEV' is set if no
* copyDirectoryProc is found.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSCopyDirectory(
Tcl_Obj *srcPathPtr, /*
* The pathname of the directory to be copied.
*/
Tcl_Obj *destPathPtr, /* The pathname of the target directory. */
Tcl_Obj **errorPtr) /* If not NULL, and there is an error, a place
* to store a pointer to a new object, with
* its refCount already incremented, and
* containing the pathname name of file
* causing the error. */
{
int retVal = -1;
const Tcl_Filesystem *fsPtr, *fsPtr2;
fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
|
| ︙ | ︙ | |||
4535 4536 4537 4538 4539 4540 4541 | } /* *--------------------------------------------------------------------------- * * Tcl_FSRemoveDirectory -- * | | | | | > | | | | | | > | > | < < < < < < | | | | < | < < < > | > > | < | | | < < < < < | < < < > > > > | > > | | < | | | | < < < < < < < < < < < < < < < < < < < | | | > < < < | > > | > | 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 4512 4513 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 |
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSRemoveDirectory --
*
* Calls 'removeDirectoryProc' of the filesystem corresponding to remove
* pathPtr.
*
* Results:
* A standard Tcl return code, or -1 if no removeDirectoryProc is found.
*
* Side effects:
* A directory may be removed. POSIX error 'ENOENT' is set if no
* removeDirectoryProc is found.
*
*---------------------------------------------------------------------------
*/
int
Tcl_FSRemoveDirectory(
Tcl_Obj *pathPtr, /* The pathname of the directory to be removed.
*/
int recursive, /* If zero, removes only an empty directory.
* Otherwise, removes the directory and all its
* contents. */
Tcl_Obj **errorPtr) /* If not NULL and an error occurs, stores a
* place to store a a pointer to a new
* object having a refCount of 1 and containing
* the name of the file that produced an error.
* */
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr == NULL || fsPtr->removeDirectoryProc == NULL) {
Tcl_SetErrno(ENOENT);
return -1;
}
if (recursive) {
Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL);
if (cwdPtr != NULL) {
const char *cwdStr, *normPathStr;
int cwdLen, normLen;
Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normPath != NULL) {
normPathStr = TclGetStringFromObj(normPath, &normLen);
cwdStr = TclGetStringFromObj(cwdPtr, &cwdLen);
if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr,
(size_t) normLen) == 0)) {
/*
* The cwd is inside the directory to be removed. Change
* the cwd to [file dirname $path].
*/
Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr,
TCL_PATH_DIRNAME);
Tcl_FSChdir(dirPtr);
Tcl_DecrRefCount(dirPtr);
}
}
Tcl_DecrRefCount(cwdPtr);
}
}
return fsPtr->removeDirectoryProc(pathPtr, recursive, errorPtr);
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetFileSystemForPath --
*
* Produces the filesystem that corresponds to the given pathname.
*
* Results:
* The corresponding Tcl_Filesystem, or NULL if the pathname is invalid.
*
* Side effects:
* The internal representation of fsPtrPtr is converted to fsPathType if
* needed, and that internal representation is updated as needed.
*
*---------------------------------------------------------------------------
*/
const Tcl_Filesystem *
Tcl_FSGetFileSystemForPath(
Tcl_Obj *pathPtr)
{
FilesystemRecord *fsRecPtr;
const Tcl_Filesystem *retVal = NULL;
if (pathPtr == NULL) {
Tcl_Panic("Tcl_FSGetFileSystemForPath called with NULL object");
return NULL;
}
if (pathPtr->refCount == 0) {
/*
* 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 master filesystem. */
fsRecPtr = FsGetFirstFilesystem();
Claim();
/*
* Ensure that pathPtr is a valid pathname.
*/
if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) {
/* not a valid pathname */
Disclaim();
return NULL;
} else if (retVal != NULL) {
/*
* Found the filesystem in the internal representation of pathPtr.
*/
Disclaim();
return retVal;
}
/*
* Call each of the "pathInFilesystem" functions in succession until the
* corresponding filesystem is found.
*/
for (; fsRecPtr!=NULL ; fsRecPtr=fsRecPtr->nextPtr) {
ClientData clientData = NULL;
if (fsRecPtr->fsPtr->pathInFilesystemProc == NULL) {
continue;
}
if (fsRecPtr->fsPtr->pathInFilesystemProc(pathPtr, &clientData)!=-1) {
/* This is the filesystem for pathPtr. Assume the type of pathPtr
* hasn't been changed by the above call to the
* pathInFilesystemProc, and cache this result in the internal
* representation of pathPtr. */
TclFSSetPathDetails(pathPtr, fsRecPtr->fsPtr, clientData);
Disclaim();
return fsRecPtr->fsPtr;
}
}
Disclaim();
return NULL;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetNativePath --
*
* See Tcl_FSGetInternalRep.
*
*---------------------------------------------------------------------------
*/
const void *
Tcl_FSGetNativePath(
Tcl_Obj *pathPtr)
{
return Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem);
}
/*
*---------------------------------------------------------------------------
*
* NativeFreeInternalRep --
*
* Free a native internal representation.
*
* Results:
* None.
*
* Side effects:
* Memory is released.
*
*---------------------------------------------------------------------------
*/
static void
NativeFreeInternalRep(
ClientData clientData)
{
ckfree(clientData);
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSFileSystemInfo --
* Produce the type of a pathname and the type of its filesystem.
*
*
* Results:
* A list where the first item is the name of the filesystem (e.g.
* "native" or "vfs"), and the second item is the type of the given
* pathname within that filesystem.
*
* Side effects:
* The internal representation of pathPtr may be converted to a
* fsPathType.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSFileSystemInfo(
Tcl_Obj *pathPtr)
|
| ︙ | ︙ | |||
4798 4799 4800 4801 4802 4803 4804 | } /* *--------------------------------------------------------------------------- * * Tcl_FSPathSeparator -- * | | < | < < | > | < | | | | | | 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 |
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSPathSeparator --
*
* Produces the separator for given pathname.
*
* Results:
* A Tcl object having a refCount of zero.
*
* Side effects:
* The internal representation of pathPtr may be converted to a fsPathType
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSPathSeparator(
Tcl_Obj *pathPtr)
{
const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
Tcl_Obj *resultObj;
if (fsPtr == NULL) {
return NULL;
}
if (fsPtr->filesystemSeparatorProc != NULL) {
return fsPtr->filesystemSeparatorProc(pathPtr);
}
/*
* Use the standard forward slash character if filesystem does not to
* provide a filesystemSeparatorProc.
*/
TclNewLiteralStringObj(resultObj, "/");
return resultObj;
}
/*
*---------------------------------------------------------------------------
*
* NativeFilesystemSeparator --
*
* This function, part of the native filesystem support, returns the
* separator for the given pathname.
*
* Results:
* The separator character.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static Tcl_Obj *
NativeFilesystemSeparator(
TCL_UNUSED(Tcl_Obj *) /*pathPtr*/)
{
const char *separator = NULL;
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
separator = "/";
break;
case TCL_PLATFORM_WINDOWS:
separator = "\\";
|
| ︙ | ︙ |
Changes to generic/tclIndexObj.c.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 | /* * Prototypes for functions defined later in this file: */ static int GetIndexFromObjList(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *tableObjPtr, const char *msg, int flags, int *indexPtr); | < | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | /* * Prototypes for functions defined later in this file: */ static int GetIndexFromObjList(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj *tableObjPtr, const char *msg, int flags, int *indexPtr); static void UpdateStringOfIndex(Tcl_Obj *objPtr); static void DupIndex(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void FreeIndex(Tcl_Obj *objPtr); static int PrefixAllObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int PrefixLongestObjCmd(ClientData clientData, |
| ︙ | ︙ | |||
44 45 46 47 48 49 50 |
*/
static const Tcl_ObjType indexType = {
"index", /* name */
FreeIndex, /* freeIntRepProc */
DupIndex, /* dupIntRepProc */
UpdateStringOfIndex, /* updateStringProc */
| | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 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 |
*/
static const Tcl_ObjType indexType = {
"index", /* name */
FreeIndex, /* freeIntRepProc */
DupIndex, /* dupIntRepProc */
UpdateStringOfIndex, /* updateStringProc */
NULL /* setFromAnyProc */
};
/*
* The definition of the internal representation of the "index" object; The
* internalRep.twoPtrValue.ptr1 field of an object of "index" type will be a
* pointer to one of these structures.
*
* Keep this structure declaration in sync with tclTestObj.c
*/
typedef struct {
void *tablePtr; /* Pointer to the table of strings */
int offset; /* Offset between table entries */
int index; /* Selected index into table. */
} IndexRep;
/*
* The following macros greatly simplify moving through a table...
*/
#define STRING_AT(table, offset) \
(*((const char *const *)(((char *)(table)) + (offset))))
#define NEXT_ENTRY(table, offset) \
(&(STRING_AT(table, offset)))
#define EXPAND_OF(indexRep) \
STRING_AT((indexRep)->tablePtr, (indexRep)->offset*(indexRep)->index)
/*
*----------------------------------------------------------------------
*
* Tcl_GetIndexFromObj --
*
* This function looks up an object's value in a table of strings and
* returns the index of the matching string, if any.
*
* Results:
* If the value of objPtr is identical to or a unique abbreviation for
* one of the entries in tablePtr, then the return value is TCL_OK and the
* index of the matching entry is stored at *indexPtr. If there isn't a
* proper match, then TCL_ERROR is returned and an error message is left
* in interp's result (unless interp is NULL). The msg argument is used
* in the error message; for example, if msg has the value "option" then
* the error message will say something flag 'bad option "foo": must be
* ...'
*
* Side effects:
* The result of the lookup is cached as the internal rep of objPtr, so
* that repeated lookups can be done quickly.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
#undef Tcl_GetIndexFromObj
int
Tcl_GetIndexFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object containing the string to lookup. */
const char *const*tablePtr, /* Array of strings to compare against the
* 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 & INDEX_TEMP_TABLE)) {
/*
* See if there is a valid cached result from a previous lookup (doing the
* check here saves the overhead of calling Tcl_GetIndexFromObjStruct in
* the common case where the result is cached).
*/
const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &indexType);
if (irPtr) {
IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
/*
* Here's hoping we don't get hit by unfortunate packing constraints
* on odd platforms like a Cray PVP...
*/
if (indexRep->tablePtr == (void *) tablePtr
&& indexRep->offset == sizeof(char *)) {
*indexPtr = indexRep->index;
return TCL_OK;
}
}
}
return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *),
msg, flags, indexPtr);
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* GetIndexFromObjList --
*
* This procedure looks up an object's value in a table of strings and
* returns the index of the matching string, if any.
|
| ︙ | ︙ | |||
127 128 129 130 131 132 133 |
return result;
}
/*
* Build a string table from the list.
*/
| | | | | | 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 |
return result;
}
/*
* Build a string table from the list.
*/
tablePtr = (const char **)ckalloc((objc + 1) * sizeof(char *));
for (t = 0; t < objc; t++) {
if (objv[t] == objPtr) {
/*
* An exact match is always chosen, so we can stop here.
*/
ckfree(tablePtr);
*indexPtr = t;
return TCL_OK;
}
tablePtr[t] = Tcl_GetString(objv[t]);
}
tablePtr[objc] = NULL;
result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr,
sizeof(char *), msg, flags | INDEX_TEMP_TABLE, indexPtr);
ckfree(tablePtr);
return result;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 |
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object containing the string to lookup. */
const void *tablePtr, /* The first string in the table. The second
* string will be at this address plus the
* offset, the third plus the offset again,
* etc. The last entry must be NULL and there
* must not be duplicate entries. */
| | | | | | 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 |
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object containing the string to lookup. */
const void *tablePtr, /* The first string in the table. The second
* string will be at this address plus the
* offset, the third plus the offset again,
* etc. The last entry must be NULL and there
* must not be duplicate entries. */
int offset, /* The number of bytes between 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. */
{
int index, idx, numAbbrev;
const char *key, *p1;
const char *p2;
const char *const *entryPtr;
Tcl_Obj *resultPtr;
IndexRep *indexRep;
const Tcl_ObjIntRep *irPtr;
/* Protect against invalid values, like -1 or 0. */
if (offset < (int)sizeof(char *)) {
offset = (int)sizeof(char *);
}
/*
* See if there is a valid cached result from a previous lookup.
*/
if (!(flags & 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;
}
}
}
|
| ︙ | ︙ | |||
235 236 237 238 239 240 241 |
/*
* Scan the table looking for one of:
* - An exact match (always preferred)
* - A single abbreviation (allowed depending on flags)
* - Several abbreviations (never allowed, but overridden by exact match)
*/
| | | 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 |
/*
* Scan the table looking for one of:
* - An exact match (always preferred)
* - A single abbreviation (allowed depending on flags)
* - Several abbreviations (never allowed, but overridden by exact match)
*/
for (entryPtr = (const char* const*)tablePtr, idx = 0; *entryPtr != NULL;
entryPtr = NEXT_ENTRY(entryPtr, offset), idx++) {
for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
if (*p1 == '\0') {
index = idx;
goto done;
}
}
|
| ︙ | ︙ | |||
275 276 277 278 279 280 281 |
* new internal-rep if at all possible since that is potentially a slow
* operation.
*/
if (!(flags & INDEX_TEMP_TABLE)) {
irPtr = TclFetchIntRep(objPtr, &indexType);
if (irPtr) {
| | | | | 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 |
* new internal-rep if at all possible since that is potentially a slow
* operation.
*/
if (!(flags & INDEX_TEMP_TABLE)) {
irPtr = TclFetchIntRep(objPtr, &indexType);
if (irPtr) {
indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
} else {
Tcl_ObjIntRep ir;
indexRep = (IndexRep*)ckalloc(sizeof(IndexRep));
ir.twoPtrValue.ptr1 = indexRep;
Tcl_StoreIntRep(objPtr, &indexType, &ir);
}
indexRep->tablePtr = (void *) tablePtr;
indexRep->offset = offset;
indexRep->index = index;
}
*indexPtr = index;
return TCL_OK;
error:
if (interp != NULL) {
/*
* Produce a fancy error message.
*/
int count = 0;
TclNewObj(resultPtr);
entryPtr = (const char* const *)tablePtr;
while ((*entryPtr != NULL) && !**entryPtr) {
entryPtr = NEXT_ENTRY(entryPtr, offset);
}
Tcl_AppendStringsToObj(resultPtr,
(numAbbrev>1 && !(flags & TCL_EXACT) ? "ambiguous " : "bad "),
msg, " \"", key, NULL);
if (*entryPtr == NULL) {
|
| ︙ | ︙ | |||
333 334 335 336 337 338 339 |
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 |
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfIndex --
*
* This function is called to convert a Tcl object from index internal
* form to its string form. No abbreviation is ever generated.
*
* Results:
* None.
*
* Side effects:
* The string representation of the object is updated.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfIndex(
Tcl_Obj *objPtr)
{
IndexRep *indexRep = (IndexRep *)TclFetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1;
const char *indexStr = EXPAND_OF(indexRep);
Tcl_InitStringRep(objPtr, indexStr, strlen(indexStr));
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
414 415 416 417 418 419 420 |
static void
DupIndex(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
Tcl_ObjIntRep ir;
| | | 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 |
static void
DupIndex(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
Tcl_ObjIntRep ir;
IndexRep *dupIndexRep = (IndexRep *)ckalloc(sizeof(IndexRep));
memcpy(dupIndexRep, TclFetchIntRep(srcPtr, &indexType)->twoPtrValue.ptr1,
sizeof(IndexRep));
ir.twoPtrValue.ptr1 = dupIndexRep;
Tcl_StoreIntRep(dupPtr, &indexType, &ir);
}
|
| ︙ | ︙ | |||
444 445 446 447 448 449 450 |
*----------------------------------------------------------------------
*/
static void
FreeIndex(
Tcl_Obj *objPtr)
{
| | | 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 |
*----------------------------------------------------------------------
*/
static void
FreeIndex(
Tcl_Obj *objPtr)
{
ckfree(TclFetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1);
objPtr->typePtr = NULL;
}
/*
*----------------------------------------------------------------------
*
* TclInitPrefixCmd --
|
| ︙ | ︙ | |||
501 502 503 504 505 506 507 | * None. * *---------------------------------------------------------------------- */ static int PrefixMatchObjCmd( | | | 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PrefixMatchObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int flags = 0, result, index;
int dummyLength, i, errorLength;
Tcl_Obj *errorPtr = NULL;
|
| ︙ | ︙ | |||
540 541 542 543 544 545 546 |
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing value for -message", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
return TCL_ERROR;
}
i++;
| | | 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 |
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing value for -message", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
return TCL_ERROR;
}
i++;
message = Tcl_GetString(objv[i]);
break;
case PRFMATCH_ERROR:
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing value for -error", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
625 626 627 628 629 630 631 | * None. * *---------------------------------------------------------------------- */ static int PrefixAllObjCmd( | | | < | 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PrefixAllObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int tableObjc, result, t, length, elemLength;
const char *string, *elemString;
Tcl_Obj **tableObjv, *resultPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "table string");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
683 684 685 686 687 688 689 | * None. * *---------------------------------------------------------------------- */ static int PrefixLongestObjCmd( | | | < | 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PrefixLongestObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int tableObjc, result, i, t, length, elemLength, resultLength;
const char *string, *elemString, *resultString;
Tcl_Obj **tableObjv;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "table string");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
748 749 750 751 752 753 754 |
for (i = 0; i < resultLength; i++) {
if (resultString[i] != elemString[i]) {
/*
* Adjust in case we stopped in the middle of a UTF char.
*/
| | | 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 |
for (i = 0; i < resultLength; i++) {
if (resultString[i] != elemString[i]) {
/*
* Adjust in case we stopped in the middle of a UTF char.
*/
resultLength = TclUtfPrev(&resultString[i+1],
resultString) - resultString;
break;
}
}
}
}
if (resultLength > 0) {
|
| ︙ | ︙ | |||
812 813 814 815 816 817 818 |
Tcl_Obj *const objv[], /* Initial argument objects, which should be
* included in the error message. */
const char *message) /* Error message to print after the leading
* objects in objv. The message may be
* NULL. */
{
Tcl_Obj *objPtr;
| < | > > > > > > > > > > > > > > > > > > > > > > > | 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 |
Tcl_Obj *const objv[], /* Initial argument objects, which should be
* included in the error message. */
const char *message) /* Error message to print after the leading
* objects in objv. The message may be
* NULL. */
{
Tcl_Obj *objPtr;
int i, len, elemLen;
char flags;
Interp *iPtr = (Interp *) interp;
const char *elementStr;
/*
* [incr Tcl] does something fairly horrific when generating error
* messages for its ensembles; it passes the whole set of ensemble
* arguments as a list in the first argument. This means that this code
* causes a problem in iTcl if it attempts to correctly quote all
* arguments, which would be the correct thing to do. We work around this
* nasty behaviour for now, and hope that we can remove it all in the
* future...
*/
#ifndef AVOID_HACKS_FOR_ITCL
int isFirst = 1; /* Special flag used to inhibit the treating
* of the first word as a list element so the
* hacky way Itcl generates error messages for
* its ensembles will still work. [Bug
* 1066837] */
# define MAY_QUOTE_WORD (!isFirst)
# define AFTER_FIRST_WORD (isFirst = 0)
#else /* !AVOID_HACKS_FOR_ITCL */
# define MAY_QUOTE_WORD 1
# define AFTER_FIRST_WORD (void) 0
#endif /* AVOID_HACKS_FOR_ITCL */
TclNewObj(objPtr);
if (iPtr->flags & INTERP_ALTERNATE_WRONG_ARGS) {
iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS;
Tcl_AppendObjToObj(objPtr, Tcl_GetObjResult(interp));
Tcl_AppendToObj(objPtr, " or \"", -1);
} else {
Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
|
| ︙ | ︙ | |||
874 875 876 877 878 879 880 |
for (i=0 ; i<toPrint ; i++) {
/*
* Add the element, quoting it if necessary.
*/
const Tcl_ObjIntRep *irPtr;
if ((irPtr = TclFetchIntRep(origObjv[i], &indexType))) {
| | | | > > | 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 |
for (i=0 ; i<toPrint ; i++) {
/*
* Add the element, quoting it if necessary.
*/
const Tcl_ObjIntRep *irPtr;
if ((irPtr = TclFetchIntRep(origObjv[i], &indexType))) {
IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
elementStr = EXPAND_OF(indexRep);
elemLen = strlen(elementStr);
} else {
elementStr = TclGetStringFromObj(origObjv[i], &elemLen);
}
flags = 0;
len = TclScanElement(elementStr, elemLen, &flags);
if (MAY_QUOTE_WORD && len != elemLen) {
char *quotedElementStr = (char *)TclStackAlloc(interp, len + 1);
len = TclConvertElement(elementStr, elemLen,
quotedElementStr, flags);
Tcl_AppendToObj(objPtr, quotedElementStr, len);
TclStackFree(interp, quotedElementStr);
} else {
Tcl_AppendToObj(objPtr, elementStr, elemLen);
}
AFTER_FIRST_WORD;
/*
* Add a space if the word is not the last one (which has a
* moderately complex condition here).
*/
if (i<toPrint-1 || objc!=0 || message!=NULL) {
|
| ︙ | ︙ | |||
921 922 923 924 925 926 927 |
* If the object is an index type use the index table which allows for
* the correct error message even if the subcommand was abbreviated.
* Otherwise, just use the string rep.
*/
const Tcl_ObjIntRep *irPtr;
if ((irPtr = TclFetchIntRep(objv[i], &indexType))) {
| | | | > > | 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 |
* If the object is an index type use the index table which allows for
* the correct error message even if the subcommand was abbreviated.
* Otherwise, just use the string rep.
*/
const Tcl_ObjIntRep *irPtr;
if ((irPtr = TclFetchIntRep(objv[i], &indexType))) {
IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL);
} else {
/*
* Quote the argument if it contains spaces (Bug 942757).
*/
elementStr = TclGetStringFromObj(objv[i], &elemLen);
flags = 0;
len = TclScanElement(elementStr, elemLen, &flags);
if (MAY_QUOTE_WORD && len != elemLen) {
char *quotedElementStr = (char *)TclStackAlloc(interp, len + 1);
len = TclConvertElement(elementStr, elemLen,
quotedElementStr, flags);
Tcl_AppendToObj(objPtr, quotedElementStr, len);
TclStackFree(interp, quotedElementStr);
} else {
Tcl_AppendToObj(objPtr, elementStr, elemLen);
}
}
AFTER_FIRST_WORD;
/*
* Append a space character (" ") if there is more text to follow
* (either another element from objv, or the message string).
*/
if (i<objc-1 || message!=NULL) {
|
| ︙ | ︙ | |||
967 968 969 970 971 972 973 974 975 976 977 978 979 980 |
if (message != NULL) {
Tcl_AppendStringsToObj(objPtr, message, NULL);
}
Tcl_AppendStringsToObj(objPtr, "\"", NULL);
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
Tcl_SetObjResult(interp, objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ParseArgsObjv --
*
| > > | 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 |
if (message != NULL) {
Tcl_AppendStringsToObj(objPtr, message, NULL);
}
Tcl_AppendStringsToObj(objPtr, "\"", NULL);
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
Tcl_SetObjResult(interp, objPtr);
#undef MAY_QUOTE_WORD
#undef AFTER_FIRST_WORD
}
/*
*----------------------------------------------------------------------
*
* Tcl_ParseArgsObjv --
*
|
| ︙ | ︙ | |||
1008 1009 1010 1011 1012 1013 1014 |
* processed here. Should be NULL if no return
* of arguments is desired. */
{
Tcl_Obj **leftovers; /* Array to write back to remObjv on
* successful exit. Will include the name of
* the command. */
int nrem; /* Size of leftovers.*/
| | | | | | 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 |
* processed here. Should be NULL if no return
* of arguments is desired. */
{
Tcl_Obj **leftovers; /* Array to write back to remObjv on
* successful exit. Will include the name of
* the command. */
int nrem; /* Size of leftovers.*/
const Tcl_ArgvInfo *infoPtr;
/* Pointer to the current entry in the table
* of argument descriptions. */
const Tcl_ArgvInfo *matchPtr;
/* Descriptor that matches current argument */
Tcl_Obj *curArg; /* Current argument */
const char *str = NULL;
char c; /* Second character of current arg (used for
* quick check for matching; use 2nd char.
* because first char. will almost always be
* '-'). */
int srcIndex; /* Location from which to read next argument
* from objv. */
int dstIndex; /* Used to keep track of current arguments
* being processed, primarily for error
* reporting. */
int objc; /* # arguments in objv still to process. */
int length; /* Number of characters in current argument */
if (remObjv != NULL) {
/*
* Then we should copy the name of the command (0th argument). The
* upper bound on the number of elements is known, and (undocumented,
* but historically true) there should be a NULL argument after the
* last result. [Bug 3413857]
*/
nrem = 1;
leftovers = (Tcl_Obj **)ckalloc((1 + *objcPtr) * sizeof(Tcl_Obj *));
leftovers[0] = objv[0];
} else {
nrem = 0;
leftovers = NULL;
}
/*
|
| ︙ | ︙ | |||
1122 1123 1124 1125 1126 1127 1128 |
if (objc == 0) {
goto missingArg;
}
if (Tcl_GetIntFromObj(interp, objv[srcIndex],
(int *) infoPtr->dstPtr) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer argument for \"%s\" but got \"%s\"",
| | | | 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 |
if (objc == 0) {
goto missingArg;
}
if (Tcl_GetIntFromObj(interp, objv[srcIndex],
(int *) infoPtr->dstPtr) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer argument for \"%s\" but got \"%s\"",
infoPtr->keyStr, Tcl_GetString(objv[srcIndex])));
goto error;
}
srcIndex++;
objc--;
break;
case TCL_ARGV_STRING:
if (objc == 0) {
goto missingArg;
}
*((const char **) infoPtr->dstPtr) =
Tcl_GetString(objv[srcIndex]);
srcIndex++;
objc--;
break;
case TCL_ARGV_REST:
/*
* Only store the point where we got to if it's not to be written
* to NULL, so that TCL_ARGV_AUTO_REST works.
|
| ︙ | ︙ | |||
1155 1156 1157 1158 1159 1160 1161 |
if (objc == 0) {
goto missingArg;
}
if (Tcl_GetDoubleFromObj(interp, objv[srcIndex],
(double *) infoPtr->dstPtr) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected floating-point argument for \"%s\" but got \"%s\"",
| | | 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 |
if (objc == 0) {
goto missingArg;
}
if (Tcl_GetDoubleFromObj(interp, objv[srcIndex],
(double *) infoPtr->dstPtr) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected floating-point argument for \"%s\" but got \"%s\"",
infoPtr->keyStr, Tcl_GetString(objv[srcIndex])));
goto error;
}
srcIndex++;
objc--;
break;
case TCL_ARGV_FUNC: {
Tcl_ArgvFuncProc *handlerProc = (Tcl_ArgvFuncProc *)
|
| ︙ | ︙ | |||
1220 1221 1222 1223 1224 1225 1226 |
if (objc > 0) {
memcpy(leftovers+nrem, objv+srcIndex, objc*sizeof(Tcl_Obj *));
nrem += objc;
}
leftovers[nrem] = NULL;
*objcPtr = nrem++;
| | | | 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 |
if (objc > 0) {
memcpy(leftovers+nrem, objv+srcIndex, objc*sizeof(Tcl_Obj *));
nrem += objc;
}
leftovers[nrem] = NULL;
*objcPtr = nrem++;
*remObjv = (Tcl_Obj **)ckrealloc(leftovers, nrem * sizeof(Tcl_Obj *));
return TCL_OK;
/*
* Make sure to handle freeing any temporary space we've allocated on the
* way to an error.
*/
missingArg:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" option requires an additional argument", str));
error:
if (leftovers != NULL) {
ckfree(leftovers);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1263 1264 1265 1266 1267 1268 1269 |
PrintUsage(
Tcl_Interp *interp, /* Place information in this interp's result
* area. */
const Tcl_ArgvInfo *argTable)
/* Array of command-specific argument
* descriptions. */
{
| | | | | 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 |
PrintUsage(
Tcl_Interp *interp, /* Place information in this interp's result
* area. */
const Tcl_ArgvInfo *argTable)
/* Array of command-specific argument
* descriptions. */
{
const Tcl_ArgvInfo *infoPtr;
int width, numSpaces;
#define NUM_SPACES 20
static const char spaces[] = " ";
char tmp[TCL_DOUBLE_SPACE];
Tcl_Obj *msg;
/*
* First, compute the width of the widest option key, so that we can make
* everything line up.
*/
width = 4;
for (infoPtr = argTable; infoPtr->type != TCL_ARGV_END; infoPtr++) {
int length;
if (infoPtr->keyStr == NULL) {
continue;
}
length = strlen(infoPtr->keyStr);
if (length > width) {
width = length;
}
}
/*
* Now add the option information, with pretty-printing.
*/
|
| ︙ | ︙ |
Changes to generic/tclInt.decls.
| ︙ | ︙ | |||
44 45 46 47 48 49 50 |
int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr,
Tcl_Channel errorChan)
}
declare 6 {
void TclCleanupCommand(Command *cmdPtr)
}
declare 7 {
| | < | | | < > | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 |
int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr,
Tcl_Channel errorChan)
}
declare 6 {
void TclCleanupCommand(Command *cmdPtr)
}
declare 7 {
int TclCopyAndCollapse(int count, const char *src, char *dst)
}
declare 8 {deprecated {}} {
int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan,
Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr)
}
# TclCreatePipeline unofficially exported for use by BLT.
declare 9 {
int TclCreatePipeline(Tcl_Interp *interp, int argc, const char **argv,
Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr,
TclFile *errFilePtr)
|
| ︙ | ︙ | |||
76 77 78 79 80 81 82 |
}
# Removed in 8.5:
#declare 13 {
# int TclDoGlob(Tcl_Interp *interp, char *separators,
# Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types)
#}
declare 14 {
| | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
}
# Removed in 8.5:
#declare 13 {
# int TclDoGlob(Tcl_Interp *interp, char *separators,
# Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types)
#}
declare 14 {
int TclDumpMemoryInfo(ClientData clientData, int flags)
}
# Removed in 8.1:
# declare 15 {
# void TclExpandParseValue(ParseValue *pvPtr, int needed)
# }
declare 16 {
void TclExprFloatError(Tcl_Interp *interp, double value)
|
| ︙ | ︙ | |||
104 105 106 107 108 109 110 |
#}
#declare 21 {
# int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv)
#}
declare 22 {
int TclFindElement(Tcl_Interp *interp, const char *listStr,
int listLength, const char **elementPtr, const char **nextPtr,
| | | | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 |
#}
#declare 21 {
# int TclFileRenameCmd(Tcl_Interp *interp, int argc, char **argv)
#}
declare 22 {
int TclFindElement(Tcl_Interp *interp, const char *listStr,
int listLength, const char **elementPtr, const char **nextPtr,
int *sizePtr, int *bracePtr)
}
declare 23 {
Proc *TclFindProc(Interp *iPtr, const char *procName)
}
# Replaced with macro (see tclInt.h) in Tcl 8.5.0, restored in 8.5.10
declare 24 {
int TclFormatInt(char *buffer, Tcl_WideInt n)
}
declare 25 {
void TclFreePackageInfo(Interp *iPtr)
}
# Removed in 8.1:
# declare 26 {
# char *TclGetCwd(Tcl_Interp *interp)
|
| ︙ | ︙ | |||
148 149 150 151 152 153 154 |
int TclGetFrame(Tcl_Interp *interp, const char *str,
CallFrame **framePtrPtr)
}
# Removed in 8.5:
#declare 33 {
# TclCmdProcType TclGetInterpProc(void)
#}
| < | | | < > | 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 |
int TclGetFrame(Tcl_Interp *interp, const char *str,
CallFrame **framePtrPtr)
}
# Removed in 8.5:
#declare 33 {
# TclCmdProcType TclGetInterpProc(void)
#}
declare 34 {deprecated {Use Tcl_GetIntForIndex}} {
int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr,
int endValue, int *indexPtr)
}
# Removed in 8.4b2:
#declare 35 {
# Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex,
# int flags)
#}
# Removed in 8.6a2:
#declare 36 {
|
| ︙ | ︙ | |||
181 182 183 184 185 186 187 |
declare 40 {
int TclGetOpenMode(Tcl_Interp *interp, const char *str, int *seekFlagPtr)
}
declare 41 {
Tcl_Command TclGetOriginalCommand(Tcl_Command command)
}
declare 42 {
| | | 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 |
declare 40 {
int TclGetOpenMode(Tcl_Interp *interp, const char *str, int *seekFlagPtr)
}
declare 41 {
Tcl_Command TclGetOriginalCommand(Tcl_Command command)
}
declare 42 {
CONST86 char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr)
}
# Removed in 8.5a2:
#declare 43 {
# int TclGlobalInvoke(Tcl_Interp *interp, int argc, const char **argv,
# int flags)
#}
declare 44 {
|
| ︙ | ︙ | |||
224 225 226 227 228 229 230 |
}
# Removed in 8.5a2:
#declare 52 {
# int TclInvoke(Tcl_Interp *interp, int argc, const char **argv,
# int flags)
#}
declare 53 {
| | | | 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 |
}
# Removed in 8.5a2:
#declare 52 {
# int TclInvoke(Tcl_Interp *interp, int argc, const char **argv,
# int flags)
#}
declare 53 {
int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp,
int argc, const char **argv)
}
declare 54 {
int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 55 {
Proc *TclIsProc(Command *cmdPtr)
}
# Replaced with TclpLoadFile in 8.1:
# declare 56 {
|
| ︙ | ︙ | |||
264 265 266 267 268 269 270 |
declare 61 {
Tcl_Obj *TclNewProcBodyObj(Proc *procPtr)
}
declare 62 {
int TclObjCommandComplete(Tcl_Obj *cmdPtr)
}
declare 63 {
| | | 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 |
declare 61 {
Tcl_Obj *TclNewProcBodyObj(Proc *procPtr)
}
declare 62 {
int TclObjCommandComplete(Tcl_Obj *cmdPtr)
}
declare 63 {
int TclObjInterpProc(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 64 {
int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[],
int flags)
}
# Removed in 8.5a2:
|
| ︙ | ︙ | |||
287 288 289 290 291 292 293 |
# int TclOpenFileChannelInsertProc(TclOpenFileChannelProc_ *proc)
#}
# Replaced by Tcl_FSAccess in 8.4:
#declare 68 {
# int TclpAccess(const char *path, int mode)
#}
declare 69 {
| | | | < < | | < > | | 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 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 |
# int TclOpenFileChannelInsertProc(TclOpenFileChannelProc_ *proc)
#}
# Replaced by Tcl_FSAccess in 8.4:
#declare 68 {
# int TclpAccess(const char *path, int mode)
#}
declare 69 {
void *TclpAlloc(unsigned int size)
}
#declare 70 {
# int TclpCopyFile(const char *source, const char *dest)
#}
#declare 71 {
# int TclpCopyDirectory(const char *source, const char *dest,
# Tcl_DString *errorPtr)
#}
#declare 72 {
# int TclpCreateDirectory(const char *path)
#}
#declare 73 {
# int TclpDeleteFile(const char *path)
#}
declare 74 {
void TclpFree(void *ptr)
}
declare 75 {
unsigned long TclpGetClicks(void)
}
declare 76 {
unsigned long TclpGetSeconds(void)
}
declare 77 {deprecated {}} {
void TclpGetTime(Tcl_Time *time)
}
# Removed in 8.6:
#declare 78 {
# int TclpGetTimeZone(unsigned long time)
#}
# Replaced by Tcl_FSListVolumes in 8.4:
#declare 79 {
# int TclpListVolumes(Tcl_Interp *interp)
#}
# Replaced by Tcl_FSOpenFileChannel in 8.4:
#declare 80 {
# Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName,
# char *modeString, int permissions)
#}
declare 81 {
void *TclpRealloc(void *ptr, unsigned int size)
}
#declare 82 {
# int TclpRemoveDirectory(const char *path, int recursive,
# Tcl_DString *errorPtr)
#}
#declare 83 {
# int TclpRenameFile(const char *source, const char *dest)
|
| ︙ | ︙ | |||
355 356 357 358 359 360 361 |
# declare 86 {
# int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar,
# int flags, char **termPtr, ParseValue *pvPtr)
# }
# declare 87 {
# void TclPlatformInit(Tcl_Interp *interp)
# }
| < | | | < > | | 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 |
# declare 86 {
# int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar,
# int flags, char **termPtr, ParseValue *pvPtr)
# }
# declare 87 {
# void TclPlatformInit(Tcl_Interp *interp)
# }
declare 88 {deprecated {}} {
char *TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp,
const char *name1, const char *name2, int flags)
}
declare 89 {
int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp,
Tcl_Command cmd)
}
# Removed in 8.1 (only available if compiled with TCL_COMPILE_DEBUG):
# declare 90 {
# void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
# }
declare 91 {
void TclProcCleanupProc(Proc *procPtr)
}
declare 92 {
int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr,
Tcl_Obj *bodyPtr, Namespace *nsPtr, const char *description,
const char *procName)
}
declare 93 {
void TclProcDeleteProc(ClientData clientData)
}
# Removed in 8.5:
#declare 94 {
# int TclProcInterpProc(void *clientData, Tcl_Interp *interp,
# int argc, const char **argv)
#}
# Replaced by Tcl_FSStat in 8.4:
|
| ︙ | ︙ | |||
409 410 411 412 413 414 415 |
#}
# Removed in 8.4b2:
#declare 100 {
# Tcl_Obj *TclSetIndexedScalar(Tcl_Interp *interp, int localIndex,
# Tcl_Obj *objPtr, int flags)
#}
declare 101 {
| | < | | < > | 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 |
#}
# Removed in 8.4b2:
#declare 100 {
# Tcl_Obj *TclSetIndexedScalar(Tcl_Interp *interp, int localIndex,
# Tcl_Obj *objPtr, int flags)
#}
declare 101 {
CONST86 char *TclSetPreInitScript(const char *string)
}
declare 102 {
void TclSetupEnv(Tcl_Interp *interp)
}
declare 103 {
int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto,
int *portPtr)
}
declare 104 {deprecated {}} {
int TclSockMinimumBuffersOld(int sock, int size)
}
# Replaced by Tcl_FSStat in 8.4:
#declare 105 {
# int TclStat(const char *path, Tcl_StatBuf *buf)
#}
#declare 106 {
# int TclStatDeleteProc(TclStatProc_ *proc)
#}
|
| ︙ | ︙ | |||
454 455 456 457 458 459 460 |
# defined here instead of in tcl.decls since they are not stable yet.
declare 111 {
void Tcl_AddInterpResolvers(Tcl_Interp *interp, const char *name,
Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
| < | | | < < > | | | < < > | | < < > | | | < < > | | | < < > | | | < > < | | | < < > | | < < > | | | < < > | | < < > | | < > < | | | < > < | | < > | 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 |
# defined here instead of in tcl.decls since they are not stable yet.
declare 111 {
void Tcl_AddInterpResolvers(Tcl_Interp *interp, const char *name,
Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
declare 112 {
int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
Tcl_Obj *objPtr)
}
declare 113 {
Tcl_Namespace *TclCreateNamespace(Tcl_Interp *interp, const char *name,
ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc)
}
declare 114 {
void TclDeleteNamespace(Tcl_Namespace *nsPtr)
}
declare 115 {
int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int resetListFirst)
}
declare 116 {
Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
declare 117 {
Tcl_Namespace *TclFindNamespace(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
declare 118 {
int Tcl_GetInterpResolvers(Tcl_Interp *interp, const char *name,
Tcl_ResolverInfo *resInfo)
}
declare 119 {
int Tcl_GetNamespaceResolvers(Tcl_Namespace *namespacePtr,
Tcl_ResolverInfo *resInfo)
}
declare 120 {
Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags)
}
declare 121 {
int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern)
}
declare 122 {
Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr)
}
declare 123 {
void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command,
Tcl_Obj *objPtr)
}
declare 124 {
Tcl_Namespace *TclGetCurrentNamespace_(Tcl_Interp *interp)
}
declare 125 {
Tcl_Namespace *TclGetGlobalNamespace_(Tcl_Interp *interp)
}
declare 126 {
void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable,
Tcl_Obj *objPtr)
}
declare 127 {
int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int allowOverwrite)
}
declare 128 {
void Tcl_PopCallFrame(Tcl_Interp *interp)
}
declare 129 {
int Tcl_PushCallFrame(Tcl_Interp *interp, Tcl_CallFrame *framePtr,
Tcl_Namespace *nsPtr, int isProcCallFrame)
}
declare 130 {
int Tcl_RemoveInterpResolvers(Tcl_Interp *interp, const char *name)
}
declare 131 {
void Tcl_SetNamespaceResolvers(Tcl_Namespace *namespacePtr,
Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc)
}
declare 132 {
int TclpHasSockets(Tcl_Interp *interp)
}
declare 133 {deprecated {}} {
struct tm *TclpGetDate(const time_t *time, int useGMT)
}
# Removed in 8.5
#declare 134 {
# size_t TclpStrftime(char *s, size_t maxsize, const char *format,
# const struct tm *t, int useGMT)
#}
#declare 135 {
# int TclpCheckStackSpace(void)
|
| ︙ | ︙ | |||
579 580 581 582 583 584 585 |
#}
# This is used by TclX, but should otherwise be considered private
declare 141 {
const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
declare 142 {
int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
| | | 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 |
#}
# This is used by TclX, but should otherwise be considered private
declare 141 {
const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
declare 142 {
int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
CompileHookProc *hookProc, ClientData clientData)
}
declare 143 {
int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr,
LiteralEntry **litPtrPtr)
}
declare 144 {
void TclHideLiteral(Tcl_Interp *interp, struct CompileEnv *envPtr,
|
| ︙ | ︙ | |||
611 612 613 614 615 616 617 |
# Added for Tcl 8.2
declare 150 {
int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re)
}
declare 151 {
| | | | 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 |
# Added for Tcl 8.2
declare 150 {
int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re)
}
declare 151 {
void TclRegExpRangeUniChar(Tcl_RegExp re, int index, int *startPtr,
int *endPtr)
}
declare 152 {
void TclSetLibraryPath(Tcl_Obj *pathPtr)
}
declare 153 {
Tcl_Obj *TclGetLibraryPath(void)
}
|
| ︙ | ︙ | |||
638 639 640 641 642 643 644 |
declare 156 {
void TclRegError(Tcl_Interp *interp, const char *msg,
int status)
}
declare 157 {
Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName)
}
| | < | < > | < | < > | | 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 |
declare 156 {
void TclRegError(Tcl_Interp *interp, const char *msg,
int status)
}
declare 157 {
Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName)
}
declare 158 {deprecated {use public Tcl_SetStartupScript()}} {
void TclSetStartupScriptFileName(const char *filename)
}
declare 159 {deprecated {use public Tcl_GetStartupScript()}} {
const char *TclGetStartupScriptFileName(void)
}
#declare 160 {
# int TclpMatchFilesTypes(Tcl_Interp *interp, char *separators,
# Tcl_DString *dirPtr, char *pattern, char *tail,
# GlobTypeData *types)
#}
# new in 8.3.2/8.4a2
declare 161 {
int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan,
Tcl_Obj *cmdObjPtr)
}
declare 162 {
void TclChannelEventScriptInvoker(ClientData clientData, int flags)
}
# ALERT: The result of 'TclGetInstructionTable' is actually a
# "const InstructionDesc*" but we do not want to describe this structure in
# "tclInt.h". It is described in "tclCompile.h". Use a cast to the
# correct type when calling this procedure.
|
| ︙ | ︙ | |||
689 690 691 692 693 694 695 |
# New function due to TIP #33
declare 166 {
int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
int index, Tcl_Obj *valuePtr)
}
| < | < | < > | < | < > | | | | | | 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 |
# New function due to TIP #33
declare 166 {
int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr,
int index, Tcl_Obj *valuePtr)
}
declare 167 {deprecated {use public Tcl_SetStartupScript()}} {
void TclSetStartupScriptPath(Tcl_Obj *pathPtr)
}
declare 168 {deprecated {use public Tcl_GetStartupScript()}} {
Tcl_Obj *TclGetStartupScriptPath(void)
}
# variant of Tcl_UtfNCmp that takes n as bytes, not chars
declare 169 {
int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n)
}
declare 170 {
int TclCheckInterpTraces(Tcl_Interp *interp, const char *command,
int numChars, Command *cmdPtr, int result, int traceFlags,
int objc, Tcl_Obj *const objv[])
}
declare 171 {
int TclCheckExecutionTraces(Tcl_Interp *interp, const char *command,
int numChars, Command *cmdPtr, int result, int traceFlags,
int objc, Tcl_Obj *const objv[])
}
declare 172 {
int TclInThreadExit(void)
}
# added for 8.4.2
declare 173 {
int TclUniCharMatch(const Tcl_UniChar *string, int strLen,
const Tcl_UniChar *pattern, int ptnLen, int flags)
}
# added for 8.4.3
#declare 174 {
# Tcl_Obj *TclIncrWideVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
# Tcl_Obj *part2Ptr, Tcl_WideInt wideIncrAmount, int part1NotParsed)
|
| ︙ | ︙ | |||
743 744 745 746 747 748 749 |
declare 176 {
void TclCleanupVar(Var *varPtr, Var *arrayPtr)
}
declare 177 {
void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2,
const char *operation, const char *reason)
}
| < | | < > | | < > < | | < < > | | < > | 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 |
declare 176 {
void TclCleanupVar(Var *varPtr, Var *arrayPtr)
}
declare 177 {
void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2,
const char *operation, const char *reason)
}
declare 178 {
void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName)
}
declare 179 {
Tcl_Obj *TclGetStartupScript(const char **encodingNamePtr)
}
# REMOVED
# Allocate lists without copying arrays
# declare 180 {
# Tcl_Obj *TclNewListObjDirect(int objc, Tcl_Obj **objv)
# }
#declare 181 {
# Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj **objv,
# const char *file, int line)
#}
declare 182 {deprecated {}} {
struct tm *TclpLocaltime(const time_t *clock)
}
declare 183 {deprecated {}} {
struct tm *TclpGmtime(const time_t *clock)
}
# For the new "Thread Storage" subsystem.
### REMOVED on grounds it should never have been exposed. All these
### functions are now either static in tclThreadStorage.c or
### MODULE_SCOPE.
# declare 184 {
|
| ︙ | ︙ | |||
883 884 885 886 887 888 889 |
declare 213 {
Tcl_Obj *TclGetObjNameOfExecutable(void)
}
declare 214 {
void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding)
}
declare 215 {
| | | 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 |
declare 213 {
Tcl_Obj *TclGetObjNameOfExecutable(void)
}
declare 214 {
void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding)
}
declare 215 {
void *TclStackAlloc(Tcl_Interp *interp, int numBytes)
}
declare 216 {
void TclStackFree(Tcl_Interp *interp, void *freePtr)
}
declare 217 {
int TclPushStackFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr,
Tcl_Namespace *namespacePtr, int isProcCallFrame)
|
| ︙ | ︙ | |||
910 911 912 913 914 915 916 |
Tcl_Obj *TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr,
int keyc, Tcl_Obj *const keyv[], int flags)
}
declare 226 {
int TclObjBeingDeleted(Tcl_Obj *objPtr)
}
declare 227 {
| | | | 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 |
Tcl_Obj *TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr,
int keyc, Tcl_Obj *const keyv[], int flags)
}
declare 226 {
int TclObjBeingDeleted(Tcl_Obj *objPtr)
}
declare 227 {
void TclSetNsPath(Namespace *nsPtr, int pathLength,
Tcl_Namespace *pathAry[])
}
# Used to be needed for TclOO-extension; unneeded now that TclOO is in the
# core and NRE-enabled
# declare 228 {
# int TclObjInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj,
# int skip, ProcErrorProc *errorProc)
# }
declare 229 {
int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr,
const char *myName, int myFlags, int index)
}
declare 230 {
|
| ︙ | ︙ | |||
950 951 952 953 954 955 956 |
declare 234 {
Var *TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key,
int *newPtr)
}
declare 235 {
void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr)
}
| | > | < < < < | | 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 |
declare 234 {
Var *TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key,
int *newPtr)
}
declare 235 {
void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr)
}
declare 236 {deprecated {use Tcl_BackgroundException}} {
void TclBackgroundException(Tcl_Interp *interp, int code)
}
# TIP #285: Script cancellation support.
declare 237 {
int TclResetCancellation(Tcl_Interp *interp, int force)
}
# NRE functions for "rogue" extensions to exploit NRE; they will need to
# include NRE.h too.
declare 238 {
int TclNRInterpProc(ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
}
declare 239 {
int TclNRInterpProcCore(Tcl_Interp *interp, Tcl_Obj *procNameObj,
int skip, ProcErrorProc *errorProc)
}
declare 240 {
|
| ︙ | ︙ | |||
998 999 1000 1001 1002 1003 1004 |
declare 244 {
Tcl_HashTable *TclGetNamespaceChildTable(Tcl_Namespace *nsPtr)
}
declare 245 {
Tcl_HashTable *TclGetNamespaceCommandTable(Tcl_Namespace *nsPtr)
}
declare 246 {
| | | | 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 |
declare 244 {
Tcl_HashTable *TclGetNamespaceChildTable(Tcl_Namespace *nsPtr)
}
declare 245 {
Tcl_HashTable *TclGetNamespaceCommandTable(Tcl_Namespace *nsPtr)
}
declare 246 {
int TclInitRewriteEnsemble(Tcl_Interp *interp, int numRemoved,
int numInserted, Tcl_Obj *const *objv)
}
declare 247 {
void TclResetRewriteEnsemble(Tcl_Interp *interp, int isRootEnsemble)
}
declare 248 {
int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan,
|
| ︙ | ︙ | |||
1022 1023 1024 1025 1026 1027 1028 |
declare 250 {
void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force)
}
# Allow extensions for optimization
declare 251 {
int TclRegisterLiteral(void *envPtr,
| | | 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 |
declare 250 {
void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force)
}
# Allow extensions for optimization
declare 251 {
int TclRegisterLiteral(void *envPtr,
const char *bytes, int length, int flags)
}
# Exporting of the internal API to variables.
declare 252 {
Tcl_Obj *TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr,
Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr,
|
| ︙ | ︙ | |||
1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 |
}
# TIP 431: temporary directory creation function
declare 258 {
Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj)
}
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
# only available on the designated platform.
interface tclIntPlat
################################
# Windows specific functions
declare 0 win {
void TclWinConvertError(DWORD errCode)
}
| > > > > > > > > > < | | < < > | | | < < > | | | < > < | | < < > | | | < > | < | | < > | | | < > | 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 |
}
# TIP 431: temporary directory creation function
declare 258 {
Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj)
}
declare 259 {
unsigned char *TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
int *lengthPtr)
}
declare 260 {
void TclUnusedStubEntry(void)
}
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
# only available on the designated platform.
interface tclIntPlat
################################
# Windows specific functions
declare 0 win {
void TclWinConvertError(DWORD errCode)
}
declare 1 win {
void TclWinConvertWSAError(DWORD errCode)
}
declare 2 win {
struct servent *TclWinGetServByName(const char *nm,
const char *proto)
}
declare 3 win {
int TclWinGetSockOpt(SOCKET s, int level, int optname,
char *optval, int *optlen)
}
declare 4 win {
HINSTANCE TclWinGetTclInstance(void)
}
# new for 8.4.20+/8.5.12+ Cygwin only
declare 5 win {
int TclUnixWaitForFile(int fd, int mask, int timeout)
}
# Removed in 8.1:
# declare 5 win {
# HINSTANCE TclWinLoadLibrary(char *name)
# }
declare 6 win {
unsigned short TclWinNToHS(unsigned short ns)
}
declare 7 win {
int TclWinSetSockOpt(SOCKET s, int level, int optname,
const char *optval, int optlen)
}
declare 8 win {
int TclpGetPid(Tcl_Pid pid)
}
declare 9 win {
int TclWinGetPlatformId(void)
}
# new for 8.4.20+/8.5.12+ Cygwin only
declare 10 win {
Tcl_DirEntry *TclpReaddir(TclDIR *dir)
}
# Removed in 8.3.1 (for Win32s only):
#declare 10 win {
# int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr)
#}
# Pipe channel functions
|
| ︙ | ︙ | |||
1167 1168 1169 1170 1171 1172 1173 |
declare 18 win {
TclFile TclpMakeFile(Tcl_Channel channel, int direction)
}
declare 19 win {
TclFile TclpOpenFile(const char *fname, int mode)
}
declare 20 win {
| | < | | < > < | | < > < | | < > | 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 |
declare 18 win {
TclFile TclpMakeFile(Tcl_Channel channel, int direction)
}
declare 19 win {
TclFile TclpOpenFile(const char *fname, int mode)
}
declare 20 win {
void TclWinAddProcess(HANDLE hProcess, DWORD id)
}
declare 21 win {
char *TclpInetNtoa(struct in_addr addr)
}
# removed permanently for 8.4
#declare 21 win {
# void TclpAsyncMark(Tcl_AsyncHandler async)
#}
# Added in 8.1:
declare 22 win {
TclFile TclpCreateTempFile(const char *contents)
}
# Removed in 8.6:
#declare 23 win {
# char *TclpGetTZName(int isdst)
#}
declare 24 win {
char *TclWinNoBackslash(char *path)
}
# replaced by generic TclGetPlatform
#declare 25 win {
# TclPlatformType *TclWinGetPlatform(void)
#}
declare 26 win {
void TclWinSetInterfaces(int wide)
}
# Added in Tcl 8.3.3 / 8.4
declare 27 win {
void TclWinFlushDirtyChannels(void)
}
# Added in 8.4.2
declare 28 win {
void TclWinResetInterfaces(void)
}
################################
# Unix specific functions
# Pipe channel functions
declare 0 unix {
|
| ︙ | ︙ | |||
1234 1235 1236 1237 1238 1239 1240 |
int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe)
}
declare 4 unix {
int TclpCreateProcess(Tcl_Interp *interp, int argc,
const char **argv, TclFile inputFile, TclFile outputFile,
TclFile errorFile, Tcl_Pid *pidPtr)
}
| < | < < > > < | | > | | | | < < > | | < < > | | < > | | | | | > > > < < | 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 |
int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe)
}
declare 4 unix {
int TclpCreateProcess(Tcl_Interp *interp, int argc,
const char **argv, TclFile inputFile, TclFile outputFile,
TclFile errorFile, Tcl_Pid *pidPtr)
}
declare 5 unix {
int TclUnixWaitForFile_(int fd, int mask, int timeout)
}
declare 6 unix {
TclFile TclpMakeFile(Tcl_Channel channel, int direction)
}
declare 7 unix {
TclFile TclpOpenFile(const char *fname, int mode)
}
declare 8 unix {
int TclUnixWaitForFile(int fd, int mask, int timeout)
}
# Added in 8.1:
declare 9 unix {
TclFile TclpCreateTempFile(const char *contents)
}
# Added in 8.4:
declare 10 unix {
Tcl_DirEntry *TclpReaddir(TclDIR *dir)
}
# Slots 11 and 12 are forwarders for functions that were promoted to
# generic Stubs
declare 11 unix {
struct tm *TclpLocaltime_unix(const time_t *clock)
}
declare 12 unix {
struct tm *TclpGmtime_unix(const time_t *clock)
}
declare 13 unix {
char *TclpInetNtoa(struct in_addr addr)
}
# Added in 8.5:
declare 14 unix {
int TclUnixCopyFile(const char *src, const char *dst,
const Tcl_StatBuf *statBufPtr, int dontCopyAtts)
}
################################
# Mac OS X specific functions
declare 15 {unix macosx} {
int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex,
Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr)
}
declare 16 {unix macosx} {
int TclMacOSXSetFileAttribute(Tcl_Interp *interp, int objIndex,
Tcl_Obj *fileName, Tcl_Obj *attributePtr)
}
declare 17 {unix macosx} {
int TclMacOSXCopyFileAttributes(const char *src, const char *dst,
const Tcl_StatBuf *statBufPtr)
}
declare 18 {unix macosx} {
int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName,
const char *fileName, Tcl_StatBuf *statBufPtr,
Tcl_GlobTypeData *types)
}
declare 19 {unix macosx} {
void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode)
}
declare 22 {unix macosx} {
TclFile TclpCreateTempFile_(const char *contents)
}
declare 29 {win unix} {
int TclWinCPUID(int index, int *regs)
}
# Added in 8.6; core of TclpOpenTemporaryFile
declare 30 {win unix} {
int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj,
Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj)
}
# Local Variables:
# mode: tcl
# End:
|
Changes to generic/tclInt.h.
| ︙ | ︙ | |||
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 | #define _TCLINT /* * Some numerics configuration options. */ #undef ACCEPT_NAN /* * Used to tag functions that are only to be visible within the module being * built and not outside it (where this is supported by the linker). * Also used in the platform-specific *Port.h files. */ #ifndef MODULE_SCOPE # ifdef __cplusplus # define MODULE_SCOPE extern "C" # else # define MODULE_SCOPE extern # endif #endif /* * Common include files needed by most of the Tcl source files are included * here, so that system-dependent personalizations for the include files only * have to be made in once place. This results in a few extra includes, but * greater modularity. The order of the three groups of #includes is * important. For example, stdio.h is needed by tcl.h. */ #include "tclPort.h" #include <stdio.h> #include <ctype.h> | > > > > > > > > > > > > > > > > > > > > > > > > > > > < | | < < > > | 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 |
#define _TCLINT
/*
* Some numerics configuration options.
*/
#undef ACCEPT_NAN
/*
* In Tcl 8.7, stop supporting special hacks for legacy Itcl 3.
* Itcl 4 doesn't need them. Itcl 3 can be updated to not need them
* using the Tcl(Init|Reset)RewriteEnsemble() routines in all Tcl 8.6+
* releases. Perhaps Tcl 8.7 will add even better public interfaces
* supporting all the re-invocation mechanisms extensions like Itcl 3
* need. As an absolute last resort, folks who must make Itcl 3 work
* unchanged with Tcl 8.7 can remove this line to regain the migration
* support. Tcl 9 will no longer offer even that option.
*/
#define AVOID_HACKS_FOR_ITCL 1
/*
* Used to tag functions that are only to be visible within the module being
* built and not outside it (where this is supported by the linker).
* Also used in the platform-specific *Port.h files.
*/
#ifndef MODULE_SCOPE
# ifdef __cplusplus
# define MODULE_SCOPE extern "C"
# else
# define MODULE_SCOPE extern
# endif
#endif
#ifndef JOIN
# define JOIN(a,b) JOIN1(a,b)
# define JOIN1(a,b) a##b
#endif
#if defined(__cplusplus)
# define TCL_UNUSED(T) T
#elif defined(__GNUC__) && (__GNUC__ > 2)
# define TCL_UNUSED(T) T JOIN(dummy, __LINE__) __attribute__((unused))
#else
# define TCL_UNUSED(T) T JOIN(dummy, __LINE__)
#endif
/*
* Common include files needed by most of the Tcl source files are included
* here, so that system-dependent personalizations for the include files only
* have to be made in once place. This results in a few extra includes, but
* greater modularity. The order of the three groups of #includes is
* important. For example, stdio.h is needed by tcl.h.
*/
#include "tclPort.h"
#include <stdio.h>
#include <ctype.h>
#ifdef NO_STDLIB_H
# include "../compat/stdlib.h"
#else
# include <stdlib.h>
#endif
#ifdef NO_STRING_H
#include "../compat/string.h"
#else
#include <string.h>
#endif
#if !defined(STDC_HEADERS) && !defined(__STDC__) && !defined(__C99__FUNC__) \
&& !defined(__cplusplus) && !defined(_MSC_VER) && !defined(__ICC)
typedef int ptrdiff_t;
#endif
#include <stddef.h>
#include <locale.h>
/*
* Ensure WORDS_BIGENDIAN is defined correctly:
* Needs to happen here in addition to configure to work with fat compiles on
* Darwin (where configure runs only once for multiple architectures).
*/
|
| ︙ | ︙ | |||
195 196 197 198 199 200 201 202 203 204 205 206 207 208 | * This flag bit should not interfere with TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, or TCL_LEAVE_ERR_MSG; it signals that the variable * lookup is performed for upvar (or similar) purposes, with slightly * different rules: * - Bug #696893 - variable is either proc-local or in the current * namespace; never follow the second (global) resolution path * - Bug #631741 - do not use special namespace or interp resolvers */ #define TCL_AVOID_RESOLVERS 0x40000 /* *---------------------------------------------------------------- * Data structures related to namespaces. | > > > | 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 | * This flag bit should not interfere with TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, or TCL_LEAVE_ERR_MSG; it signals that the variable * lookup is performed for upvar (or similar) purposes, with slightly * different rules: * - Bug #696893 - variable is either proc-local or in the current * namespace; never follow the second (global) resolution path * - Bug #631741 - do not use special namespace or interp resolvers * * It should also not collide with the (deprecated) TCL_PARSE_PART1 flag * (Bug #835020) */ #define TCL_AVOID_RESOLVERS 0x40000 /* *---------------------------------------------------------------- * Data structures related to namespaces. |
| ︙ | ︙ | |||
267 268 269 270 271 272 273 |
* strings; values have type (Namespace *). */
#else
Tcl_HashTable *childTablePtr;
/* Contains any child namespaces. Indexed by
* strings; values have type (Namespace *). If
* NULL, there are no children. */
#endif
| | | | | | | | | | 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 |
* strings; values have type (Namespace *). */
#else
Tcl_HashTable *childTablePtr;
/* Contains any child namespaces. Indexed by
* strings; values have type (Namespace *). If
* NULL, there are no children. */
#endif
unsigned long nsId; /* Unique id for the namespace. */
Tcl_Interp *interp; /* The interpreter containing this
* namespace. */
int flags; /* OR-ed combination of the namespace status
* flags NS_DYING and NS_DEAD listed below. */
int activationCount; /* Number of "activations" or active call
* frames for this namespace that are on the
* Tcl call stack. The namespace won't be
* freed until activationCount becomes zero. */
unsigned int refCount; /* Count of references by namespaceName
* objects. The namespace can't be freed until
* refCount becomes zero. */
Tcl_HashTable cmdTable; /* Contains all the commands currently
* registered in the namespace. Indexed by
* strings; values have type (Command *).
* Commands imported by Tcl_Import have
* Command structures that point (via an
* ImportedCmdRef structure) to the Command
* structure in the source namespace's command
* table. */
TclVarHashTable varTable; /* Contains all the (global) variables
* currently in this namespace. Indexed by
* strings; values have type (Var *). */
char **exportArrayPtr; /* Points to an array of string patterns
* specifying which commands are exported. A
* pattern may include "string match" style
* wildcard characters to specify multiple
* commands; however, no namespace qualifiers
* are allowed. NULL if no export patterns are
* registered. */
int numExportPatterns; /* Number of export patterns currently
* registered using "namespace export". */
int maxExportPatterns; /* Mumber of export patterns for which space
* is currently allocated. */
unsigned int cmdRefEpoch; /* Incremented if a newly added command
* shadows a command for which this namespace
* has already cached a Command* pointer; this
* causes all its cached Command* pointers to
* be invalidated. */
unsigned int resolverEpoch; /* Incremented whenever (a) the name
* resolution rules change for this namespace
* or (b) a newly added command shadows a
* command that is compiled to bytecodes. This
* invalidates all byte codes compiled in the
* namespace, causing the code to be
* recompiled under the new rules.*/
Tcl_ResolveCmdProc *cmdResProc;
|
| ︙ | ︙ | |||
333 334 335 336 337 338 339 |
Tcl_ResolveCompiledVarProc *compiledVarResProc;
/* If non-null, this procedure overrides the
* usual variable resolution mechanism in Tcl.
* This procedure is invoked within
* LookupCompiledLocal to resolve variable
* references within the namespace at compile
* time. */
| | | | 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 |
Tcl_ResolveCompiledVarProc *compiledVarResProc;
/* If non-null, this procedure overrides the
* usual variable resolution mechanism in Tcl.
* This procedure is invoked within
* LookupCompiledLocal to resolve variable
* references within the namespace at compile
* time. */
unsigned int exportLookupEpoch; /* Incremented whenever a command is added to
* a namespace, removed from a namespace or
* the exports of a namespace are changed.
* Allows TIP#112-driven command lists to be
* validated efficiently. */
Tcl_Ensemble *ensembles; /* List of structures that contain the details
* of the ensembles that are implemented on
* top of this namespace. */
Tcl_Obj *unknownHandlerPtr; /* A script fragment to be used when command
* resolution in this namespace fails. TIP
* 181. */
int commandPathLength; /* The length of the explicit path. */
NamespacePathEntry *commandPathArray;
/* The explicit path of the namespace as an
* array. */
NamespacePathEntry *commandPathSourceList;
/* Linked list of path entries that point to
* this namespace. */
Tcl_NamespaceDeleteProc *earlyDeleteProc;
|
| ︙ | ︙ | |||
434 435 436 437 438 439 440 |
typedef struct EnsembleConfig {
Namespace *nsPtr; /* The namespace backing this ensemble up. */
Tcl_Command token; /* The token for the command that provides
* ensemble support for the namespace, or NULL
* if the command has been deleted (or never
* existed; the global namespace never has an
* ensemble command.) */
| | | 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 |
typedef struct EnsembleConfig {
Namespace *nsPtr; /* The namespace backing this ensemble up. */
Tcl_Command token; /* The token for the command that provides
* ensemble support for the namespace, or NULL
* if the command has been deleted (or never
* existed; the global namespace never has an
* ensemble command.) */
unsigned int epoch; /* The epoch at which this ensemble's table of
* exported commands is valid. */
char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all
* consistent points, this will have the same
* number of entries as there are entries in
* the subcommandTable hash. */
Tcl_HashTable subcommandTable;
/* Hash table of ensemble subcommand names,
|
| ︙ | ︙ | |||
547 548 549 550 551 552 553 |
void *clientData; /* Argument to pass to proc. */
int flags; /* What events the trace procedure is
* interested in: OR-ed combination of
* TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
struct CommandTrace *nextPtr;
/* Next in list of traces associated with a
* particular command. */
| | | 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 |
void *clientData; /* Argument to pass to proc. */
int flags; /* What events the trace procedure is
* interested in: OR-ed combination of
* TCL_TRACE_RENAME, TCL_TRACE_DELETE. */
struct CommandTrace *nextPtr;
/* Next in list of traces associated with a
* particular command. */
unsigned int refCount; /* Used to ensure this structure is not
* deleted too early. Keeps track of how many
* pieces of code have a pointer to this
* structure. */
} CommandTrace;
/*
* When a command trace is active (i.e. its associated procedure is executing)
|
| ︙ | ︙ | |||
610 611 612 613 614 615 616 |
* variable. See below for definitions. */
union {
Tcl_Obj *objPtr; /* The variable's object value. Used for
* scalar variables and array elements. */
TclVarHashTable *tablePtr;/* For array variables, this points to
* information about the hash table used to
* implement the associative array. Points to
| | | | 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 |
* variable. See below for definitions. */
union {
Tcl_Obj *objPtr; /* The variable's object value. Used for
* scalar variables and array elements. */
TclVarHashTable *tablePtr;/* For array variables, this points to
* information about the hash table used to
* implement the associative array. Points to
* ckalloc-ed data. */
struct Var *linkPtr; /* If this is a global variable being referred
* to in a procedure, or a variable created by
* "upvar", this field points to the
* referenced variable's Var struct. */
} value;
} Var;
typedef struct VarInHash {
Var var;
unsigned int refCount; /* Counts number of active uses of this
* variable: 1 for the entry in the hash
* table, 1 for each additional variable whose
* linkPtr points here, 1 for each nested
* trace active on variable, and 1 if the
* variable is a namespace variable. This
* record can't be deleted until refCount
* becomes 0. */
|
| ︙ | ︙ | |||
917 918 919 920 921 922 923 |
*/
typedef struct CompiledLocal {
struct CompiledLocal *nextPtr;
/* Next compiler-recognized local variable for
* this procedure, or NULL if this is the last
* local. */
| | | 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 |
*/
typedef struct CompiledLocal {
struct CompiledLocal *nextPtr;
/* Next compiler-recognized local variable for
* this procedure, or NULL if this is the last
* local. */
int nameLength; /* The number of bytes in local variable's name.
* Among others used to speed up var lookups. */
int frameIndex; /* Index in the array of compiler-assigned
* variables in the procedure call frame. */
int flags; /* Flag bits for the local variable. Same as
* the flags for the Var structure above,
* although only VAR_ARGUMENT, VAR_TEMPORARY,
* and VAR_RESOLVED make sense. */
|
| ︙ | ︙ | |||
951 952 953 954 955 956 957 |
* collection of Tcl commands plus information about arguments and other local
* variables recognized at compile time.
*/
typedef struct Proc {
struct Interp *iPtr; /* Interpreter for which this command is
* defined. */
| | | 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 |
* collection of Tcl commands plus information about arguments and other local
* variables recognized at compile time.
*/
typedef struct Proc {
struct Interp *iPtr; /* Interpreter for which this command is
* defined. */
unsigned int refCount; /* Reference count: 1 if still present in
* command table plus 1 for each call to the
* procedure that is currently active. This
* structure can be freed when refCount
* becomes zero. */
struct Command *cmdPtr; /* Points to the Command structure for this
* procedure. This is used to get the
* namespace in which to execute the
|
| ︙ | ︙ | |||
1068 1069 1070 1071 1072 1073 1074 |
/*
* Will be grown to contain: pointers to the varnames (allocated at the end),
* plus the init values for each variable (suitable to be memcopied on init)
*/
typedef struct LocalCache {
| | | 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 |
/*
* Will be grown to contain: pointers to the varnames (allocated at the end),
* plus the init values for each variable (suitable to be memcopied on init)
*/
typedef struct LocalCache {
unsigned int refCount;
int numVars;
Tcl_Obj *varName0;
} LocalCache;
#define localName(framePtr, i) \
((&((framePtr)->localCachePtr->varName0))[(i)])
|
| ︙ | ︙ | |||
1223 1224 1225 1226 1227 1228 1229 |
struct {
const void *codePtr;/* Byte code currently executed... */
const char *pc; /* ... and instruction pointer. */
} tebc;
} data;
Tcl_Obj *cmdObj;
const char *cmd; /* The executed command, if possible... */
| | | | | 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 |
struct {
const void *codePtr;/* Byte code currently executed... */
const char *pc; /* ... and instruction pointer. */
} tebc;
} data;
Tcl_Obj *cmdObj;
const char *cmd; /* The executed command, if possible... */
int len; /* ... and its length. */
const struct CFWordBC *litarg;
/* Link to set of literal arguments which have
* ben pushed on the lineLABCPtr stack by
* TclArgumentBCEnter(). These will be removed
* by TclArgumentBCRelease. */
} CmdFrame;
typedef struct CFWord {
CmdFrame *framePtr; /* CmdFrame to access. */
int word; /* Index of the word in the command. */
unsigned int refCount; /* Number of times the word is on the
* stack. */
} CFWord;
typedef struct CFWordBC {
CmdFrame *framePtr; /* CmdFrame to access. */
int pc; /* Instruction pointer of a command in
* ExtCmdLoc.loc[.] */
int word; /* Index of word in
* ExtCmdLoc.loc[cmd]->line[.] */
struct CFWordBC *prevPtr; /* Previous entry in stack for same Tcl_Obj. */
struct CFWordBC *nextPtr; /* Next entry for same command call. See
* CmdFrame litarg field for the list start. */
Tcl_Obj *obj; /* Back reference to hashtable key */
|
| ︙ | ︙ | |||
1321 1322 1323 1324 1325 1326 1327 |
GetFrameInfoValueProc *proc; /* Function to generate a Tcl_Obj* from the
* clientData, or just use the clientData
* directly (after casting) if NULL. */
void *clientData; /* Context for above function, or Tcl_Obj* if
* proc field is NULL. */
} ExtraFrameInfoField;
typedef struct {
| | | 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 |
GetFrameInfoValueProc *proc; /* Function to generate a Tcl_Obj* from the
* clientData, or just use the clientData
* directly (after casting) if NULL. */
void *clientData; /* Context for above function, or Tcl_Obj* if
* proc field is NULL. */
} ExtraFrameInfoField;
typedef struct {
int length; /* Length of array. */
ExtraFrameInfoField fields[2];
/* Really as long as necessary, but this is
* long enough for nearly anything. */
} ExtraFrameInfo;
/*
*----------------------------------------------------------------
|
| ︙ | ︙ | |||
1362 1363 1364 1365 1366 1367 1368 | void *data); /* * This is a convenience macro used to initialize a thread local storage ptr. */ #define TCL_TSD_INIT(keyPtr) \ | | | 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 | void *data); /* * This is a convenience macro used to initialize a thread local storage ptr. */ #define TCL_TSD_INIT(keyPtr) \ (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData)) /* *---------------------------------------------------------------- * Data structures related to bytecode compilation and execution. These are * used primarily in tclCompile.c, tclExecute.c, and tclBasic.c. *---------------------------------------------------------------- */ |
| ︙ | ︙ | |||
1410 1411 1412 1413 1414 1415 1416 | /* * The type of procedure called from the compilation hook point in * SetByteCodeFromAny. */ typedef int (CompileHookProc)(Tcl_Interp *interp, | | | 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 |
/*
* The type of procedure called from the compilation hook point in
* SetByteCodeFromAny.
*/
typedef int (CompileHookProc)(Tcl_Interp *interp,
struct CompileEnv *compEnvPtr, ClientData clientData);
/*
* The data structure for a (linked list of) execution stacks.
*/
typedef struct ExecStack {
struct ExecStack *prevPtr;
|
| ︙ | ︙ | |||
1497 1498 1499 1500 1501 1502 1503 |
typedef struct LiteralEntry {
struct LiteralEntry *nextPtr;
/* Points to next entry in this hash bucket or
* NULL if end of chain. */
Tcl_Obj *objPtr; /* Points to Tcl object that holds the
* literal's bytes and length. */
| | | | | | | | 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 |
typedef struct LiteralEntry {
struct LiteralEntry *nextPtr;
/* Points to next entry in this hash bucket or
* NULL if end of chain. */
Tcl_Obj *objPtr; /* Points to Tcl object that holds the
* literal's bytes and length. */
unsigned int refCount; /* If in an interpreter's global literal
* table, the number of ByteCode structures
* that share the literal object; the literal
* entry can be freed when refCount drops to
* 0. If in a local literal table, (unsigned)-1. */
Namespace *nsPtr; /* Namespace in which this literal is used. We
* try to avoid sharing literal non-FQ command
* names among different namespaces to reduce
* shimmering. */
} LiteralEntry;
typedef struct LiteralTable {
LiteralEntry **buckets; /* Pointer to bucket array. Each element
* points to first entry in bucket's hash
* chain, or NULL. */
LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE];
/* Bucket array used for small tables to avoid
* mallocs and frees. */
unsigned int numBuckets; /* Total number of buckets allocated at
* **buckets. */
unsigned int numEntries; /* Total number of entries present in
* table. */
unsigned int rebuildSize; /* Enlarge table when numEntries gets to be
* this large. */
unsigned int mask; /* Mask value used in hashing function. */
} LiteralTable;
/*
* The following structure defines for each Tcl interpreter various
* statistics-related information about the bytecode compiler and
* interpreter's operation in that interpreter.
*/
|
| ︙ | ︙ | |||
1639 1640 1641 1642 1643 1644 1645 |
* from its Tcl_Command handle. NULL means
* that the hash table entry has been removed
* already (this can happen if deleteProc
* causes the command to be deleted or
* recreated). */
Namespace *nsPtr; /* Points to the namespace containing this
* command. */
| | | | 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 |
* from its Tcl_Command handle. NULL means
* that the hash table entry has been removed
* already (this can happen if deleteProc
* causes the command to be deleted or
* recreated). */
Namespace *nsPtr; /* Points to the namespace containing this
* command. */
unsigned int refCount; /* 1 if in command hashtable plus 1 for each
* reference from a CmdName Tcl object
* representing a command's name in a ByteCode
* instruction sequence. This structure can be
* freed when refCount becomes zero. */
unsigned int cmdEpoch; /* Incremented to invalidate any references
* that point to this command when it is
* renamed, deleted, hidden, or exposed. */
CompileProc *compileProc; /* Procedure called to compile command. NULL
* if no compile proc exists for command. */
Tcl_ObjCmdProc *objProc; /* Object-based command procedure. */
void *objClientData; /* Arbitrary value passed to object proc. */
Tcl_CmdProc *proc; /* String-based command procedure. */
|
| ︙ | ︙ | |||
1764 1765 1766 1767 1768 1769 1770 |
*----------------------------------------------------------------
*/
typedef struct AllocCache {
struct Cache *nextPtr; /* Linked list of cache entries. */
Tcl_ThreadId owner; /* Which thread's cache is this? */
Tcl_Obj *firstObjPtr; /* List of free objects for thread. */
| | | | | < > | | | | > > > > > | > > | > > > > > > | | | | < | < | < > | > > > > > > > | 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 |
*----------------------------------------------------------------
*/
typedef struct AllocCache {
struct Cache *nextPtr; /* Linked list of cache entries. */
Tcl_ThreadId owner; /* Which thread's cache is this? */
Tcl_Obj *firstObjPtr; /* List of free objects for thread. */
int numObjects; /* Number of objects for thread. */
} AllocCache;
/*
*----------------------------------------------------------------
* This structure defines an interpreter, which is a collection of commands
* plus other state information related to interpreting commands, such as
* variable storage. Primary responsibility for this data structure is in
* tclBasic.c, but almost every Tcl source file uses something in here.
*----------------------------------------------------------------
*/
typedef struct Interp {
/*
* Note: the first three fields must match exactly the fields in a
* Tcl_Interp struct (see tcl.h). If you change one, be sure to change the
* other.
*
* The interpreter's result is held in both the string and the
* objResultPtr fields. These fields hold, respectively, the result's
* string or object value. The interpreter's result is always in the
* result field if that is non-empty, otherwise it is in objResultPtr.
* The two fields are kept consistent unless some C code sets
* interp->result directly. Programs should not access result and
* objResultPtr directly; instead, they should always get and set the
* result using procedures such as Tcl_SetObjResult, Tcl_GetObjResult, and
* Tcl_GetStringResult. See the SetResult man page for details.
*/
char *result; /* If the last command returned a string
* result, this points to it. Should not be
* accessed directly; see comment above. */
Tcl_FreeProc *freeProc; /* Zero means a string result is statically
* allocated. TCL_DYNAMIC means string result
* was allocated with ckalloc and should be
* freed with ckfree. Other values give
* address of procedure to invoke to free the
* string result. Tcl_Eval must free it before
* executing next command. */
int errorLine; /* When TCL_ERROR is returned, this gives the
* line number in the command where the error
* occurred (1 means first line). */
const struct TclStubs *stubTable;
/* Pointer to the exported Tcl stub table. On
* previous versions of Tcl this is a pointer
* to the objResultPtr or a pointer to a
* buckets array in a hash table. We therefore
* have to do some careful checking before we
* can use this. */
TclHandle handle; /* Handle used to keep track of when this
* interp is deleted. */
Namespace *globalNsPtr; /* The interpreter's global namespace. */
Tcl_HashTable *hiddenCmdTablePtr;
/* Hash table used by tclBasic.c to keep track
* of hidden commands on a per-interp
* basis. */
void *interpInfo; /* Information used by tclInterp.c to keep
* track of master/slave interps on a
* per-interp basis. */
union {
void (*optimizer)(void *envPtr);
Tcl_HashTable unused2; /* No longer used (was mathFuncTable). The
* unused space in interp was repurposed for
* pluggable bytecode optimizers. The core
* contains one optimizer, which can be
* selectively overridden by extensions. */
} extra;
/*
* Information related to procedures and variables. See tclProc.c and
* tclVar.c for usage.
*/
int numLevels; /* Keeps track of how many nested calls to
* Tcl_Eval are in progress for this
|
| ︙ | ︙ | |||
1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 |
* or NULL if no active traces. */
int returnCode; /* [return -code] parameter. */
CallFrame *rootFramePtr; /* Global frame pointer for this
* interpreter. */
Namespace *lookupNsPtr; /* Namespace to use ONLY on the next
* TCL_EVAL_INVOKE call to Tcl_EvalObjv. */
/*
* Information about packages. Used only in tclPkg.c.
*/
Tcl_HashTable packageTable; /* Describes all of the packages loaded in or
* available to this interpreter. Keys are
* package names, values are (Package *)
* pointers. */
char *packageUnknown; /* Command to invoke during "package require"
* commands for packages that aren't described
* in packageTable. Ckalloc'ed, may be
* NULL. */
/*
* Miscellaneous information:
*/
| > > > > > > > > > > > > > > > > > > > | > | | 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 |
* or NULL if no active traces. */
int returnCode; /* [return -code] parameter. */
CallFrame *rootFramePtr; /* Global frame pointer for this
* interpreter. */
Namespace *lookupNsPtr; /* Namespace to use ONLY on the next
* TCL_EVAL_INVOKE call to Tcl_EvalObjv. */
/*
* Information used by Tcl_AppendResult to keep track of partial results.
* See Tcl_AppendResult code for details.
*/
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
char *appendResult; /* Storage space for results generated by
* Tcl_AppendResult. Ckalloc-ed. NULL means
* not yet allocated. */
int appendAvl; /* Total amount of space available at
* partialResult. */
int appendUsed; /* Number of non-null bytes currently stored
* at partialResult. */
#else
char *appendResultDontUse;
int appendAvlDontUse;
int appendUsedDontUse;
#endif
/*
* Information about packages. Used only in tclPkg.c.
*/
Tcl_HashTable packageTable; /* Describes all of the packages loaded in or
* available to this interpreter. Keys are
* package names, values are (Package *)
* pointers. */
char *packageUnknown; /* Command to invoke during "package require"
* commands for packages that aren't described
* in packageTable. Ckalloc'ed, may be
* NULL. */
/*
* Miscellaneous information:
*/
int cmdCount; /* Total number of times a command procedure
* has been called for this interpreter. */
int evalFlags; /* Flags to control next call to Tcl_Eval.
* Normally zero, but may be set before
* calling Tcl_Eval. See below for valid
* values. */
int unused1; /* No longer used (was termOffset) */
LiteralTable literalTable; /* Contains LiteralEntry's describing all Tcl
* objects holding literals of scripts
* compiled by the interpreter. Indexed by the
* string representations of literals. Used to
* avoid creating duplicate objects. */
unsigned int compileEpoch; /* Holds the current "compilation epoch" for
* this interpreter. This is incremented to
* invalidate existing ByteCodes when, e.g., a
* command with a compile procedure is
* redefined. */
Proc *compiledProcPtr; /* If a procedure is being compiled, a pointer
* to its Proc structure; otherwise, this is
* NULL. Set by ObjInterpProc in tclProc.c and
|
| ︙ | ︙ | |||
1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 |
struct ExecEnv *execEnvPtr; /* Execution environment for Tcl bytecode
* execution. Contains a pointer to the Tcl
* evaluation stack. */
Tcl_Obj *emptyObjPtr; /* Points to an object holding an empty
* string. Returned by Tcl_ObjSetVar2 when
* variable traces change a variable in a
* gross way. */
Tcl_Obj *objResultPtr; /* If the last command returned an object
* result, this points to it. Should not be
* accessed directly; see comment above. */
Tcl_ThreadId threadId; /* ID of thread that owns the interpreter. */
ActiveCommandTrace *activeCmdTracePtr;
/* First in list of active command traces for
| > > > > > > > > | 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 |
struct ExecEnv *execEnvPtr; /* Execution environment for Tcl bytecode
* execution. Contains a pointer to the Tcl
* evaluation stack. */
Tcl_Obj *emptyObjPtr; /* Points to an object holding an empty
* string. Returned by Tcl_ObjSetVar2 when
* variable traces change a variable in a
* gross way. */
#if TCL_MAJOR_VERSION < 9
# if !defined(TCL_NO_DEPRECATED)
char resultSpace[TCL_DSTRING_STATIC_SIZE+1];
/* Static space holding small results. */
# else
char resultSpaceDontUse[TCL_DSTRING_STATIC_SIZE+1];
# endif
#endif
Tcl_Obj *objResultPtr; /* If the last command returned an object
* result, this points to it. Should not be
* accessed directly; see comment above. */
Tcl_ThreadId threadId; /* ID of thread that owns the interpreter. */
ActiveCommandTrace *activeCmdTracePtr;
/* First in list of active command traces for
|
| ︙ | ︙ | |||
1945 1946 1947 1948 1949 1950 1951 | * set. */ int granularityTicker; /* Counter used to determine how often to * check the limits. */ int exceeded; /* Which limits have been exceeded, described * as flag values the same as the 'active' * field. */ | | | 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 | * set. */ int granularityTicker; /* Counter used to determine how often to * check the limits. */ int exceeded; /* Which limits have been exceeded, described * as flag values the same as the 'active' * field. */ int cmdCount; /* Limit for how many commands to execute in * the interpreter. */ LimitHandler *cmdHandlers; /* Handlers to execute when the limit is * reached. */ int cmdGranularity; /* Mod factor used to determine how often to * evaluate the limit check. */ |
| ︙ | ︙ | |||
1981 1982 1983 1984 1985 1986 1987 |
struct {
Tcl_Obj *const *sourceObjs;
/* What arguments were actually input into the
* *root* ensemble command? (Nested ensembles
* don't rewrite this.) NULL if we're not
* processing an ensemble. */
| | | | 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 |
struct {
Tcl_Obj *const *sourceObjs;
/* What arguments were actually input into the
* *root* ensemble command? (Nested ensembles
* don't rewrite this.) NULL if we're not
* processing an ensemble. */
int numRemovedObjs; /* How many arguments have been stripped off
* because of ensemble processing. */
int numInsertedObjs; /* How many of the current arguments were
* inserted by an ensemble. */
} ensembleRewrite;
/*
* TIP #219: Global info for the I/O system.
*/
|
| ︙ | ︙ | |||
2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 | * other than these should be turned into errors. */ #define TCL_ALLOW_EXCEPTIONS 0x04 #define TCL_EVAL_FILE 0x02 #define TCL_EVAL_SOURCE_IN_FRAME 0x10 #define TCL_EVAL_NORESOLVE 0x20 /* * Flag bits for Interp structures: * * DELETED: Non-zero means the interpreter has been deleted: * don't process any more commands for it, and destroy * the structure as soon as all nested invocations of | > | 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 | * other than these should be turned into errors. */ #define TCL_ALLOW_EXCEPTIONS 0x04 #define TCL_EVAL_FILE 0x02 #define TCL_EVAL_SOURCE_IN_FRAME 0x10 #define TCL_EVAL_NORESOLVE 0x20 #define TCL_EVAL_DISCARD_RESULT 0x40 /* * Flag bits for Interp structures: * * DELETED: Non-zero means the interpreter has been deleted: * don't process any more commands for it, and destroy * the structure as soon as all nested invocations of |
| ︙ | ︙ | |||
2299 2300 2301 2302 2303 2304 2305 | #define TCL_ALIGN(x) (((int)(x) + 7) & ~7) /* * A common panic alert when memory allocation fails. */ #define TclOOM(ptr, size) \ | | | 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 |
#define TCL_ALIGN(x) (((int)(x) + 7) & ~7)
/*
* A common panic alert when memory allocation fails.
*/
#define TclOOM(ptr, size) \
((size) && ((ptr)||(Tcl_Panic("unable to alloc %u bytes", (size)),1)))
/*
* The following enum values are used to specify the runtime platform setting
* of the tclPlatform variable.
*/
typedef enum {
|
| ︙ | ︙ | |||
2352 2353 2354 2355 2356 2357 2358 |
* struct is grown (reallocated and copied) as necessary to hold all the
* list's element pointers. The struct might contain more slots than currently
* used to hold all element pointers. This is done to make append operations
* faster.
*/
typedef struct List {
| | | | 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 |
* struct is grown (reallocated and copied) as necessary to hold all the
* list's element pointers. The struct might contain more slots than currently
* used to hold all element pointers. This is done to make append operations
* faster.
*/
typedef struct List {
unsigned int refCount;
int maxElemCount; /* Total number of element array slots. */
int elemCount; /* Current number of list elements. */
int canonicalFlag; /* Set if the string representation was
* derived from the list representation. May
* be ignored if there is no string rep at
* all.*/
Tcl_Obj *elements; /* First list element; the struct is grown to
* accommodate all elements. */
} List;
#define LIST_MAX \
(1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *)))
#define LIST_SIZE(numElems) \
(unsigned)(sizeof(List) + (((numElems) - 1) * sizeof(Tcl_Obj *)))
/*
* Macro used to get the elements of a list object.
*/
#define ListRepPtr(listPtr) \
((List *) (listPtr)->internalRep.twoPtrValue.ptr1)
|
| ︙ | ︙ | |||
2415 2416 2417 2418 2419 2420 2421 | * Tcl_GetBooleanFromObj, Tcl_GetLongFromObj, Tcl_GetIntFromObj * and Tcl_GetIntForIndex. * * WARNING: these macros eval their args more than once. */ #define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ | | > | | | 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 |
* Tcl_GetBooleanFromObj, Tcl_GetLongFromObj, Tcl_GetIntFromObj
* and Tcl_GetIntForIndex.
*
* WARNING: these macros eval their args more than once.
*/
#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \
(((objPtr)->typePtr == &tclIntType) \
? (*(boolPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \
: ((objPtr)->typePtr == &tclBooleanType) \
? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \
: Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr)))
#ifdef TCL_WIDE_INT_IS_LONG
#define TclGetLongFromObj(interp, objPtr, longPtr) \
(((objPtr)->typePtr == &tclIntType) \
? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
|
| ︙ | ︙ | |||
2441 2442 2443 2444 2445 2446 2447 |
#define TclGetIntFromObj(interp, objPtr, intPtr) \
(((objPtr)->typePtr == &tclIntType \
&& (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(INT_MIN) \
&& (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \
? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
| | | | < | 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 |
#define TclGetIntFromObj(interp, objPtr, intPtr) \
(((objPtr)->typePtr == &tclIntType \
&& (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(INT_MIN) \
&& (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \
? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
((((objPtr)->typePtr == &tclIntType) && ((objPtr)->internalRep.wideValue >= 0) \
&& ((Tcl_WideUInt)(objPtr)->internalRep.wideValue <= (Tcl_WideUInt)(endValue + 1))) \
? ((*(idxPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))
/*
* Macro used to save a function call for common uses of
* Tcl_GetWideIntFromObj(). The ANSI C "prototype" is:
*
* MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
|
| ︙ | ︙ | |||
2502 2503 2504 2505 2506 2507 2508 | * been thoroughly tested and investigated a new public filesystem interface * will be released. The aim is more versatile virtual filesystem interfaces, * more efficiency in 'path' manipulation and usage, and cleaner filesystem * code internally. */ #define TCL_FILESYSTEM_VERSION_2 ((Tcl_FSVersion) 0x2) | | | 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 | * been thoroughly tested and investigated a new public filesystem interface * will be released. The aim is more versatile virtual filesystem interfaces, * more efficiency in 'path' manipulation and usage, and cleaner filesystem * code internally. */ #define TCL_FILESYSTEM_VERSION_2 ((Tcl_FSVersion) 0x2) typedef ClientData (TclFSGetCwdProc2)(ClientData clientData); typedef int (Tcl_FSLoadFileProc2) (Tcl_Interp *interp, Tcl_Obj *pathPtr, Tcl_LoadHandle *handlePtr, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); /* * The following types are used for getting and storing platform-specific file * attributes in tclFCmd.c and the various platform-versions of that file. * This is done to have as much common code as possible in the file attributes |
| ︙ | ︙ | |||
2583 2584 2585 2586 2587 2588 2589 | /* *---------------------------------------------------------------- * Data structures for process-global values. *---------------------------------------------------------------- */ | | | | | 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 |
/*
*----------------------------------------------------------------
* Data structures for process-global values.
*----------------------------------------------------------------
*/
typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, unsigned int *lengthPtr,
Tcl_Encoding *encodingPtr);
/*
* A ProcessGlobalValue struct exists for each internal value in Tcl that is
* to be shared among several threads. Each thread sees a (Tcl_Obj) copy of
* the value, and the master is kept as a counted string, with epoch and mutex
* control. Each ProcessGlobalValue struct should be a static variable in some
* file.
*/
typedef struct ProcessGlobalValue {
unsigned int epoch; /* Epoch counter to detect changes in the
* master value. */
unsigned int numBytes; /* Length of the master string. */
char *value; /* The master string value. */
Tcl_Encoding encoding; /* system encoding when master string was
* initialized. */
TclInitProcessGlobalValueProc *proc;
/* A procedure to initialize the master string
* copy when a "get" request comes in before
* any "set" request has been received. */
|
| ︙ | ︙ | |||
2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 | #define TCL_PARSE_SCAN_PREFIXES 16 /* Use [scan] rules dealing with 0? * prefixes. */ #define TCL_PARSE_NO_WHITESPACE 32 /* Reject leading/trailing whitespace. */ #define TCL_PARSE_BINARY_ONLY 64 /* Parse binary even without prefix. */ /* *---------------------------------------------------------------------- * Type values TclGetNumberFromObj *---------------------------------------------------------------------- */ #define TCL_NUMBER_INT 2 #define TCL_NUMBER_BIG 3 #define TCL_NUMBER_DOUBLE 4 #define TCL_NUMBER_NAN 5 /* *---------------------------------------------------------------- * Variables shared among Tcl modules but not used by the outside world. | > > > > > > | 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 | #define TCL_PARSE_SCAN_PREFIXES 16 /* Use [scan] rules dealing with 0? * prefixes. */ #define TCL_PARSE_NO_WHITESPACE 32 /* Reject leading/trailing whitespace. */ #define TCL_PARSE_BINARY_ONLY 64 /* Parse binary even without prefix. */ #define TCL_PARSE_NO_UNDERSCORE 128 /* Reject underscore digit separator */ /* *---------------------------------------------------------------------- * Type values TclGetNumberFromObj *---------------------------------------------------------------------- */ #define TCL_NUMBER_INT 2 #if (TCL_MAJOR_VERSION < 9) && !defined(TCL_NO_DEPRECATED) # define TCL_NUMBER_LONG 1 /* deprecated, not used any more */ # define TCL_NUMBER_WIDE TCL_NUMBER_INT /* deprecated */ #endif #define TCL_NUMBER_BIG 3 #define TCL_NUMBER_DOUBLE 4 #define TCL_NUMBER_NAN 5 /* *---------------------------------------------------------------- * Variables shared among Tcl modules but not used by the outside world. |
| ︙ | ︙ | |||
2666 2667 2668 2669 2670 2671 2672 | /* * TIP #233 (Virtualized Time) * Data for the time hooks, if any. */ MODULE_SCOPE Tcl_GetTimeProc *tclGetTimeProcPtr; MODULE_SCOPE Tcl_ScaleTimeProc *tclScaleTimeProcPtr; | | | 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 | /* * TIP #233 (Virtualized Time) * Data for the time hooks, if any. */ MODULE_SCOPE Tcl_GetTimeProc *tclGetTimeProcPtr; MODULE_SCOPE Tcl_ScaleTimeProc *tclScaleTimeProcPtr; MODULE_SCOPE ClientData tclTimeClientData; /* * Variables denoting the Tcl object types defined in the core. */ MODULE_SCOPE const Tcl_ObjType tclBignumType; MODULE_SCOPE const Tcl_ObjType tclBooleanType; |
| ︙ | ︙ | |||
2801 2802 2803 2804 2805 2806 2807 |
* loaded module */
Tcl_FSUnloadFileProc* unloadFileProcPtr;
/* Procedure that unloads a loaded module */
};
/* Flags for conversion of doubles to digit strings */
| < < < | | < | | | | | | > > | | | | | | | 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 |
* loaded module */
Tcl_FSUnloadFileProc* unloadFileProcPtr;
/* Procedure that unloads a loaded module */
};
/* Flags for conversion of doubles to digit strings */
#define TCL_DD_E_FORMAT 0x2
/* Use a fixed-length string of digits,
* suitable for E format*/
#define TCL_DD_F_FORMAT 0x3
/* Use a fixed number of digits after the
* decimal point, suitable for F format */
#define TCL_DD_SHORTEST 0x4
/* Use the shortest possible string */
#define TCL_DD_NO_QUICK 0x8
/* Debug flag: forbid quick FP conversion */
#define TCL_DD_CONVERSION_TYPE_MASK 0x3
/* Mask to isolate the conversion type */
/*
*----------------------------------------------------------------
* Procedures shared among Tcl modules but not used by the outside world:
*----------------------------------------------------------------
*/
MODULE_SCOPE void TclAppendBytesToByteArray(Tcl_Obj *objPtr,
const unsigned char *bytes, int len);
MODULE_SCOPE int TclNREvalCmd(Tcl_Interp *interp, Tcl_Obj *objPtr,
int flags);
MODULE_SCOPE void TclAdvanceContinuations(int *line, int **next,
int loc);
MODULE_SCOPE void TclAdvanceLines(int *line, const char *start,
const char *end);
MODULE_SCOPE void TclArgumentEnter(Tcl_Interp *interp,
Tcl_Obj *objv[], int objc, CmdFrame *cf);
MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp,
Tcl_Obj *objv[], int objc);
MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp,
Tcl_Obj *objv[], int objc,
void *codePtr, CmdFrame *cfPtr, int cmd, int pc);
MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp,
CmdFrame *cfPtr);
MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj,
CmdFrame **cfPtrPtr, int *wordPtr);
MODULE_SCOPE double TclBignumToDouble(const void *bignum);
MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string,
int strLen, const unsigned char *pattern,
int ptnLen, int flags);
MODULE_SCOPE double TclCeil(const void *a);
MODULE_SCOPE void TclChannelPreserve(Tcl_Channel chan);
MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan);
MODULE_SCOPE int TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr,
Var *arrayPtr, Tcl_Obj *name, int index);
MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp,
const char *value);
MODULE_SCOPE int TclCheckEmptyString(Tcl_Obj *objPtr);
MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp,
Tcl_Channel chan);
MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd;
MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble;
MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr,
Tcl_Obj *value2Ptr);
MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num,
int *loc);
MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr,
int start, int *clNext);
MODULE_SCOPE ContLineLoc *TclContinuationsGet(Tcl_Obj *objPtr);
MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr,
Tcl_Obj *originObjPtr);
MODULE_SCOPE int TclConvertElement(const char *src, int length,
char *dst, int flags);
MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs(Tcl_Interp *interp,
const char *cmdName, Tcl_Namespace *nsPtr,
Tcl_ObjCmdProc *proc, ClientData clientData,
Tcl_CmdDeleteProc *deleteProc);
MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp,
const char *name, Tcl_Namespace *nameNamespacePtr,
Tcl_Namespace *ensembleNamespacePtr, int flags);
MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr);
MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp,
const char *dict, int dictLength,
const char **elementPtr, const char **nextPtr,
int *sizePtr, int *literalPtr);
/* TIP #280 - Modified token based evaluation, with line information. */
MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script,
int numBytes, int flags, int line,
int *clNextOuter, const char *outerScript);
MODULE_SCOPE Tcl_ObjCmdProc TclFileAttrsCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileCopyCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileDeleteCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileLinkCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileMakeDirsCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileReadLinkCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileTempDirCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd;
MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc,
ClientData clientData);
MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc,
ClientData clientData);
MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr,
Tcl_Obj *objPtr);
MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr,
Tcl_DString *toAppendPtr);
MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr);
MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp,
Tcl_Obj *const *objv, int objc, int *objcPtr);
|
| ︙ | ︙ | |||
2929 2930 2931 2932 2933 2934 2935 | MODULE_SCOPE void TclFinalizePreserve(void); MODULE_SCOPE void TclFinalizeSynchronization(void); MODULE_SCOPE void TclInitThreadAlloc(void); MODULE_SCOPE void TclFinalizeThreadAlloc(void); MODULE_SCOPE void TclFinalizeThreadAllocThread(void); MODULE_SCOPE void TclFinalizeThreadData(int quick); MODULE_SCOPE void TclFinalizeThreadObjects(void); | | | | | | | | | | < < < | | 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 | MODULE_SCOPE void TclFinalizePreserve(void); MODULE_SCOPE void TclFinalizeSynchronization(void); MODULE_SCOPE void TclInitThreadAlloc(void); MODULE_SCOPE void TclFinalizeThreadAlloc(void); MODULE_SCOPE void TclFinalizeThreadAllocThread(void); MODULE_SCOPE void TclFinalizeThreadData(int quick); MODULE_SCOPE void TclFinalizeThreadObjects(void); MODULE_SCOPE double TclFloor(const void *a); MODULE_SCOPE void TclFormatNaN(double value, char *buffer); MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, const char *attributeName, int *indexPtr); MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs(Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *nsPtr, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *encodingName); MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle); MODULE_SCOPE int * TclGetAsyncReadyPtr(void); MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp); MODULE_SCOPE int TclGetChannelFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Channel *chanPtr, int *modePtr, int flags); MODULE_SCOPE CmdFrame * TclGetCmdFrameForProcedure(Proc *procPtr); MODULE_SCOPE int TclGetCompletionCodeFromObj(Tcl_Interp *interp, Tcl_Obj *value, int *code); MODULE_SCOPE Proc * TclGetLambdaFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **nsObjPtrPtr); MODULE_SCOPE int TclGetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientDataPtr, int *typePtr); MODULE_SCOPE int TclGetOpenModeEx(Tcl_Interp *interp, const char *modeString, int *seekFlagPtr, int *binaryPtr); MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, unsigned int *sizePtr); MODULE_SCOPE int TclGetLoadedPackagesEx(Tcl_Interp *interp, const char *targetName, const char *packageName); MODULE_SCOPE int TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *, Tcl_WideInt *); MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, Tcl_GlobTypeData *types); MODULE_SCOPE int TclIncrObj(Tcl_Interp *interp, Tcl_Obj *valuePtr, Tcl_Obj *incrPtr); MODULE_SCOPE Tcl_Obj * TclIncrObjVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, int flags); MODULE_SCOPE int TclInfoExistsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclInfoCoroutineCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr); MODULE_SCOPE int TclInfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclInfoLocalsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclInfoVarsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE void TclInitAlloc(void); MODULE_SCOPE void TclInitDbCkalloc(void); MODULE_SCOPE void TclInitDoubleConversion(void); MODULE_SCOPE void TclInitEmbeddedConfigurationInformation( Tcl_Interp *interp); MODULE_SCOPE void TclInitEncodingSubsystem(void); MODULE_SCOPE void TclInitIOSubsystem(void); MODULE_SCOPE void TclInitLimitSupport(Tcl_Interp *interp); MODULE_SCOPE void TclInitNamespaceSubsystem(void); MODULE_SCOPE void TclInitNotifier(void); MODULE_SCOPE void TclInitObjSubsystem(void); MODULE_SCOPE int TclInterpReady(Tcl_Interp *interp); MODULE_SCOPE int TclIsDigitProc(int byte); MODULE_SCOPE int TclIsBareword(int byte); MODULE_SCOPE Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[], int forceRelative); MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *argPtr); |
| ︙ | ︙ | |||
3023 3024 3025 3026 3027 3028 3029 | MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *indexPtr, Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, int indexCount, Tcl_Obj *const indexArray[], Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name, const EnsembleImplMap map[]); | | | | | | | | | | | | | | 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 | MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *indexPtr, Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, int indexCount, Tcl_Obj *const indexArray[], Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name, const EnsembleImplMap map[]); MODULE_SCOPE int TclMaxListLength(const char *bytes, int numBytes, const char **endPtr); MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr, int *codePtr, int *levelPtr); MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options); MODULE_SCOPE int TclNokia770Doubles(void); MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr); MODULE_SCOPE int TclNamespaceDeleted(Namespace *nsPtr); MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const char *operation, const char *reason, int index); MODULE_SCOPE int TclObjInvokeNamespace(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Tcl_Namespace *nsPtr, int flags); MODULE_SCOPE int TclObjUnsetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); MODULE_SCOPE int TclParseBackslash(const char *src, int numBytes, int *readPtr, char *dst); MODULE_SCOPE int TclParseHex(const char *src, int numBytes, int *resultPtr); MODULE_SCOPE int TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr, const char *expected, const char *bytes, int numBytes, const char **endPtrPtr, int flags); MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string, int numBytes, Tcl_Parse *parsePtr); MODULE_SCOPE int TclParseAllWhiteSpace(const char *src, int numBytes); MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, int len); MODULE_SCOPE int TclpDeleteFile(const void *path); MODULE_SCOPE void TclpFinalizeCondition(Tcl_Condition *condPtr); MODULE_SCOPE void TclpFinalizeMutex(Tcl_Mutex *mutexPtr); MODULE_SCOPE void TclpFinalizePipes(void); MODULE_SCOPE void TclpFinalizeSockets(void); MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, struct addrinfo **addrlist, const char *host, int port, int willBind, const char **errorMsgPtr); MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, Tcl_ThreadCreateProc *proc, ClientData clientData, int stackSize, int flags); MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, unsigned int *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); MODULE_SCOPE Tcl_Obj * TclpObjListVolumes(void); MODULE_SCOPE void TclpMasterLock(void); MODULE_SCOPE void TclpMasterUnlock(void); MODULE_SCOPE int TclpMatchFiles(Tcl_Interp *interp, char *separators, Tcl_DString *dirPtr, char *pattern, char *tail); MODULE_SCOPE int TclpObjNormalizePath(Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint); MODULE_SCOPE void TclpNativeJoinPath(Tcl_Obj *prefix, const char *joining); MODULE_SCOPE Tcl_Obj * TclpNativeSplitPath(Tcl_Obj *pathPtr, int *lenPtr); MODULE_SCOPE Tcl_PathType TclpGetNativePathType(Tcl_Obj *pathPtr, int *driveNameLengthPtr, Tcl_Obj **driveNameRef); MODULE_SCOPE int TclCrossFilesystemCopy(Tcl_Interp *interp, Tcl_Obj *source, Tcl_Obj *target); MODULE_SCOPE int TclpMatchInDirectory(Tcl_Interp *interp, Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, const char *pattern, Tcl_GlobTypeData *types); MODULE_SCOPE ClientData TclpGetNativeCwd(ClientData clientData); MODULE_SCOPE Tcl_FSDupInternalRepProc TclNativeDupInternalRep; MODULE_SCOPE Tcl_Obj * TclpObjLink(Tcl_Obj *pathPtr, Tcl_Obj *toPtr, int linkType); MODULE_SCOPE int TclpObjChdir(Tcl_Obj *pathPtr); MODULE_SCOPE Tcl_Channel TclpOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); |
| ︙ | ︙ | |||
3115 3116 3117 3118 3119 3120 3121 | void *data); MODULE_SCOPE TCL_NORETURN void TclpThreadExit(int status); MODULE_SCOPE void TclRememberCondition(Tcl_Condition *mutex); MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id); MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex); MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, | | | | | | | | | | | | | | | | | | | | | > > > | | > | > | < < < | > > > > > > > | 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 |
void *data);
MODULE_SCOPE TCL_NORETURN void TclpThreadExit(int status);
MODULE_SCOPE void TclRememberCondition(Tcl_Condition *mutex);
MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id);
MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex);
MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp);
MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr,
int reStrLen, Tcl_DString *dsPtr, int *flagsPtr,
int *quantifiersFoundPtr);
MODULE_SCOPE int TclScanElement(const char *string, int length,
char *flagPtr);
MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp,
Tcl_Obj *cmdPrefix);
MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr,
void *bignumValue);
MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr);
MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
Command *cmdPtr);
MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr);
MODULE_SCOPE void TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr,
Tcl_Obj *newValue, Tcl_Encoding encoding);
MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result);
MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp,
Tcl_Obj *const *objv, int objc, int subIdx,
Tcl_Obj *bad, Tcl_Obj *fix);
MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr,
int numBytes);
typedef int (*memCmpFn_t)(const void*, const void*, size_t);
MODULE_SCOPE int TclStringCmp(Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr,
int checkEq, int nocase, int reqlength);
MODULE_SCOPE int TclStringCmpOpts(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[], int *nocase,
int *reqlength);
MODULE_SCOPE int TclStringMatch(const char *str, int strLen,
const char *pattern, int ptnLen, int flags);
MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj,
Tcl_Obj *patternObj, int flags);
MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes,
int numBytes, int flags, int line,
struct CompileEnv *envPtr);
MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, int numOpts,
Tcl_Obj *const opts[], int *flagPtr);
MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes,
int numBytes, int flags, Tcl_Parse *parsePtr,
Tcl_InterpState *statePtr);
MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
int count, int *tokensLeftPtr, int line,
int *clNextOuter, const char *outerScript);
MODULE_SCOPE int TclTrim(const char *bytes, int numBytes,
const char *trim, int numTrim, int *trimRight);
MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes,
const char *trim, int numTrim);
MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes,
const char *trim, int numTrim);
MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command);
MODULE_SCOPE void TclRegisterCommandTypeName(
Tcl_ObjCmdProc *implementationProc,
const char *nameStr);
MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct);
MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct);
MODULE_SCOPE int TclUtfCount(int ch);
#if TCL_UTF_MAX > 3
# define TclUtfToUCS4 Tcl_UtfToUniChar
# define TclUniCharToUCS4(src, ptr) (*ptr = *(src),1)
# define 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 *src, int *ucs4Ptr);
MODULE_SCOPE int TclUniCharToUCS4(const Tcl_UniChar *src, int *ucs4Ptr);
# define TclUCS4Complete(src, length) (((unsigned)((unsigned char)*(src) - 0xF0) < 5) \
? ((length) >= 4) : Tcl_UtfCharComplete((src), (length)))
# define TclChar16Complete Tcl_UtfCharComplete
#endif
MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData);
MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr);
MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_LoadHandle *loadHandle,
Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
MODULE_SCOPE int TclpUtime(Tcl_Obj *pathPtr, struct utimbuf *tval);
#ifdef TCL_LOAD_FROM_MEMORY
MODULE_SCOPE void * TclpLoadMemoryGetBuffer(Tcl_Interp *interp, int size);
MODULE_SCOPE int TclpLoadMemory(Tcl_Interp *interp, void *buffer,
int size, int codeSize, Tcl_LoadHandle *loadHandle,
Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
#endif
MODULE_SCOPE void TclInitThreadStorage(void);
MODULE_SCOPE void TclFinalizeThreadDataThread(void);
MODULE_SCOPE void TclFinalizeThreadStorage(void);
/* TclWideMUInt -- wide integer used for measurement calculations: */
#if (!defined(_WIN32) || !defined(_MSC_VER) || (_MSC_VER >= 1400))
# define TclWideMUInt Tcl_WideUInt
#else
/* older MSVS may not allow conversions between unsigned __int64 and double) */
# define TclWideMUInt Tcl_WideInt
#endif
#ifdef TCL_WIDE_CLICKS
MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void);
MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks);
MODULE_SCOPE double TclpWideClickInMicrosec(void);
#else
# ifdef _WIN32
# define TCL_WIDE_CLICKS 1
|
| ︙ | ︙ | |||
3218 3219 3220 3221 3222 3223 3224 | MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); MODULE_SCOPE void * TclpThreadCreateKey(void); MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); MODULE_SCOPE void TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr); MODULE_SCOPE void * TclpThreadGetMasterTSD(void *tsdKeyPtr); MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, | | > > > > > > > > > > | | | | > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 | MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp); MODULE_SCOPE void * TclpThreadCreateKey(void); MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); MODULE_SCOPE void TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr); MODULE_SCOPE void * TclpThreadGetMasterTSD(void *tsdKeyPtr); MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length); /* Tip 430 */ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); /* * Many parsing tasks need a common definition of whitespace. * Use this routine and macro to achieve that and place * optimization (fragile on changes) in one place. */ MODULE_SCOPE int TclIsSpaceProc(int byte); # define TclIsSpaceProcM(byte) \ (((byte) > 0x20) ? 0 : TclIsSpaceProc(byte)) /* *---------------------------------------------------------------- * Command procedures in the generic core: *---------------------------------------------------------------- */ MODULE_SCOPE int Tcl_AfterObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_AppendObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_ApplyObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitArrayCmd(Tcl_Interp *interp); MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); #endif MODULE_SCOPE int Tcl_CatchObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_CdObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitChanCmd(Tcl_Interp *interp); MODULE_SCOPE int TclChanCreateObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclChanPostEventObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclChanPopObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclChanPushObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE void TclClockInit(Tcl_Interp *interp); MODULE_SCOPE int TclClockOldscanObjCmd( void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_CloseObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_ConcatObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_ContinueObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler( Tcl_Time *timePtr, Tcl_TimerProc *proc, ClientData clientData); MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp); MODULE_SCOPE int TclDictWithFinish(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int index, int pathc, Tcl_Obj *const pathv[], Tcl_Obj *keysPtr); MODULE_SCOPE Tcl_Obj * TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr, int pathc, Tcl_Obj *const pathv[]); MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* Assemble command function */ MODULE_SCOPE int Tcl_AssembleObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclNRAssembleObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitEncodingCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_EofObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_ErrorObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_EvalObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_ExecObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_ExitObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_ExprObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_FblockedObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_FconfigureObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_FcopyObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitFileCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_FileEventObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_FlushObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_ForObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_ForeachObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_FormatObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_GetsObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_GlobalObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_GlobObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_IfObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_IncrObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitInfoCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_InterpObjCmd(ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_JoinObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LappendObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LassignObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LindexObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LinsertObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LlengthObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_ListObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LmapObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LoadObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LpopObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LrangeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LremoveObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LrepeatObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LreplaceObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LreverseObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LsearchObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LsetObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LsortObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitNamespaceCmd(Tcl_Interp *interp); MODULE_SCOPE int TclNamespaceEnsembleCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_OpenObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_PackageObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_PidObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitPrefixCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_PutsObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_PwdObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_ReadObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_RegexpObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_RegsubObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_RenameObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_RepresentationCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_ReturnObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_ScanObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_SeekObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_SetObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_SplitObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_SocketObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_SourceObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitStringCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_SubstObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_SwitchObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_TellObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_ThrowObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_TimeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_TimeRateObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_TraceObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_TryObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_UnloadObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_UnsetObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_UpdateObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_UplevelObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_UpvarObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_VariableObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_VwaitObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_WhileObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* *---------------------------------------------------------------- * Compilation procedures for commands in the generic core: *---------------------------------------------------------------- |
| ︙ | ︙ | |||
3847 3848 3849 3850 3851 3852 3853 | MODULE_SCOPE int TclCompileBasicMin1ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasicMin2ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); | | | | | | | | | | | | | | | | | | | 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 | MODULE_SCOPE int TclCompileBasicMin1ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileBasicMin2ArgCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclInvertOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileInvertOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclNotOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileNotOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclAddOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileAddOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclMulOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileMulOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclAndOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileAndOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclOrOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileOrOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclXorOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileXorOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclPowOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompilePowOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclLshiftOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileLshiftOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclRshiftOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileRshiftOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclModOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileModOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclNeqOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileNeqOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclStrneqOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileStrneqOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclInOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileInOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclNiOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileNiOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclMinusOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileMinusOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclDivOpCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclCompileDivOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileLessOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, |
| ︙ | ︙ | |||
3991 3992 3993 3994 3995 3996 3997 | /* * Routines that provide the [string] ensemble functionality. Possible * candidates for public interface. */ MODULE_SCOPE Tcl_Obj * TclStringCat(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); | | | | | | | | 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 | /* * Routines that provide the [string] ensemble functionality. Possible * candidates for public interface. */ MODULE_SCOPE Tcl_Obj * TclStringCat(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); MODULE_SCOPE Tcl_Obj * TclStringFirst(Tcl_Obj *needle, Tcl_Obj *haystack, int start); MODULE_SCOPE Tcl_Obj * TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack, int last); MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr, int count, int flags); MODULE_SCOPE Tcl_Obj * TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr, int first, int count, Tcl_Obj *insertPtr, int flags); MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr, int flags); /* Flag values for the [string] ensemble functions. */ #define TCL_STRING_MATCH_NOCASE TCL_MATCH_NOCASE /* (1<<0) in tcl.h */ #define TCL_STRING_IN_PLACE (1<<1) |
| ︙ | ︙ | |||
4057 4058 4059 4060 4061 4062 4063 | int flags, int leaveErrMsg, int index); /* * So tclObj.c and tclDictObj.c can share these implementations. */ MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr); | < | 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 | int flags, int leaveErrMsg, int index); /* * So tclObj.c and tclDictObj.c can share these implementations. */ MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr); MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr); MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclFullFinalizationRequested(void); /* * Just for the purposes of command-type registration. |
| ︙ | ︙ | |||
4113 4114 4115 4116 4117 4118 4119 | /* * Utility routines for encoding index values as integers. Used by both * some of the command compilers and by [lsort] and [lsearch]. */ MODULE_SCOPE int TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr, | | | | | | 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 | /* * Utility routines for encoding index values as integers. Used by both * some of the command compilers and by [lsort] and [lsearch]. */ MODULE_SCOPE int TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr, int before, int after, int *indexPtr); MODULE_SCOPE int TclIndexDecode(int encoded, int endValue); /* Constants used in index value encoding routines. */ #define TCL_INDEX_END (-2) #define TCL_INDEX_START (0) /* *---------------------------------------------------------------- * Macros used by the Tcl core to create and release Tcl objects. * TclNewObj(objPtr) creates a new object denoting an empty string. * TclDecrRefCount(objPtr) decrements the object's reference count, and frees * the object if its reference count is zero. These macros are inline versions |
| ︙ | ︙ | |||
4147 4148 4149 4150 4151 4152 4153 | /* * DTrace object allocation probe macros. */ #ifdef USE_DTRACE #ifndef _TCLDTRACE_H | < | 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 |
/*
* DTrace object allocation probe macros.
*/
#ifdef USE_DTRACE
#ifndef _TCLDTRACE_H
#include "tclDTrace.h"
#endif
#define TCL_DTRACE_OBJ_CREATE(objPtr) TCL_OBJ_CREATE(objPtr)
#define TCL_DTRACE_OBJ_FREE(objPtr) TCL_OBJ_FREE(objPtr)
#else /* USE_DTRACE */
#define TCL_DTRACE_OBJ_CREATE(objPtr) {}
#define TCL_DTRACE_OBJ_FREE(objPtr) {}
|
| ︙ | ︙ | |||
4186 4187 4188 4189 4190 4191 4192 |
(objPtr)->length = 0; \
(objPtr)->typePtr = NULL; \
TCL_DTRACE_OBJ_CREATE(objPtr)
/*
* Invalidate the string rep first so we can use the bytes value for our
* pointer chain, and signal an obj deletion (as opposed to shimmering) with
| | | | | 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 |
(objPtr)->length = 0; \
(objPtr)->typePtr = NULL; \
TCL_DTRACE_OBJ_CREATE(objPtr)
/*
* Invalidate the string rep first so we can use the bytes value for our
* pointer chain, and signal an obj deletion (as opposed to shimmering) with
* 'length == -1'.
* Use empty 'if ; else' to handle use in unbraced outer if/else conditions.
*/
# define TclDecrRefCount(objPtr) \
if ((objPtr)->refCount-- > 1) ; else { \
if (!(objPtr)->typePtr || !(objPtr)->typePtr->freeIntRepProc) { \
TCL_DTRACE_OBJ_FREE(objPtr); \
if ((objPtr)->bytes \
&& ((objPtr)->bytes != &tclEmptyString)) { \
ckfree((objPtr)->bytes); \
} \
(objPtr)->length = -1; \
TclFreeObjStorage(objPtr); \
TclIncrObjsFreed(); \
} else { \
TclFreeObj(objPtr); \
} \
}
|
| ︙ | ︙ | |||
4220 4221 4222 4223 4224 4225 4226 | * The PURIFY mode is like the regular mode, but instead of doing block * Tcl_Obj allocation and keeping a freed list for efficiency, it always * allocates and frees a single Tcl_Obj so that tools like Purify can better * track memory leaks. */ # define TclAllocObjStorageEx(interp, objPtr) \ | | | | 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 | * The PURIFY mode is like the regular mode, but instead of doing block * Tcl_Obj allocation and keeping a freed list for efficiency, it always * allocates and frees a single Tcl_Obj so that tools like Purify can better * track memory leaks. */ # define TclAllocObjStorageEx(interp, objPtr) \ (objPtr) = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)) # define TclFreeObjStorageEx(interp, objPtr) \ ckfree(objPtr) #undef USE_THREAD_ALLOC #undef USE_TCLALLOC #elif TCL_THREADS && defined(USE_THREAD_ALLOC) /* * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from |
| ︙ | ︙ | |||
4263 4264 4265 4266 4267 4268 4269 |
AllocCache *cachePtr; \
if (((interp) == NULL) || \
((cachePtr = ((Interp *)(interp))->allocCache), \
(cachePtr->numObjects == 0))) { \
(objPtr) = TclThreadAllocObj(); \
} else { \
(objPtr) = cachePtr->firstObjPtr; \
| | | 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 |
AllocCache *cachePtr; \
if (((interp) == NULL) || \
((cachePtr = ((Interp *)(interp))->allocCache), \
(cachePtr->numObjects == 0))) { \
(objPtr) = TclThreadAllocObj(); \
} else { \
(objPtr) = cachePtr->firstObjPtr; \
cachePtr->firstObjPtr = (Tcl_Obj *)(objPtr)->internalRep.twoPtrValue.ptr1; \
--cachePtr->numObjects; \
} \
} while (0)
# define TclFreeObjStorageEx(interp, objPtr) \
do { \
AllocCache *cachePtr; \
|
| ︙ | ︙ | |||
4351 4352 4353 4354 4355 4356 4357 | *---------------------------------------------------------------- * Macro used by the Tcl core to set a Tcl_Obj's string representation to a * copy of the "len" bytes starting at "bytePtr". This code works even if the * byte array contains NULLs as long as the length is correct. Because "len" * is referenced multiple times, it should be as simple an expression as * possible. The ANSI C "prototype" for this macro is: * | | | < < < < < < < < < < < < < < < < < < < | < | < < < | < < < < < | 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 |
*----------------------------------------------------------------
* Macro used by the Tcl core to set a Tcl_Obj's string representation to a
* copy of the "len" bytes starting at "bytePtr". This code works even if the
* byte array contains NULLs as long as the length is correct. Because "len"
* is referenced multiple times, it should be as simple an expression as
* possible. The ANSI C "prototype" for this macro is:
*
* MODULE_SCOPE void TclInitStringRep(Tcl_Obj *objPtr, char *bytePtr, int len);
*
* This macro should only be called on an unshared objPtr where
* objPtr->typePtr->freeIntRepProc == NULL
*----------------------------------------------------------------
*/
#define TclInitStringRep(objPtr, bytePtr, len) \
if ((len) == 0) { \
(objPtr)->bytes = &tclEmptyString; \
(objPtr)->length = 0; \
} else { \
(objPtr)->bytes = (char *) ckalloc((len) + 1); \
memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)); \
(objPtr)->bytes[len] = '\0'; \
(objPtr)->length = (len); \
}
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to get the string representation's byte array
* pointer from a Tcl_Obj. This is an inline version of Tcl_GetString(). The
* macro's expression result is the string rep's byte pointer which might be
* NULL. The bytes referenced by this pointer must not be modified by the
* caller. The ANSI C "prototype" for this macro is:
*
* MODULE_SCOPE char * TclGetString(Tcl_Obj *objPtr);
*----------------------------------------------------------------
*/
#define TclGetString(objPtr) \
((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString(objPtr))
#define TclGetStringFromObj(objPtr, lenPtr) \
((objPtr)->bytes \
? (*(lenPtr) = (objPtr)->length, (objPtr)->bytes) \
: Tcl_GetStringFromObj((objPtr), (lenPtr)))
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to clean out an object's internal
* representation. Does not actually reset the rep's bytes. The ANSI C
* "prototype" for this macro is:
*
|
| ︙ | ︙ | |||
4447 4448 4449 4450 4451 4452 4453 |
* MODULE_SCOPE void TclInvalidateStringRep(Tcl_Obj *objPtr);
*----------------------------------------------------------------
*/
#define TclInvalidateStringRep(objPtr) \
if ((objPtr)->bytes != NULL) { \
if ((objPtr)->bytes != &tclEmptyString) { \
| | > > > > > > > > > > > > > > > | 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 |
* MODULE_SCOPE void TclInvalidateStringRep(Tcl_Obj *objPtr);
*----------------------------------------------------------------
*/
#define TclInvalidateStringRep(objPtr) \
if ((objPtr)->bytes != NULL) { \
if ((objPtr)->bytes != &tclEmptyString) { \
ckfree((objPtr)->bytes); \
} \
(objPtr)->bytes = NULL; \
}
/*
* These form part of the native filesystem support. They are needed here
* because we have a few native filesystem functions (which are the same for
* win/unix) in this file.
*/
#ifdef __cplusplus
extern "C" {
#endif
MODULE_SCOPE const char *const tclpFileAttrStrings[];
MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[];
#ifdef __cplusplus
}
#endif
/*
*----------------------------------------------------------------
* Macro used by the Tcl core to test whether an object has a
* string representation (or is a 'pure' internal value).
* The ANSI C "prototype" for this macro is:
*
* MODULE_SCOPE int TclHasStringRep(Tcl_Obj *objPtr);
|
| ︙ | ︙ | |||
4476 4477 4478 4479 4480 4481 4482 |
*
* MODULE_SCOPE void TclUnpackBignum(Tcl_Obj *objPtr, mp_int bignum);
*----------------------------------------------------------------
*/
#define TclUnpackBignum(objPtr, bignum) \
do { \
| | | | | | | 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 |
*
* MODULE_SCOPE void TclUnpackBignum(Tcl_Obj *objPtr, mp_int bignum);
*----------------------------------------------------------------
*/
#define TclUnpackBignum(objPtr, bignum) \
do { \
Tcl_Obj *bignumObj = (objPtr); \
int bignumPayload = \
PTR2INT(bignumObj->internalRep.twoPtrValue.ptr2); \
if (bignumPayload == -1) { \
(bignum) = *((mp_int *) bignumObj->internalRep.twoPtrValue.ptr1); \
} else { \
(bignum).dp = (mp_digit *)bignumObj->internalRep.twoPtrValue.ptr1; \
(bignum).sign = bignumPayload >> 30; \
(bignum).alloc = (bignumPayload >> 15) & 0x7FFF; \
(bignum).used = bignumPayload & 0x7FFF; \
} \
} while (0)
/*
*----------------------------------------------------------------
* Macros used by the Tcl core to grow Tcl_Token arrays. They use the same
* growth algorithm as used in tclStringObj.c for growing strings. The ANSI C
|
| ︙ | ︙ | |||
4536 4537 4538 4539 4540 4541 4542 |
Tcl_Token *newPtr; \
if (oldPtr == (staticPtr)) { \
oldPtr = NULL; \
} \
if (allocated > TCL_MAX_TOKENS) { \
allocated = TCL_MAX_TOKENS; \
} \
| | | | | | | 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 |
Tcl_Token *newPtr; \
if (oldPtr == (staticPtr)) { \
oldPtr = NULL; \
} \
if (allocated > TCL_MAX_TOKENS) { \
allocated = TCL_MAX_TOKENS; \
} \
newPtr = (Tcl_Token *) attemptckrealloc((char *) oldPtr, \
allocated * sizeof(Tcl_Token)); \
if (newPtr == NULL) { \
allocated = _needed + (append) + TCL_MIN_TOKEN_GROWTH; \
if (allocated > TCL_MAX_TOKENS) { \
allocated = TCL_MAX_TOKENS; \
} \
newPtr = (Tcl_Token *) ckrealloc((char *) oldPtr, \
allocated * sizeof(Tcl_Token)); \
} \
(available) = allocated; \
if (oldPtr == NULL) { \
memcpy(newPtr, staticPtr, \
(used) * sizeof(Tcl_Token)); \
} \
(tokenPtr) = newPtr; \
} \
} while (0)
#define TclGrowParseTokenArray(parsePtr, append) \
TclGrowTokenArray((parsePtr)->tokenPtr, (parsePtr)->numTokens, \
|
| ︙ | ︙ | |||
4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 | * string handling. The macro's expression result is 1 for the 1-byte case or * the result of Tcl_UtfToUniChar. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE int TclUtfToUniChar(const char *string, Tcl_UniChar *ch); *---------------------------------------------------------------- */ #define TclUtfToUniChar(str, chPtr) \ ((((unsigned char) *(str)) < 0x80) ? \ ((*(chPtr) = (unsigned char) *(str)), 1) \ | > > > > > > | > | | > > > > > | 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 |
* string handling. The macro's expression result is 1 for the 1-byte case or
* the result of Tcl_UtfToUniChar. The ANSI C "prototype" for this macro is:
*
* MODULE_SCOPE int TclUtfToUniChar(const char *string, Tcl_UniChar *ch);
*----------------------------------------------------------------
*/
#if TCL_UTF_MAX > 3
#define TclUtfToUniChar(str, chPtr) \
(((UCHAR(*(str))) < 0x80) ? \
((*(chPtr) = UCHAR(*(str))), 1) \
: Tcl_UtfToUniChar(str, chPtr))
#else
#define TclUtfToUniChar(str, chPtr) \
((((unsigned char) *(str)) < 0x80) ? \
((*(chPtr) = (unsigned char) *(str)), 1) \
: Tcl_UtfToChar16(str, chPtr))
#endif
/*
*----------------------------------------------------------------
* Macro counterpart of the Tcl_NumUtfChars() function. To be used in speed-
* -sensitive points where it pays to avoid a function call in the common case
* of counting along a string of all one-byte characters. The ANSI C
* "prototype" for this macro is:
*
* MODULE_SCOPE void TclNumUtfChars(int numChars, const char *bytes,
* int numBytes);
*----------------------------------------------------------------
*/
#define TclNumUtfChars(numChars, bytes, numBytes) \
do { \
int _count, _i = (numBytes); \
unsigned char *_str = (unsigned char *) (bytes); \
while (_i && (*_str < 0xC0)) { _i--; _str++; } \
_count = (numBytes) - _i; \
if (_i) { \
_count += Tcl_NumUtfChars((bytes) + _count, _i); \
} \
(numChars) = _count; \
} while (0);
#define TclUtfPrev(src, start) \
(((src) < (start) + 2) ? (start) : \
((unsigned char) *((src) - 1)) < 0x80 ? (src) - 1 : \
Tcl_UtfPrev(src, start))
/*
*----------------------------------------------------------------
* Macro that encapsulates the logic that determines when it is safe to
* interpret a string as a byte array directly. In summary, the object must be
* a byte array and must not have a string representation (as the operations
* that it is used in are defined on strings, not byte arrays). Theoretically
|
| ︙ | ︙ | |||
4734 4735 4736 4737 4738 4739 4740 | *---------------------------------------------------------------- * Macros used by the Tcl core to create and initialise objects of standard * types, avoiding the corresponding function calls in time critical parts of * the core. The ANSI C "prototypes" for these macros are: * * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d); | | | | | 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 |
*----------------------------------------------------------------
* Macros used by the Tcl core to create and initialise objects of standard
* types, avoiding the corresponding function calls in time critical parts of
* the core. The ANSI C "prototypes" for these macros are:
*
* MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, Tcl_WideInt w);
* MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d);
* MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, int len);
* MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral);
*
*----------------------------------------------------------------
*/
#ifndef TCL_MEM_DEBUG
#define TclNewIntObj(objPtr, w) \
do { \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = NULL; \
(objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \
(objPtr)->typePtr = &tclIntType; \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
#define TclNewDoubleObj(objPtr, d) \
do { \
TclIncrObjsAllocated(); \
|
| ︙ | ︙ | |||
4789 4790 4791 4792 4793 4794 4795 | #endif /* TCL_MEM_DEBUG */ /* * The sLiteral argument *must* be a string literal; the incantation with * sizeof(sLiteral "") will fail to compile otherwise. */ #define TclNewLiteralStringObj(objPtr, sLiteral) \ | | | | 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 |
#endif /* TCL_MEM_DEBUG */
/*
* The sLiteral argument *must* be a string literal; the incantation with
* sizeof(sLiteral "") will fail to compile otherwise.
*/
#define TclNewLiteralStringObj(objPtr, sLiteral) \
TclNewStringObj((objPtr), (sLiteral), (int) (sizeof(sLiteral "") - 1))
/*
*----------------------------------------------------------------
* Convenience macros for DStrings.
* The ANSI C "prototypes" for these macros are:
*
* MODULE_SCOPE char * TclDStringAppendLiteral(Tcl_DString *dsPtr,
* const char *sLiteral);
* MODULE_SCOPE void TclDStringClear(Tcl_DString *dsPtr);
*/
#define TclDStringAppendLiteral(dsPtr, sLiteral) \
Tcl_DStringAppend((dsPtr), (sLiteral), (int) (sizeof(sLiteral "") - 1))
#define TclDStringClear(dsPtr) \
Tcl_DStringSetLength((dsPtr), 0)
/*
*----------------------------------------------------------------
* Macros used by the Tcl core to test for some special double values.
* The ANSI C "prototypes" for these macros are:
|
| ︙ | ︙ | |||
4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 | # ifdef NO_ISNAN # define TclIsNaN(d) ((d) != (d)) # else # define TclIsNaN(d) (isnan(d)) # endif #endif /* Workaround for platforms missing offsetof(), e.g. VC++ 6.0 */ #ifndef offsetof # define offsetof(type, field) ((size_t) ((char *) &((type *) 0)->field)) #endif /* *---------------------------------------------------------------- | > > > > > > > > | 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 | # ifdef NO_ISNAN # define TclIsNaN(d) ((d) != (d)) # else # define TclIsNaN(d) (isnan(d)) # endif #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. */ #ifndef TCL_NO_DEPRECATED # 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 /* *---------------------------------------------------------------- |
| ︙ | ︙ | |||
4851 4852 4853 4854 4855 4856 4857 |
*----------------------------------------------------------------
* 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) \
if ((cmdPtr)->refCount-- <= 1) { \
| | | 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 |
*----------------------------------------------------------------
* 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) \
if ((cmdPtr)->refCount-- <= 1) { \
ckfree(cmdPtr);\
}
/*
*----------------------------------------------------------------
* 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
|
| ︙ | ︙ | |||
4914 4915 4916 4917 4918 4919 4920 |
#ifndef TCL_MEM_DEBUG
#define TclSmallAllocEx(interp, nbytes, memPtr) \
do { \
Tcl_Obj *_objPtr; \
TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \
TclIncrObjsAllocated(); \
| | | | | < < < < < < < < < < < < < < < | 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 |
#ifndef TCL_MEM_DEBUG
#define TclSmallAllocEx(interp, nbytes, memPtr) \
do { \
Tcl_Obj *_objPtr; \
TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \
TclIncrObjsAllocated(); \
TclAllocObjStorageEx((interp), (_objPtr)); \
*(void **)&memPtr = (void *) (_objPtr); \
} while (0)
#define TclSmallFreeEx(interp, memPtr) \
do { \
TclFreeObjStorageEx((interp), (Tcl_Obj *) (memPtr)); \
TclIncrObjsFreed(); \
} while (0)
#else /* TCL_MEM_DEBUG */
#define TclSmallAllocEx(interp, nbytes, memPtr) \
do { \
Tcl_Obj *_objPtr; \
TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \
TclNewObj(_objPtr); \
*(void **)&memPtr = (void *) _objPtr; \
} while (0)
#define TclSmallFreeEx(interp, memPtr) \
do { \
Tcl_Obj *_objPtr = (Tcl_Obj *) memPtr; \
_objPtr->bytes = NULL; \
_objPtr->typePtr = NULL; \
_objPtr->refCount = 1; \
TclDecrRefCount(_objPtr); \
} while (0)
#endif /* TCL_MEM_DEBUG */
/*
* Support for Clang Static Analyzer <http://clang-analyzer.llvm.org>
*/
#if defined(PURIFY) && defined(__clang__)
#if __has_feature(attribute_analyzer_noreturn) && \
!defined(Tcl_Panic) && defined(Tcl_Panic_TCL_DECLARED)
|
| ︙ | ︙ | |||
4994 4995 4996 4997 4998 4999 5000 |
* This is the main data struct for representing NR commands. It is designed
* to fit in sizeof(Tcl_Obj) in order to exploit the fastest memory allocator
* available.
*/
typedef struct NRE_callback {
Tcl_NRPostProc *procPtr;
| | | | | | | | < | | | | 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 |
* This is the main data struct for representing NR commands. It is designed
* to fit in sizeof(Tcl_Obj) in order to exploit the fastest memory allocator
* available.
*/
typedef struct NRE_callback {
Tcl_NRPostProc *procPtr;
ClientData data[4];
struct NRE_callback *nextPtr;
} NRE_callback;
#define TOP_CB(iPtr) (((Interp *)(iPtr))->execEnvPtr->callbackPtr)
/*
* Inline version of Tcl_NRAddCallback.
*/
#define TclNRAddCallback(interp,postProcPtr,data0,data1,data2,data3) \
do { \
NRE_callback *_callbackPtr; \
TCLNR_ALLOC((interp), (_callbackPtr)); \
_callbackPtr->procPtr = (postProcPtr); \
_callbackPtr->data[0] = (ClientData)(data0); \
_callbackPtr->data[1] = (ClientData)(data1); \
_callbackPtr->data[2] = (ClientData)(data2); \
_callbackPtr->data[3] = (ClientData)(data3); \
_callbackPtr->nextPtr = TOP_CB(interp); \
TOP_CB(interp) = _callbackPtr; \
} while (0)
#if NRE_USE_SMALL_ALLOC
#define TCLNR_ALLOC(interp, ptr) \
TclSmallAllocEx(interp, sizeof(NRE_callback), (ptr))
#define TCLNR_FREE(interp, ptr) TclSmallFreeEx((interp), (ptr))
#else
#define TCLNR_ALLOC(interp, ptr) \
(ptr = ((ClientData) ckalloc(sizeof(NRE_callback))))
#define TCLNR_FREE(interp, ptr) ckfree(ptr)
#endif
#if NRE_ENABLE_ASSERTS
#define NRE_ASSERT(expr) assert((expr))
#else
#define NRE_ASSERT(expr)
#endif
#include "tclIntDecls.h"
#include "tclIntPlatDecls.h"
#if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG)
#define Tcl_AttemptAlloc(size) TclpAlloc(size)
#define Tcl_AttemptRealloc(ptr, size) TclpRealloc((ptr), (size))
#define Tcl_Free(ptr) TclpFree(ptr)
#endif
#endif /* _TCLINT */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclIntDecls.h.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 30 31 32 33 34 35 36 | # ifdef USE_TCL_STUBS # define TCL_STORAGE_CLASS # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif /* * WARNING: This file is automatically generated by the tools/genStubs.tcl * script. Any modifications to the function declarations below should be made * in the generic/tclInt.decls script. */ /* !BEGIN!: Do not edit below this line. */ | > > > > > > > > > > > > > > > > > | 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 | # ifdef USE_TCL_STUBS # define TCL_STORAGE_CLASS # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif #if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) # define tclGetIntForIndex tcl_GetIntForIndex /* Those macro's are especially for Itcl 3.4 compatibility */ # define tclCreateNamespace tcl_CreateNamespace # define tclDeleteNamespace tcl_DeleteNamespace # define tclAppendExportList tcl_AppendExportList # define tclExport tcl_Export # define tclImport tcl_Import # define tclForgetImport tcl_ForgetImport # define tclGetCurrentNamespace_ tcl_GetCurrentNamespace # define tclGetGlobalNamespace_ tcl_GetGlobalNamespace # define tclFindNamespace tcl_FindNamespace # define tclFindCommand tcl_FindCommand # define tclGetCommandFromObj tcl_GetCommandFromObj # define tclGetCommandFullName tcl_GetCommandFullName #endif /* !defined(TCL_NO_DEPRECATED) */ /* * WARNING: This file is automatically generated by the tools/genStubs.tcl * script. Any modifications to the function declarations below should be made * in the generic/tclInt.decls script. */ /* !BEGIN!: Do not edit below this line. */ |
| ︙ | ︙ | |||
51 52 53 54 55 56 57 | /* Slot 4 is reserved */ /* 5 */ EXTERN int TclCleanupChildren(Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 6 */ EXTERN void TclCleanupCommand(Command *cmdPtr); /* 7 */ | | | > > > > | | | | > > > | | | | | | | | > > | | > > > > | | | > > | > > | > > > | > | > > | > > | > > > | > > | > > | > > | > | > | > > | > > | | | | > > | > > | | > > | > > | | | | | | > > | > | > > | > > | 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 |
/* Slot 4 is reserved */
/* 5 */
EXTERN int TclCleanupChildren(Tcl_Interp *interp, int numPids,
Tcl_Pid *pidPtr, Tcl_Channel errorChan);
/* 6 */
EXTERN void TclCleanupCommand(Command *cmdPtr);
/* 7 */
EXTERN int TclCopyAndCollapse(int count, const char *src,
char *dst);
/* 8 */
TCL_DEPRECATED("")
int TclCopyChannelOld(Tcl_Interp *interp,
Tcl_Channel inChan, Tcl_Channel outChan,
int toRead, Tcl_Obj *cmdPtr);
/* 9 */
EXTERN int TclCreatePipeline(Tcl_Interp *interp, int argc,
const char **argv, Tcl_Pid **pidArrayPtr,
TclFile *inPipePtr, TclFile *outPipePtr,
TclFile *errFilePtr);
/* 10 */
EXTERN int TclCreateProc(Tcl_Interp *interp, Namespace *nsPtr,
const char *procName, Tcl_Obj *argsPtr,
Tcl_Obj *bodyPtr, Proc **procPtrPtr);
/* 11 */
EXTERN void TclDeleteCompiledLocalVars(Interp *iPtr,
CallFrame *framePtr);
/* 12 */
EXTERN void TclDeleteVars(Interp *iPtr,
TclVarHashTable *tablePtr);
/* Slot 13 is reserved */
/* 14 */
EXTERN int TclDumpMemoryInfo(ClientData clientData, int flags);
/* Slot 15 is reserved */
/* 16 */
EXTERN void TclExprFloatError(Tcl_Interp *interp, double value);
/* Slot 17 is reserved */
/* Slot 18 is reserved */
/* Slot 19 is reserved */
/* Slot 20 is reserved */
/* Slot 21 is reserved */
/* 22 */
EXTERN int TclFindElement(Tcl_Interp *interp,
const char *listStr, int listLength,
const char **elementPtr,
const char **nextPtr, int *sizePtr,
int *bracePtr);
/* 23 */
EXTERN Proc * TclFindProc(Interp *iPtr, const char *procName);
/* 24 */
EXTERN int TclFormatInt(char *buffer, Tcl_WideInt n);
/* 25 */
EXTERN void TclFreePackageInfo(Interp *iPtr);
/* Slot 26 is reserved */
/* Slot 27 is reserved */
/* 28 */
EXTERN Tcl_Channel TclpGetDefaultStdChannel(int type);
/* Slot 29 is reserved */
/* Slot 30 is reserved */
/* 31 */
EXTERN const char * TclGetExtension(const char *name);
/* 32 */
EXTERN int TclGetFrame(Tcl_Interp *interp, const char *str,
CallFrame **framePtrPtr);
/* Slot 33 is reserved */
/* 34 */
TCL_DEPRECATED("Use Tcl_GetIntForIndex")
int TclGetIntForIndex(Tcl_Interp *interp,
Tcl_Obj *objPtr, int endValue, int *indexPtr);
/* Slot 35 is reserved */
/* Slot 36 is reserved */
/* 37 */
EXTERN int TclGetLoadedPackages(Tcl_Interp *interp,
const char *targetName);
/* 38 */
EXTERN int TclGetNamespaceForQualName(Tcl_Interp *interp,
const char *qualName, Namespace *cxtNsPtr,
int flags, Namespace **nsPtrPtr,
Namespace **altNsPtrPtr,
Namespace **actualCxtPtrPtr,
const char **simpleNamePtr);
/* 39 */
EXTERN TclObjCmdProcType TclGetObjInterpProc(void);
/* 40 */
EXTERN int TclGetOpenMode(Tcl_Interp *interp, const char *str,
int *seekFlagPtr);
/* 41 */
EXTERN Tcl_Command TclGetOriginalCommand(Tcl_Command command);
/* 42 */
EXTERN CONST86 char * TclpGetUserHome(const char *name,
Tcl_DString *bufferPtr);
/* Slot 43 is reserved */
/* 44 */
EXTERN int TclGuessPackageName(const char *fileName,
Tcl_DString *bufPtr);
/* 45 */
EXTERN int TclHideUnsafeCommands(Tcl_Interp *interp);
/* 46 */
EXTERN int TclInExit(void);
/* Slot 47 is reserved */
/* Slot 48 is reserved */
/* Slot 49 is reserved */
/* 50 */
EXTERN void TclInitCompiledLocals(Tcl_Interp *interp,
CallFrame *framePtr, Namespace *nsPtr);
/* 51 */
EXTERN int TclInterpInit(Tcl_Interp *interp);
/* Slot 52 is reserved */
/* 53 */
EXTERN int TclInvokeObjectCommand(ClientData clientData,
Tcl_Interp *interp, int argc,
const char **argv);
/* 54 */
EXTERN int TclInvokeStringCommand(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
/* 55 */
EXTERN Proc * TclIsProc(Command *cmdPtr);
/* Slot 56 is reserved */
/* Slot 57 is reserved */
/* 58 */
EXTERN Var * TclLookupVar(Tcl_Interp *interp, const char *part1,
const char *part2, int flags,
const char *msg, int createPart1,
int createPart2, Var **arrayPtrPtr);
/* Slot 59 is reserved */
/* 60 */
EXTERN int TclNeedSpace(const char *start, const char *end);
/* 61 */
EXTERN Tcl_Obj * TclNewProcBodyObj(Proc *procPtr);
/* 62 */
EXTERN int TclObjCommandComplete(Tcl_Obj *cmdPtr);
/* 63 */
EXTERN int TclObjInterpProc(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
/* 64 */
EXTERN int TclObjInvoke(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[], int flags);
/* Slot 65 is reserved */
/* Slot 66 is reserved */
/* Slot 67 is reserved */
/* Slot 68 is reserved */
/* 69 */
EXTERN void * TclpAlloc(unsigned int size);
/* Slot 70 is reserved */
/* Slot 71 is reserved */
/* Slot 72 is reserved */
/* Slot 73 is reserved */
/* 74 */
EXTERN void TclpFree(void *ptr);
/* 75 */
EXTERN unsigned long TclpGetClicks(void);
/* 76 */
EXTERN unsigned long TclpGetSeconds(void);
/* 77 */
TCL_DEPRECATED("")
void TclpGetTime(Tcl_Time *time);
/* Slot 78 is reserved */
/* Slot 79 is reserved */
/* Slot 80 is reserved */
/* 81 */
EXTERN void * TclpRealloc(void *ptr, unsigned int size);
/* Slot 82 is reserved */
/* Slot 83 is reserved */
/* Slot 84 is reserved */
/* Slot 85 is reserved */
/* Slot 86 is reserved */
/* Slot 87 is reserved */
/* 88 */
TCL_DEPRECATED("")
char * TclPrecTraceProc(ClientData clientData,
Tcl_Interp *interp, const char *name1,
const char *name2, int flags);
/* 89 */
EXTERN int TclPreventAliasLoop(Tcl_Interp *interp,
Tcl_Interp *cmdInterp, Tcl_Command cmd);
/* Slot 90 is reserved */
/* 91 */
EXTERN void TclProcCleanupProc(Proc *procPtr);
/* 92 */
EXTERN int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr,
Tcl_Obj *bodyPtr, Namespace *nsPtr,
const char *description,
const char *procName);
/* 93 */
EXTERN void TclProcDeleteProc(ClientData clientData);
/* Slot 94 is reserved */
/* Slot 95 is reserved */
/* 96 */
EXTERN int TclRenameCommand(Tcl_Interp *interp,
const char *oldName, const char *newName);
/* 97 */
EXTERN void TclResetShadowedCmdRefs(Tcl_Interp *interp,
Command *newCmdPtr);
/* 98 */
EXTERN int TclServiceIdle(void);
/* Slot 99 is reserved */
/* Slot 100 is reserved */
/* 101 */
EXTERN CONST86 char * TclSetPreInitScript(const char *string);
/* 102 */
EXTERN void TclSetupEnv(Tcl_Interp *interp);
/* 103 */
EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str,
const char *proto, int *portPtr);
/* 104 */
TCL_DEPRECATED("")
int TclSockMinimumBuffersOld(int sock, int size);
/* Slot 105 is reserved */
/* Slot 106 is reserved */
/* Slot 107 is reserved */
/* 108 */
EXTERN void TclTeardownNamespace(Namespace *nsPtr);
/* 109 */
EXTERN int TclUpdateReturnInfo(Interp *iPtr);
/* 110 */
EXTERN int TclSockMinimumBuffers(void *sock, int size);
/* 111 */
EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp,
const char *name,
Tcl_ResolveCmdProc *cmdProc,
Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc);
/* 112 */
EXTERN int TclAppendExportList(Tcl_Interp *interp,
Tcl_Namespace *nsPtr, Tcl_Obj *objPtr);
/* 113 */
EXTERN Tcl_Namespace * TclCreateNamespace(Tcl_Interp *interp,
const char *name, ClientData clientData,
Tcl_NamespaceDeleteProc *deleteProc);
/* 114 */
EXTERN void TclDeleteNamespace(Tcl_Namespace *nsPtr);
/* 115 */
EXTERN int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int resetListFirst);
/* 116 */
EXTERN Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name,
Tcl_Namespace *contextNsPtr, int flags);
/* 117 */
EXTERN Tcl_Namespace * TclFindNamespace(Tcl_Interp *interp,
const char *name,
Tcl_Namespace *contextNsPtr, int flags);
/* 118 */
EXTERN int Tcl_GetInterpResolvers(Tcl_Interp *interp,
const char *name, Tcl_ResolverInfo *resInfo);
/* 119 */
EXTERN int Tcl_GetNamespaceResolvers(
Tcl_Namespace *namespacePtr,
Tcl_ResolverInfo *resInfo);
/* 120 */
EXTERN Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp,
const char *name,
Tcl_Namespace *contextNsPtr, int flags);
/* 121 */
EXTERN int TclForgetImport(Tcl_Interp *interp,
Tcl_Namespace *nsPtr, const char *pattern);
/* 122 */
EXTERN Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr);
/* 123 */
EXTERN void TclGetCommandFullName(Tcl_Interp *interp,
Tcl_Command command, Tcl_Obj *objPtr);
/* 124 */
EXTERN Tcl_Namespace * TclGetCurrentNamespace_(Tcl_Interp *interp);
/* 125 */
EXTERN Tcl_Namespace * TclGetGlobalNamespace_(Tcl_Interp *interp);
/* 126 */
EXTERN void Tcl_GetVariableFullName(Tcl_Interp *interp,
Tcl_Var variable, Tcl_Obj *objPtr);
/* 127 */
EXTERN int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr,
const char *pattern, int allowOverwrite);
/* 128 */
EXTERN void Tcl_PopCallFrame(Tcl_Interp *interp);
/* 129 */
EXTERN int Tcl_PushCallFrame(Tcl_Interp *interp,
Tcl_CallFrame *framePtr,
Tcl_Namespace *nsPtr, int isProcCallFrame);
/* 130 */
EXTERN int Tcl_RemoveInterpResolvers(Tcl_Interp *interp,
const char *name);
/* 131 */
EXTERN void Tcl_SetNamespaceResolvers(
Tcl_Namespace *namespacePtr,
Tcl_ResolveCmdProc *cmdProc,
Tcl_ResolveVarProc *varProc,
Tcl_ResolveCompiledVarProc *compiledVarProc);
/* 132 */
EXTERN int TclpHasSockets(Tcl_Interp *interp);
/* 133 */
TCL_DEPRECATED("")
struct tm * TclpGetDate(const time_t *time, int useGMT);
/* Slot 134 is reserved */
/* Slot 135 is reserved */
/* Slot 136 is reserved */
/* Slot 137 is reserved */
/* 138 */
EXTERN const char * TclGetEnv(const char *name, Tcl_DString *valuePtr);
/* Slot 139 is reserved */
/* Slot 140 is reserved */
/* 141 */
EXTERN const char * TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr);
/* 142 */
EXTERN int TclSetByteCodeFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr, CompileHookProc *hookProc,
ClientData clientData);
/* 143 */
EXTERN int TclAddLiteralObj(struct CompileEnv *envPtr,
Tcl_Obj *objPtr, LiteralEntry **litPtrPtr);
/* 144 */
EXTERN void TclHideLiteral(Tcl_Interp *interp,
struct CompileEnv *envPtr, int index);
/* 145 */
EXTERN const struct AuxDataType * TclGetAuxDataType(const char *typeName);
/* 146 */
EXTERN TclHandle TclHandleCreate(void *ptr);
/* 147 */
EXTERN void TclHandleFree(TclHandle handle);
/* 148 */
EXTERN TclHandle TclHandlePreserve(TclHandle handle);
/* 149 */
EXTERN void TclHandleRelease(TclHandle handle);
/* 150 */
EXTERN int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re);
/* 151 */
EXTERN void TclRegExpRangeUniChar(Tcl_RegExp re, int index,
int *startPtr, int *endPtr);
/* 152 */
EXTERN void TclSetLibraryPath(Tcl_Obj *pathPtr);
/* 153 */
EXTERN Tcl_Obj * TclGetLibraryPath(void);
/* Slot 154 is reserved */
/* Slot 155 is reserved */
/* 156 */
EXTERN void TclRegError(Tcl_Interp *interp, const char *msg,
int status);
/* 157 */
EXTERN Var * TclVarTraceExists(Tcl_Interp *interp,
const char *varName);
/* 158 */
TCL_DEPRECATED("use public Tcl_SetStartupScript()")
void TclSetStartupScriptFileName(const char *filename);
/* 159 */
TCL_DEPRECATED("use public Tcl_GetStartupScript()")
const char * TclGetStartupScriptFileName(void);
/* Slot 160 is reserved */
/* 161 */
EXTERN int TclChannelTransform(Tcl_Interp *interp,
Tcl_Channel chan, Tcl_Obj *cmdObjPtr);
/* 162 */
EXTERN void TclChannelEventScriptInvoker(ClientData clientData,
int flags);
/* 163 */
EXTERN const void * TclGetInstructionTable(void);
/* 164 */
EXTERN void TclExpandCodeArray(void *envPtr);
/* 165 */
EXTERN void TclpSetInitialEncodings(void);
/* 166 */
EXTERN int TclListObjSetElement(Tcl_Interp *interp,
Tcl_Obj *listPtr, int index,
Tcl_Obj *valuePtr);
/* 167 */
TCL_DEPRECATED("use public Tcl_SetStartupScript()")
void TclSetStartupScriptPath(Tcl_Obj *pathPtr);
/* 168 */
TCL_DEPRECATED("use public Tcl_GetStartupScript()")
Tcl_Obj * TclGetStartupScriptPath(void);
/* 169 */
EXTERN int TclpUtfNcmp2(const char *s1, const char *s2,
unsigned long n);
/* 170 */
EXTERN int TclCheckInterpTraces(Tcl_Interp *interp,
const char *command, int numChars,
Command *cmdPtr, int result, int traceFlags,
int objc, Tcl_Obj *const objv[]);
/* 171 */
EXTERN int TclCheckExecutionTraces(Tcl_Interp *interp,
const char *command, int numChars,
Command *cmdPtr, int result, int traceFlags,
int objc, Tcl_Obj *const objv[]);
/* 172 */
EXTERN int TclInThreadExit(void);
/* 173 */
EXTERN int TclUniCharMatch(const Tcl_UniChar *string,
int strLen, const Tcl_UniChar *pattern,
int ptnLen, int flags);
/* Slot 174 is reserved */
/* 175 */
EXTERN int TclCallVarTraces(Interp *iPtr, Var *arrayPtr,
Var *varPtr, const char *part1,
const char *part2, int flags,
int leaveErrMsg);
/* 176 */
EXTERN void TclCleanupVar(Var *varPtr, Var *arrayPtr);
/* 177 */
EXTERN void TclVarErrMsg(Tcl_Interp *interp, const char *part1,
const char *part2, const char *operation,
const char *reason);
/* 178 */
EXTERN void TclSetStartupScript(Tcl_Obj *pathPtr,
const char *encodingName);
/* 179 */
EXTERN Tcl_Obj * TclGetStartupScript(const char **encodingNamePtr);
/* Slot 180 is reserved */
/* Slot 181 is reserved */
/* 182 */
TCL_DEPRECATED("")
struct tm * TclpLocaltime(const time_t *clock);
/* 183 */
TCL_DEPRECATED("")
struct tm * TclpGmtime(const time_t *clock);
/* Slot 184 is reserved */
/* Slot 185 is reserved */
/* Slot 186 is reserved */
/* Slot 187 is reserved */
/* Slot 188 is reserved */
/* Slot 189 is reserved */
/* Slot 190 is reserved */
|
| ︙ | ︙ | |||
453 454 455 456 457 458 459 | EXTERN void TclpFindExecutable(const char *argv0); /* 213 */ EXTERN Tcl_Obj * TclGetObjNameOfExecutable(void); /* 214 */ EXTERN void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding); /* 215 */ | | | 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 | EXTERN void TclpFindExecutable(const char *argv0); /* 213 */ EXTERN Tcl_Obj * TclGetObjNameOfExecutable(void); /* 214 */ EXTERN void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding); /* 215 */ EXTERN void * TclStackAlloc(Tcl_Interp *interp, int numBytes); /* 216 */ EXTERN void TclStackFree(Tcl_Interp *interp, void *freePtr); /* 217 */ EXTERN int TclPushStackFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, Tcl_Namespace *namespacePtr, int isProcCallFrame); |
| ︙ | ︙ | |||
477 478 479 480 481 482 483 | /* 225 */ EXTERN Tcl_Obj * TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags); /* 226 */ EXTERN int TclObjBeingDeleted(Tcl_Obj *objPtr); /* 227 */ | | | 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 | /* 225 */ EXTERN Tcl_Obj * TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags); /* 226 */ EXTERN int TclObjBeingDeleted(Tcl_Obj *objPtr); /* 227 */ EXTERN void TclSetNsPath(Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]); /* Slot 228 is reserved */ /* 229 */ EXTERN int TclPtrMakeUpvar(Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); /* 230 */ EXTERN Var * TclObjLookupVar(Tcl_Interp *interp, |
| ︙ | ︙ | |||
503 504 505 506 507 508 509 | EXTERN void TclGetSrcInfoForPc(CmdFrame *contextPtr); /* 234 */ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 235 */ EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); | | > > | > | | 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 |
EXTERN void TclGetSrcInfoForPc(CmdFrame *contextPtr);
/* 234 */
EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr,
const char *key, int *newPtr);
/* 235 */
EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr,
Namespace *nsPtr);
/* 236 */
TCL_DEPRECATED("use Tcl_BackgroundException")
void TclBackgroundException(Tcl_Interp *interp, int code);
/* 237 */
EXTERN int TclResetCancellation(Tcl_Interp *interp, int force);
/* 238 */
EXTERN int TclNRInterpProc(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
/* 239 */
EXTERN int TclNRInterpProcCore(Tcl_Interp *interp,
Tcl_Obj *procNameObj, int skip,
ProcErrorProc *errorProc);
/* 240 */
EXTERN int TclNRRunCallbacks(Tcl_Interp *interp, int result,
struct NRE_callback *rootPtr);
|
| ︙ | ︙ | |||
531 532 533 534 535 536 537 | EXTERN void TclDbDumpActiveObjects(FILE *outFile); /* 244 */ EXTERN Tcl_HashTable * TclGetNamespaceChildTable(Tcl_Namespace *nsPtr); /* 245 */ EXTERN Tcl_HashTable * TclGetNamespaceCommandTable(Tcl_Namespace *nsPtr); /* 246 */ EXTERN int TclInitRewriteEnsemble(Tcl_Interp *interp, | | | | 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 | EXTERN void TclDbDumpActiveObjects(FILE *outFile); /* 244 */ EXTERN Tcl_HashTable * TclGetNamespaceChildTable(Tcl_Namespace *nsPtr); /* 245 */ EXTERN Tcl_HashTable * TclGetNamespaceCommandTable(Tcl_Namespace *nsPtr); /* 246 */ EXTERN int TclInitRewriteEnsemble(Tcl_Interp *interp, int numRemoved, int numInserted, Tcl_Obj *const *objv); /* 247 */ EXTERN void TclResetRewriteEnsemble(Tcl_Interp *interp, int isRootEnsemble); /* 248 */ EXTERN int TclCopyChannel(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 249 */ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 250 */ EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force); /* 251 */ EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes, int length, int flags); /* 252 */ EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 253 */ EXTERN Tcl_Obj * TclPtrSetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, |
| ︙ | ︙ | |||
579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 |
EXTERN void TclStaticPackage(Tcl_Interp *interp,
const char *pkgName,
Tcl_PackageInitProc *initProc,
Tcl_PackageInitProc *safeInitProc);
/* 258 */
EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj);
typedef struct TclIntStubs {
int magic;
void *hooks;
void (*reserved0)(void);
void (*reserved1)(void);
void (*reserved2)(void);
void (*tclAllocateFreeObjects) (void); /* 3 */
void (*reserved4)(void);
int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */
void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */
| > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 |
EXTERN void TclStaticPackage(Tcl_Interp *interp,
const char *pkgName,
Tcl_PackageInitProc *initProc,
Tcl_PackageInitProc *safeInitProc);
/* 258 */
EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj);
/* 259 */
EXTERN unsigned char * TclGetBytesFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, int *lengthPtr);
/* 260 */
EXTERN void TclUnusedStubEntry(void);
typedef struct TclIntStubs {
int magic;
void *hooks;
void (*reserved0)(void);
void (*reserved1)(void);
void (*reserved2)(void);
void (*tclAllocateFreeObjects) (void); /* 3 */
void (*reserved4)(void);
int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */
void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */
int (*tclCopyAndCollapse) (int count, const char *src, char *dst); /* 7 */
TCL_DEPRECATED_API("") int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */
int (*tclCreatePipeline) (Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */
int (*tclCreateProc) (Tcl_Interp *interp, Namespace *nsPtr, const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); /* 10 */
void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */
void (*tclDeleteVars) (Interp *iPtr, TclVarHashTable *tablePtr); /* 12 */
void (*reserved13)(void);
int (*tclDumpMemoryInfo) (ClientData clientData, int flags); /* 14 */
void (*reserved15)(void);
void (*tclExprFloatError) (Tcl_Interp *interp, double value); /* 16 */
void (*reserved17)(void);
void (*reserved18)(void);
void (*reserved19)(void);
void (*reserved20)(void);
void (*reserved21)(void);
int (*tclFindElement) (Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *bracePtr); /* 22 */
Proc * (*tclFindProc) (Interp *iPtr, const char *procName); /* 23 */
int (*tclFormatInt) (char *buffer, Tcl_WideInt n); /* 24 */
void (*tclFreePackageInfo) (Interp *iPtr); /* 25 */
void (*reserved26)(void);
void (*reserved27)(void);
Tcl_Channel (*tclpGetDefaultStdChannel) (int type); /* 28 */
void (*reserved29)(void);
void (*reserved30)(void);
const char * (*tclGetExtension) (const char *name); /* 31 */
int (*tclGetFrame) (Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr); /* 32 */
void (*reserved33)(void);
TCL_DEPRECATED_API("Use Tcl_GetIntForIndex") int (*tclGetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr); /* 34 */
void (*reserved35)(void);
void (*reserved36)(void);
int (*tclGetLoadedPackages) (Tcl_Interp *interp, const char *targetName); /* 37 */
int (*tclGetNamespaceForQualName) (Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 38 */
TclObjCmdProcType (*tclGetObjInterpProc) (void); /* 39 */
int (*tclGetOpenMode) (Tcl_Interp *interp, const char *str, int *seekFlagPtr); /* 40 */
Tcl_Command (*tclGetOriginalCommand) (Tcl_Command command); /* 41 */
CONST86 char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */
void (*reserved43)(void);
int (*tclGuessPackageName) (const char *fileName, Tcl_DString *bufPtr); /* 44 */
int (*tclHideUnsafeCommands) (Tcl_Interp *interp); /* 45 */
int (*tclInExit) (void); /* 46 */
void (*reserved47)(void);
void (*reserved48)(void);
void (*reserved49)(void);
void (*tclInitCompiledLocals) (Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr); /* 50 */
int (*tclInterpInit) (Tcl_Interp *interp); /* 51 */
void (*reserved52)(void);
int (*tclInvokeObjectCommand) (ClientData clientData, Tcl_Interp *interp, int argc, const char **argv); /* 53 */
int (*tclInvokeStringCommand) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 54 */
Proc * (*tclIsProc) (Command *cmdPtr); /* 55 */
void (*reserved56)(void);
void (*reserved57)(void);
Var * (*tclLookupVar) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, const char *msg, int createPart1, int createPart2, Var **arrayPtrPtr); /* 58 */
void (*reserved59)(void);
int (*tclNeedSpace) (const char *start, const char *end); /* 60 */
Tcl_Obj * (*tclNewProcBodyObj) (Proc *procPtr); /* 61 */
int (*tclObjCommandComplete) (Tcl_Obj *cmdPtr); /* 62 */
int (*tclObjInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 63 */
int (*tclObjInvoke) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 64 */
void (*reserved65)(void);
void (*reserved66)(void);
void (*reserved67)(void);
void (*reserved68)(void);
void * (*tclpAlloc) (unsigned int size); /* 69 */
void (*reserved70)(void);
void (*reserved71)(void);
void (*reserved72)(void);
void (*reserved73)(void);
void (*tclpFree) (void *ptr); /* 74 */
unsigned long (*tclpGetClicks) (void); /* 75 */
unsigned long (*tclpGetSeconds) (void); /* 76 */
TCL_DEPRECATED_API("") void (*tclpGetTime) (Tcl_Time *time); /* 77 */
void (*reserved78)(void);
void (*reserved79)(void);
void (*reserved80)(void);
void * (*tclpRealloc) (void *ptr, unsigned int size); /* 81 */
void (*reserved82)(void);
void (*reserved83)(void);
void (*reserved84)(void);
void (*reserved85)(void);
void (*reserved86)(void);
void (*reserved87)(void);
TCL_DEPRECATED_API("") char * (*tclPrecTraceProc) (ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 88 */
int (*tclPreventAliasLoop) (Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd); /* 89 */
void (*reserved90)(void);
void (*tclProcCleanupProc) (Proc *procPtr); /* 91 */
int (*tclProcCompileProc) (Tcl_Interp *interp, Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, const char *description, const char *procName); /* 92 */
void (*tclProcDeleteProc) (ClientData clientData); /* 93 */
void (*reserved94)(void);
void (*reserved95)(void);
int (*tclRenameCommand) (Tcl_Interp *interp, const char *oldName, const char *newName); /* 96 */
void (*tclResetShadowedCmdRefs) (Tcl_Interp *interp, Command *newCmdPtr); /* 97 */
int (*tclServiceIdle) (void); /* 98 */
void (*reserved99)(void);
void (*reserved100)(void);
CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */
void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */
int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */
TCL_DEPRECATED_API("") int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */
void (*reserved105)(void);
void (*reserved106)(void);
void (*reserved107)(void);
void (*tclTeardownNamespace) (Namespace *nsPtr); /* 108 */
int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */
int (*tclSockMinimumBuffers) (void *sock, int size); /* 110 */
void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */
int (*tclAppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */
Tcl_Namespace * (*tclCreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */
void (*tclDeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */
int (*tclExport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */
Tcl_Command (*tclFindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */
Tcl_Namespace * (*tclFindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */
int (*tcl_GetInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); /* 118 */
int (*tcl_GetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolverInfo *resInfo); /* 119 */
Tcl_Var (*tcl_FindNamespaceVar) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 120 */
int (*tclForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */
Tcl_Command (*tclGetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */
void (*tclGetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */
Tcl_Namespace * (*tclGetCurrentNamespace_) (Tcl_Interp *interp); /* 124 */
Tcl_Namespace * (*tclGetGlobalNamespace_) (Tcl_Interp *interp); /* 125 */
void (*tcl_GetVariableFullName) (Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 126 */
int (*tclImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */
void (*tcl_PopCallFrame) (Tcl_Interp *interp); /* 128 */
int (*tcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */
int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */
void (*tcl_SetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 131 */
int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */
TCL_DEPRECATED_API("") struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */
void (*reserved134)(void);
void (*reserved135)(void);
void (*reserved136)(void);
void (*reserved137)(void);
const char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */
void (*reserved139)(void);
void (*reserved140)(void);
const char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */
int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, ClientData clientData); /* 142 */
int (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */
void (*tclHideLiteral) (Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 144 */
const struct AuxDataType * (*tclGetAuxDataType) (const char *typeName); /* 145 */
TclHandle (*tclHandleCreate) (void *ptr); /* 146 */
void (*tclHandleFree) (TclHandle handle); /* 147 */
TclHandle (*tclHandlePreserve) (TclHandle handle); /* 148 */
void (*tclHandleRelease) (TclHandle handle); /* 149 */
int (*tclRegAbout) (Tcl_Interp *interp, Tcl_RegExp re); /* 150 */
void (*tclRegExpRangeUniChar) (Tcl_RegExp re, int index, int *startPtr, int *endPtr); /* 151 */
void (*tclSetLibraryPath) (Tcl_Obj *pathPtr); /* 152 */
Tcl_Obj * (*tclGetLibraryPath) (void); /* 153 */
void (*reserved154)(void);
void (*reserved155)(void);
void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */
Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */
TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */
TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") const char * (*tclGetStartupScriptFileName) (void); /* 159 */
void (*reserved160)(void);
int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */
void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */
const void * (*tclGetInstructionTable) (void); /* 163 */
void (*tclExpandCodeArray) (void *envPtr); /* 164 */
void (*tclpSetInitialEncodings) (void); /* 165 */
int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 166 */
TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */
TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */
int (*tclpUtfNcmp2) (const char *s1, const char *s2, unsigned long n); /* 169 */
int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */
int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */
int (*tclInThreadExit) (void); /* 172 */
int (*tclUniCharMatch) (const Tcl_UniChar *string, int strLen, const Tcl_UniChar *pattern, int ptnLen, int flags); /* 173 */
void (*reserved174)(void);
int (*tclCallVarTraces) (Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg); /* 175 */
void (*tclCleanupVar) (Var *varPtr, Var *arrayPtr); /* 176 */
void (*tclVarErrMsg) (Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 177 */
void (*tclSetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */
Tcl_Obj * (*tclGetStartupScript) (const char **encodingNamePtr); /* 179 */
void (*reserved180)(void);
void (*reserved181)(void);
TCL_DEPRECATED_API("") struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */
TCL_DEPRECATED_API("") struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */
void (*reserved184)(void);
void (*reserved185)(void);
void (*reserved186)(void);
void (*reserved187)(void);
void (*reserved188)(void);
void (*reserved189)(void);
void (*reserved190)(void);
|
| ︙ | ︙ | |||
799 800 801 802 803 804 805 |
Tcl_Channel (*tclpOpenFileChannel) (Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode, int permissions); /* 208 */
void (*reserved209)(void);
void (*reserved210)(void);
void (*reserved211)(void);
void (*tclpFindExecutable) (const char *argv0); /* 212 */
Tcl_Obj * (*tclGetObjNameOfExecutable) (void); /* 213 */
void (*tclSetObjNameOfExecutable) (Tcl_Obj *name, Tcl_Encoding encoding); /* 214 */
| | | | | | | > > | 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 |
Tcl_Channel (*tclpOpenFileChannel) (Tcl_Interp *interp, Tcl_Obj *pathPtr, int mode, int permissions); /* 208 */
void (*reserved209)(void);
void (*reserved210)(void);
void (*reserved211)(void);
void (*tclpFindExecutable) (const char *argv0); /* 212 */
Tcl_Obj * (*tclGetObjNameOfExecutable) (void); /* 213 */
void (*tclSetObjNameOfExecutable) (Tcl_Obj *name, Tcl_Encoding encoding); /* 214 */
void * (*tclStackAlloc) (Tcl_Interp *interp, int numBytes); /* 215 */
void (*tclStackFree) (Tcl_Interp *interp, void *freePtr); /* 216 */
int (*tclPushStackFrame) (Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, Tcl_Namespace *namespacePtr, int isProcCallFrame); /* 217 */
void (*tclPopStackFrame) (Tcl_Interp *interp); /* 218 */
void (*reserved219)(void);
void (*reserved220)(void);
void (*reserved221)(void);
void (*reserved222)(void);
void (*reserved223)(void);
TclPlatformType * (*tclGetPlatform) (void); /* 224 */
Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags); /* 225 */
int (*tclObjBeingDeleted) (Tcl_Obj *objPtr); /* 226 */
void (*tclSetNsPath) (Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]); /* 227 */
void (*reserved228)(void);
int (*tclPtrMakeUpvar) (Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); /* 229 */
Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, const int createPart1, const int createPart2, Var **arrayPtrPtr); /* 230 */
int (*tclGetNamespaceFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); /* 231 */
int (*tclEvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 232 */
void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */
Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */
void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */
TCL_DEPRECATED_API("use Tcl_BackgroundException") void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */
int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */
int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */
int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */
int (*tclNRRunCallbacks) (Tcl_Interp *interp, int result, struct NRE_callback *rootPtr); /* 240 */
int (*tclNREvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, const CmdFrame *invoker, int word); /* 241 */
int (*tclNREvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 242 */
void (*tclDbDumpActiveObjects) (FILE *outFile); /* 243 */
Tcl_HashTable * (*tclGetNamespaceChildTable) (Tcl_Namespace *nsPtr); /* 244 */
Tcl_HashTable * (*tclGetNamespaceCommandTable) (Tcl_Namespace *nsPtr); /* 245 */
int (*tclInitRewriteEnsemble) (Tcl_Interp *interp, int numRemoved, int numInserted, Tcl_Obj *const *objv); /* 246 */
void (*tclResetRewriteEnsemble) (Tcl_Interp *interp, int isRootEnsemble); /* 247 */
int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */
char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */
void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */
int (*tclRegisterLiteral) (void *envPtr, const char *bytes, int length, int flags); /* 251 */
Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 252 */
Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, const int flags); /* 253 */
Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags); /* 254 */
int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */
int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */
void (*tclStaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */
Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */
unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *lengthPtr); /* 259 */
void (*tclUnusedStubEntry) (void); /* 260 */
} TclIntStubs;
extern const TclIntStubs *tclIntStubsPtr;
#ifdef __cplusplus
}
#endif
|
| ︙ | ︙ | |||
869 870 871 872 873 874 875 | /* Slot 4 is reserved */ #define TclCleanupChildren \ (tclIntStubsPtr->tclCleanupChildren) /* 5 */ #define TclCleanupCommand \ (tclIntStubsPtr->tclCleanupCommand) /* 6 */ #define TclCopyAndCollapse \ (tclIntStubsPtr->tclCopyAndCollapse) /* 7 */ | | > | 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 | /* Slot 4 is reserved */ #define TclCleanupChildren \ (tclIntStubsPtr->tclCleanupChildren) /* 5 */ #define TclCleanupCommand \ (tclIntStubsPtr->tclCleanupCommand) /* 6 */ #define TclCopyAndCollapse \ (tclIntStubsPtr->tclCopyAndCollapse) /* 7 */ #define TclCopyChannelOld \ (tclIntStubsPtr->tclCopyChannelOld) /* 8 */ #define TclCreatePipeline \ (tclIntStubsPtr->tclCreatePipeline) /* 9 */ #define TclCreateProc \ (tclIntStubsPtr->tclCreateProc) /* 10 */ #define TclDeleteCompiledLocalVars \ (tclIntStubsPtr->tclDeleteCompiledLocalVars) /* 11 */ #define TclDeleteVars \ |
| ︙ | ︙ | |||
908 909 910 911 912 913 914 | /* Slot 29 is reserved */ /* Slot 30 is reserved */ #define TclGetExtension \ (tclIntStubsPtr->tclGetExtension) /* 31 */ #define TclGetFrame \ (tclIntStubsPtr->tclGetFrame) /* 32 */ /* Slot 33 is reserved */ | | > | 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 | /* Slot 29 is reserved */ /* Slot 30 is reserved */ #define TclGetExtension \ (tclIntStubsPtr->tclGetExtension) /* 31 */ #define TclGetFrame \ (tclIntStubsPtr->tclGetFrame) /* 32 */ /* Slot 33 is reserved */ #define TclGetIntForIndex \ (tclIntStubsPtr->tclGetIntForIndex) /* 34 */ /* Slot 35 is reserved */ /* Slot 36 is reserved */ #define TclGetLoadedPackages \ (tclIntStubsPtr->tclGetLoadedPackages) /* 37 */ #define TclGetNamespaceForQualName \ (tclIntStubsPtr->tclGetNamespaceForQualName) /* 38 */ #define TclGetObjInterpProc \ |
| ︙ | ︙ | |||
975 976 977 978 979 980 981 | /* Slot 73 is reserved */ #define TclpFree \ (tclIntStubsPtr->tclpFree) /* 74 */ #define TclpGetClicks \ (tclIntStubsPtr->tclpGetClicks) /* 75 */ #define TclpGetSeconds \ (tclIntStubsPtr->tclpGetSeconds) /* 76 */ | > | | > | 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 | /* Slot 73 is reserved */ #define TclpFree \ (tclIntStubsPtr->tclpFree) /* 74 */ #define TclpGetClicks \ (tclIntStubsPtr->tclpGetClicks) /* 75 */ #define TclpGetSeconds \ (tclIntStubsPtr->tclpGetSeconds) /* 76 */ #define TclpGetTime \ (tclIntStubsPtr->tclpGetTime) /* 77 */ /* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ #define TclpRealloc \ (tclIntStubsPtr->tclpRealloc) /* 81 */ /* Slot 82 is reserved */ /* Slot 83 is reserved */ /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ /* Slot 87 is reserved */ #define TclPrecTraceProc \ (tclIntStubsPtr->tclPrecTraceProc) /* 88 */ #define TclPreventAliasLoop \ (tclIntStubsPtr->tclPreventAliasLoop) /* 89 */ /* Slot 90 is reserved */ #define TclProcCleanupProc \ (tclIntStubsPtr->tclProcCleanupProc) /* 91 */ #define TclProcCompileProc \ (tclIntStubsPtr->tclProcCompileProc) /* 92 */ |
| ︙ | ︙ | |||
1013 1014 1015 1016 1017 1018 1019 | /* Slot 100 is reserved */ #define TclSetPreInitScript \ (tclIntStubsPtr->tclSetPreInitScript) /* 101 */ #define TclSetupEnv \ (tclIntStubsPtr->tclSetupEnv) /* 102 */ #define TclSockGetPort \ (tclIntStubsPtr->tclSockGetPort) /* 103 */ | > | > | > | > | > | > | > | > | > | > | > | > | > | > | | 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 | /* Slot 100 is reserved */ #define TclSetPreInitScript \ (tclIntStubsPtr->tclSetPreInitScript) /* 101 */ #define TclSetupEnv \ (tclIntStubsPtr->tclSetupEnv) /* 102 */ #define TclSockGetPort \ (tclIntStubsPtr->tclSockGetPort) /* 103 */ #define TclSockMinimumBuffersOld \ (tclIntStubsPtr->tclSockMinimumBuffersOld) /* 104 */ /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ #define TclTeardownNamespace \ (tclIntStubsPtr->tclTeardownNamespace) /* 108 */ #define TclUpdateReturnInfo \ (tclIntStubsPtr->tclUpdateReturnInfo) /* 109 */ #define TclSockMinimumBuffers \ (tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */ #define Tcl_AddInterpResolvers \ (tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */ #define TclAppendExportList \ (tclIntStubsPtr->tclAppendExportList) /* 112 */ #define TclCreateNamespace \ (tclIntStubsPtr->tclCreateNamespace) /* 113 */ #define TclDeleteNamespace \ (tclIntStubsPtr->tclDeleteNamespace) /* 114 */ #define TclExport \ (tclIntStubsPtr->tclExport) /* 115 */ #define TclFindCommand \ (tclIntStubsPtr->tclFindCommand) /* 116 */ #define TclFindNamespace \ (tclIntStubsPtr->tclFindNamespace) /* 117 */ #define Tcl_GetInterpResolvers \ (tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */ #define Tcl_GetNamespaceResolvers \ (tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */ #define Tcl_FindNamespaceVar \ (tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */ #define TclForgetImport \ (tclIntStubsPtr->tclForgetImport) /* 121 */ #define TclGetCommandFromObj \ (tclIntStubsPtr->tclGetCommandFromObj) /* 122 */ #define TclGetCommandFullName \ (tclIntStubsPtr->tclGetCommandFullName) /* 123 */ #define TclGetCurrentNamespace_ \ (tclIntStubsPtr->tclGetCurrentNamespace_) /* 124 */ #define TclGetGlobalNamespace_ \ (tclIntStubsPtr->tclGetGlobalNamespace_) /* 125 */ #define Tcl_GetVariableFullName \ (tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */ #define TclImport \ (tclIntStubsPtr->tclImport) /* 127 */ #define Tcl_PopCallFrame \ (tclIntStubsPtr->tcl_PopCallFrame) /* 128 */ #define Tcl_PushCallFrame \ (tclIntStubsPtr->tcl_PushCallFrame) /* 129 */ #define Tcl_RemoveInterpResolvers \ (tclIntStubsPtr->tcl_RemoveInterpResolvers) /* 130 */ #define Tcl_SetNamespaceResolvers \ (tclIntStubsPtr->tcl_SetNamespaceResolvers) /* 131 */ #define TclpHasSockets \ (tclIntStubsPtr->tclpHasSockets) /* 132 */ #define TclpGetDate \ (tclIntStubsPtr->tclpGetDate) /* 133 */ /* Slot 134 is reserved */ /* Slot 135 is reserved */ /* Slot 136 is reserved */ /* Slot 137 is reserved */ #define TclGetEnv \ (tclIntStubsPtr->tclGetEnv) /* 138 */ /* Slot 139 is reserved */ |
| ︙ | ︙ | |||
1096 1097 1098 1099 1100 1101 1102 | (tclIntStubsPtr->tclGetLibraryPath) /* 153 */ /* Slot 154 is reserved */ /* Slot 155 is reserved */ #define TclRegError \ (tclIntStubsPtr->tclRegError) /* 156 */ #define TclVarTraceExists \ (tclIntStubsPtr->tclVarTraceExists) /* 157 */ | > | > | > | > | > | > | > | > | | 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 | (tclIntStubsPtr->tclGetLibraryPath) /* 153 */ /* Slot 154 is reserved */ /* Slot 155 is reserved */ #define TclRegError \ (tclIntStubsPtr->tclRegError) /* 156 */ #define TclVarTraceExists \ (tclIntStubsPtr->tclVarTraceExists) /* 157 */ #define TclSetStartupScriptFileName \ (tclIntStubsPtr->tclSetStartupScriptFileName) /* 158 */ #define TclGetStartupScriptFileName \ (tclIntStubsPtr->tclGetStartupScriptFileName) /* 159 */ /* Slot 160 is reserved */ #define TclChannelTransform \ (tclIntStubsPtr->tclChannelTransform) /* 161 */ #define TclChannelEventScriptInvoker \ (tclIntStubsPtr->tclChannelEventScriptInvoker) /* 162 */ #define TclGetInstructionTable \ (tclIntStubsPtr->tclGetInstructionTable) /* 163 */ #define TclExpandCodeArray \ (tclIntStubsPtr->tclExpandCodeArray) /* 164 */ #define TclpSetInitialEncodings \ (tclIntStubsPtr->tclpSetInitialEncodings) /* 165 */ #define TclListObjSetElement \ (tclIntStubsPtr->tclListObjSetElement) /* 166 */ #define TclSetStartupScriptPath \ (tclIntStubsPtr->tclSetStartupScriptPath) /* 167 */ #define TclGetStartupScriptPath \ (tclIntStubsPtr->tclGetStartupScriptPath) /* 168 */ #define TclpUtfNcmp2 \ (tclIntStubsPtr->tclpUtfNcmp2) /* 169 */ #define TclCheckInterpTraces \ (tclIntStubsPtr->tclCheckInterpTraces) /* 170 */ #define TclCheckExecutionTraces \ (tclIntStubsPtr->tclCheckExecutionTraces) /* 171 */ #define TclInThreadExit \ (tclIntStubsPtr->tclInThreadExit) /* 172 */ #define TclUniCharMatch \ (tclIntStubsPtr->tclUniCharMatch) /* 173 */ /* Slot 174 is reserved */ #define TclCallVarTraces \ (tclIntStubsPtr->tclCallVarTraces) /* 175 */ #define TclCleanupVar \ (tclIntStubsPtr->tclCleanupVar) /* 176 */ #define TclVarErrMsg \ (tclIntStubsPtr->tclVarErrMsg) /* 177 */ #define TclSetStartupScript \ (tclIntStubsPtr->tclSetStartupScript) /* 178 */ #define TclGetStartupScript \ (tclIntStubsPtr->tclGetStartupScript) /* 179 */ /* Slot 180 is reserved */ /* Slot 181 is reserved */ #define TclpLocaltime \ (tclIntStubsPtr->tclpLocaltime) /* 182 */ #define TclpGmtime \ (tclIntStubsPtr->tclpGmtime) /* 183 */ /* Slot 184 is reserved */ /* Slot 185 is reserved */ /* Slot 186 is reserved */ /* Slot 187 is reserved */ /* Slot 188 is reserved */ /* Slot 189 is reserved */ /* Slot 190 is reserved */ |
| ︙ | ︙ | |||
1216 1217 1218 1219 1220 1221 1222 | (tclIntStubsPtr->tclEvalObjEx) /* 232 */ #define TclGetSrcInfoForPc \ (tclIntStubsPtr->tclGetSrcInfoForPc) /* 233 */ #define TclVarHashCreateVar \ (tclIntStubsPtr->tclVarHashCreateVar) /* 234 */ #define TclInitVarHashTable \ (tclIntStubsPtr->tclInitVarHashTable) /* 235 */ | > | | 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 | (tclIntStubsPtr->tclEvalObjEx) /* 232 */ #define TclGetSrcInfoForPc \ (tclIntStubsPtr->tclGetSrcInfoForPc) /* 233 */ #define TclVarHashCreateVar \ (tclIntStubsPtr->tclVarHashCreateVar) /* 234 */ #define TclInitVarHashTable \ (tclIntStubsPtr->tclInitVarHashTable) /* 235 */ #define TclBackgroundException \ (tclIntStubsPtr->tclBackgroundException) /* 236 */ #define TclResetCancellation \ (tclIntStubsPtr->tclResetCancellation) /* 237 */ #define TclNRInterpProc \ (tclIntStubsPtr->tclNRInterpProc) /* 238 */ #define TclNRInterpProcCore \ (tclIntStubsPtr->tclNRInterpProcCore) /* 239 */ #define TclNRRunCallbacks \ |
| ︙ | ︙ | |||
1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 | (tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */ #define TclPtrUnsetVar \ (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ #define TclStaticPackage \ (tclIntStubsPtr->tclStaticPackage) /* 257 */ #define TclpCreateTemporaryDirectory \ (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #if defined(USE_TCL_STUBS) | > > > > > > > > > > > > > > > > > > | > > > > > > > > > > | | | < < < | 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 | (tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */ #define TclPtrUnsetVar \ (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ #define TclStaticPackage \ (tclIntStubsPtr->tclStaticPackage) /* 257 */ #define TclpCreateTemporaryDirectory \ (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */ #define TclGetBytesFromObj \ (tclIntStubsPtr->tclGetBytesFromObj) /* 259 */ #define TclUnusedStubEntry \ (tclIntStubsPtr->tclUnusedStubEntry) /* 260 */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #if defined(USE_TCL_STUBS) # undef TclGetStartupScriptFileName # undef TclSetStartupScriptFileName # undef TclGetStartupScriptPath # undef TclSetStartupScriptPath # undef TclBackgroundException # undef TclSetStartupScript # undef TclGetStartupScript # undef TclGetIntForIndex # undef TclCreateNamespace # undef TclDeleteNamespace # undef TclAppendExportList # undef TclExport # undef TclImport # undef TclForgetImport # undef TclGetCurrentNamespace_ # undef TclGetGlobalNamespace_ # undef TclFindNamespace # undef TclFindCommand # undef TclGetCommandFromObj # undef TclGetCommandFullName # undef TclCopyChannelOld # undef TclSockMinimumBuffersOld # undef Tcl_StaticPackage # define Tcl_StaticPackage (tclIntStubsPtr->tclStaticPackage) #endif #endif /* _TCLINTDECLS */ |
Changes to generic/tclIntPlatDecls.h.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 | /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); | | > | > | > | > | > | > > > | > > > | > > > | > > > > | > > | > | > | > > | > > | > | > > | | > | > | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 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 | /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 5 */ EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); /* 6 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 8 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 9 */ EXTERN TclFile TclpCreateTempFile(const char *contents); /* 10 */ EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); /* 11 */ EXTERN struct tm * TclpLocaltime_unix(const time_t *clock); /* 12 */ EXTERN struct tm * TclpGmtime_unix(const time_t *clock); /* 13 */ EXTERN char * TclpInetNtoa(struct in_addr addr); /* 14 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 15 */ EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 16 */ EXTERN int TclMacOSXSetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 17 */ EXTERN int TclMacOSXCopyFileAttributes(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 18 */ EXTERN int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ /* 22 */ EXTERN TclFile TclpCreateTempFile_(const char *contents); /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ /* 29 */ EXTERN int TclWinCPUID(int index, int *regs); /* 30 */ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ /* 0 */ EXTERN void TclWinConvertError(DWORD errCode); /* 1 */ EXTERN void TclWinConvertWSAError(DWORD errCode); /* 2 */ EXTERN struct servent * TclWinGetServByName(const char *nm, const char *proto); /* 3 */ EXTERN int TclWinGetSockOpt(SOCKET s, int level, int optname, char *optval, int *optlen); /* 4 */ EXTERN HINSTANCE TclWinGetTclInstance(void); /* 5 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 6 */ EXTERN unsigned short TclWinNToHS(unsigned short ns); /* 7 */ EXTERN int TclWinSetSockOpt(SOCKET s, int level, int optname, const char *optval, int optlen); /* 8 */ EXTERN int TclpGetPid(Tcl_Pid pid); /* 9 */ EXTERN int TclWinGetPlatformId(void); /* 10 */ EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); /* 11 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); /* 12 */ EXTERN int TclpCloseFile(TclFile file); /* 13 */ EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, |
| ︙ | ︙ | |||
134 135 136 137 138 139 140 | const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 18 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 19 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 20 */ | | | > | > | > | 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 | const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 18 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 19 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 20 */ EXTERN void TclWinAddProcess(HANDLE hProcess, DWORD id); /* 21 */ EXTERN char * TclpInetNtoa(struct in_addr addr); /* 22 */ EXTERN TclFile TclpCreateTempFile(const char *contents); /* Slot 23 is reserved */ /* 24 */ EXTERN char * TclWinNoBackslash(char *path); /* Slot 25 is reserved */ /* 26 */ EXTERN void TclWinSetInterfaces(int wide); /* 27 */ EXTERN void TclWinFlushDirtyChannels(void); /* 28 */ EXTERN void TclWinResetInterfaces(void); /* 29 */ EXTERN int TclWinCPUID(int index, int *regs); /* 30 */ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); #endif /* WIN */ |
| ︙ | ︙ | |||
170 171 172 173 174 175 176 | /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); | | > | > | > | > | > | 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 | /* 3 */ EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); /* 4 */ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 5 */ EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); /* 6 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 8 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); /* 9 */ EXTERN TclFile TclpCreateTempFile(const char *contents); /* 10 */ EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); /* 11 */ EXTERN struct tm * TclpLocaltime_unix(const time_t *clock); /* 12 */ EXTERN struct tm * TclpGmtime_unix(const time_t *clock); /* 13 */ EXTERN char * TclpInetNtoa(struct in_addr addr); /* 14 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 15 */ EXTERN int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, |
| ︙ | ︙ | |||
209 210 211 212 213 214 215 | Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ | | > | 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 | Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 19 */ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ /* 22 */ EXTERN TclFile TclpCreateTempFile_(const char *contents); /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ /* 29 */ |
| ︙ | ︙ | |||
234 235 236 237 238 239 240 |
#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
int (*tclpCloseFile) (TclFile file); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 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 |
#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
int (*tclpCloseFile) (TclFile file); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 5 */
TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */
TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */
int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */
TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */
Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */
struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */
struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */
char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */
int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */
int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */
int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */
int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */
int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */
void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */
void (*reserved20)(void);
void (*reserved21)(void);
TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */
void (*reserved23)(void);
void (*reserved24)(void);
void (*reserved25)(void);
void (*reserved26)(void);
void (*reserved27)(void);
void (*reserved28)(void);
int (*tclWinCPUID) (int index, int *regs); /* 29 */
int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
#endif /* UNIX */
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
void (*tclWinConvertError) (DWORD errCode); /* 0 */
void (*tclWinConvertWSAError) (DWORD errCode); /* 1 */
struct servent * (*tclWinGetServByName) (const char *nm, const char *proto); /* 2 */
int (*tclWinGetSockOpt) (SOCKET s, int level, int optname, char *optval, int *optlen); /* 3 */
HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */
int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */
unsigned short (*tclWinNToHS) (unsigned short ns); /* 6 */
int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, const char *optval, int optlen); /* 7 */
int (*tclpGetPid) (Tcl_Pid pid); /* 8 */
int (*tclWinGetPlatformId) (void); /* 9 */
Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */
int (*tclpCloseFile) (TclFile file); /* 12 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 14 */
int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */
int (*tclpIsAtty) (int fd); /* 16 */
int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */
TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */
TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */
void (*tclWinAddProcess) (HANDLE hProcess, DWORD id); /* 20 */
char * (*tclpInetNtoa) (struct in_addr addr); /* 21 */
TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */
void (*reserved23)(void);
char * (*tclWinNoBackslash) (char *path); /* 24 */
void (*reserved25)(void);
void (*tclWinSetInterfaces) (int wide); /* 26 */
void (*tclWinFlushDirtyChannels) (void); /* 27 */
void (*tclWinResetInterfaces) (void); /* 28 */
int (*tclWinCPUID) (int index, int *regs); /* 29 */
int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
int (*tclpCloseFile) (TclFile file); /* 1 */
Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */
int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 4 */
int (*tclUnixWaitForFile_) (int fd, int mask, int timeout); /* 5 */
TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */
TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */
int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */
TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */
Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */
struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */
struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */
char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */
int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */
int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */
int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */
int (*tclMacOSXCopyFileAttributes) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr); /* 17 */
int (*tclMacOSXMatchType) (Tcl_Interp *interp, const char *pathName, const char *fileName, Tcl_StatBuf *statBufPtr, Tcl_GlobTypeData *types); /* 18 */
void (*tclMacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 19 */
void (*reserved20)(void);
void (*reserved21)(void);
TclFile (*tclpCreateTempFile_) (const char *contents); /* 22 */
void (*reserved23)(void);
void (*reserved24)(void);
void (*reserved25)(void);
void (*reserved26)(void);
void (*reserved27)(void);
void (*reserved28)(void);
int (*tclWinCPUID) (int index, int *regs); /* 29 */
|
| ︙ | ︙ | |||
352 353 354 355 356 357 358 | (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ | | > | | | | > > > > < < < < | > > > > > > > > > < > > | | | > > > | | > > < < > > > > | > | > < > > | > | | | | > > > > | > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > | | 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 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 | (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ #define TclUnixWaitForFile_ \ (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ #define TclpReaddir \ (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ #define TclpLocaltime_unix \ (tclIntPlatStubsPtr->tclpLocaltime_unix) /* 11 */ #define TclpGmtime_unix \ (tclIntPlatStubsPtr->tclpGmtime_unix) /* 12 */ #define TclpInetNtoa \ (tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ #define TclMacOSXGetFileAttribute \ (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */ #define TclMacOSXSetFileAttribute \ (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */ #define TclMacOSXCopyFileAttributes \ (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ #define TclMacOSXMatchType \ (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ #define TclpCreateTempFile_ \ (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #define TclUnixOpenTemporaryFile \ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ #define TclWinConvertError \ (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ #define TclWinConvertWSAError \ (tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */ #define TclWinGetServByName \ (tclIntPlatStubsPtr->tclWinGetServByName) /* 2 */ #define TclWinGetSockOpt \ (tclIntPlatStubsPtr->tclWinGetSockOpt) /* 3 */ #define TclWinGetTclInstance \ (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ #define TclWinNToHS \ (tclIntPlatStubsPtr->tclWinNToHS) /* 6 */ #define TclWinSetSockOpt \ (tclIntPlatStubsPtr->tclWinSetSockOpt) /* 7 */ #define TclpGetPid \ (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ #define TclWinGetPlatformId \ (tclIntPlatStubsPtr->tclWinGetPlatformId) /* 9 */ #define TclpReaddir \ (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 12 */ #define TclpCreateCommandChannel \ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 14 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */ #define TclpIsAtty \ (tclIntPlatStubsPtr->tclpIsAtty) /* 16 */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 17 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 18 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 19 */ #define TclWinAddProcess \ (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */ #define TclpInetNtoa \ (tclIntPlatStubsPtr->tclpInetNtoa) /* 21 */ #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ /* Slot 23 is reserved */ #define TclWinNoBackslash \ (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ /* Slot 25 is reserved */ #define TclWinSetInterfaces \ (tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */ #define TclWinFlushDirtyChannels \ (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */ #define TclWinResetInterfaces \ (tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #define TclUnixOpenTemporaryFile \ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ #define TclpCreateCommandChannel \ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ #define TclpCreatePipe \ (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ #define TclUnixWaitForFile_ \ (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 8 */ #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ #define TclpReaddir \ (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ #define TclpLocaltime_unix \ (tclIntPlatStubsPtr->tclpLocaltime_unix) /* 11 */ #define TclpGmtime_unix \ (tclIntPlatStubsPtr->tclpGmtime_unix) /* 12 */ #define TclpInetNtoa \ (tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ #define TclMacOSXGetFileAttribute \ (tclIntPlatStubsPtr->tclMacOSXGetFileAttribute) /* 15 */ #define TclMacOSXSetFileAttribute \ (tclIntPlatStubsPtr->tclMacOSXSetFileAttribute) /* 16 */ #define TclMacOSXCopyFileAttributes \ (tclIntPlatStubsPtr->tclMacOSXCopyFileAttributes) /* 17 */ #define TclMacOSXMatchType \ (tclIntPlatStubsPtr->tclMacOSXMatchType) /* 18 */ #define TclMacOSXNotifierAddRunLoopMode \ (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ #define TclpCreateTempFile_ \ (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* Slot 28 is reserved */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #define TclUnixOpenTemporaryFile \ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* MACOSX */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #undef TclpLocaltime_unix #undef TclpGmtime_unix #undef TclWinConvertWSAError #define TclWinConvertWSAError TclWinConvertError #undef TclpInetNtoa #define TclpInetNtoa inet_ntoa #undef TclpCreateTempFile_ #undef TclUnixWaitForFile_ #ifndef MAC_OSX_TCL /* not accessable on Win32/UNIX */ #undef TclMacOSXGetFileAttribute /* 15 */ #undef TclMacOSXSetFileAttribute /* 16 */ #undef TclMacOSXCopyFileAttributes /* 17 */ #undef TclMacOSXMatchType /* 18 */ #undef TclMacOSXNotifierAddRunLoopMode /* 19 */ #endif #if defined(_WIN32) # undef TclWinNToHS # undef TclWinGetServByName # undef TclWinGetSockOpt # undef TclWinSetSockOpt # undef TclWinGetPlatformId # undef TclWinResetInterfaces # undef TclWinSetInterfaces # if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # define TclWinNToHS ntohs # define TclWinGetServByName getservbyname # define TclWinGetSockOpt getsockopt # define TclWinSetSockOpt setsockopt # define TclWinGetPlatformId() (2) /* VER_PLATFORM_WIN32_NT */ # define TclWinResetInterfaces() /* nop */ # define TclWinSetInterfaces(dummy) /* nop */ # endif /* TCL_NO_DEPRECATED */ #else # undef TclpGetPid # define TclpGetPid(pid) ((unsigned long) (pid)) #endif #endif /* _TCLINTPLATDECLS */ |
Changes to generic/tclInterp.c.
| ︙ | ︙ | |||
21 22 23 24 25 26 27 | static const char *tclPreInitScript = NULL; /* Forward declaration */ struct Target; /* | | | | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
static const char *tclPreInitScript = NULL;
/* Forward declaration */
struct Target;
/*
* struct Alias:
*
* Stores information about an alias. Is stored in the slave interpreter and
* used by the source command to find the target command in the master when
* the source command is invoked.
*/
typedef struct Alias {
Tcl_Obj *token; /* Token for the alias command in the slave
* interp. This used to be the command name in
* the slave when the alias was first
* created. */
Tcl_Interp *targetInterp; /* Interp in which target command will be
* invoked. */
Tcl_Command slaveCmd; /* Source command in slave interpreter, bound
|
| ︙ | ︙ | |||
62 63 64 65 66 67 68 | * the structure, which will be extended to * accomodate the remaining objects in the * prefix. */ } Alias; /* * | | | | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 |
* the structure, which will be extended to
* accomodate the remaining objects in the
* prefix. */
} Alias;
/*
*
* struct Slave:
*
* Used by the "interp" command to record and find information about slave
* interpreters. Maps from a command name in the master to information about a
* slave interpreter, e.g. what aliases are defined in it.
*/
typedef struct Slave {
Tcl_Interp *masterInterp; /* Master interpreter for this slave. */
Tcl_HashEntry *slaveEntryPtr;
/* Hash entry in masters slave table for this
* slave interpreter. Used to find this
* record, and used when deleting the slave
* interpreter to delete it from the master's
* table. */
|
| ︙ | ︙ | |||
108 109 110 111 112 113 114 |
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;
/*
| | | | | | | 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 |
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 Master:
*
* This record is used for two purposes: First, slaveTable (a hashtable) maps
* from names of commands to slave interpreters. This hashtable is used to
* store information about slave interpreters of this interpreter, to map over
* all slaves, etc. The second purpose is to store information about all
* aliases in slaves (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 slave interpreters and can
* only load safe extensions.
*/
typedef struct Master {
Tcl_HashTable slaveTable; /* Hash table for slave interpreters. Maps
* from command names to Slave records. */
Target *targetsPtr; /* The head of a doubly-linked list of all the
* target records which denote aliases from
* slaves or sibling interpreters that direct
* to commands in this interpreter. This list
* is used to remove dangling pointers from
* the slave (or sibling) interpreters when
* this interpreter is deleted. */
} Master;
/*
* The following structure keeps track of all the Master and Slave information
* on a per-interp basis.
*/
typedef struct InterpInfo {
Master master; /* Keeps track of all interps for which this
* interp is the Master. */
Slave slave; /* Information necessary for this interp to
* function as a slave. */
} 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.
*/
typedef struct ScriptLimitCallback {
Tcl_Interp *interp; /* The interpreter in which to execute the
* callback. */
Tcl_Obj *scriptObj; /* The script to execute to perform the
* user-defined part of the callback. */
int type; /* What kind of callback is this. */
Tcl_HashEntry *entryPtr; /* The entry in the hash table maintained by
* the target interpreter that refers to this
* callback record, or NULL if the entry has
* already been deleted from that hash
* table. */
} ScriptLimitCallback;
typedef struct ScriptLimitCallbackKey {
Tcl_Interp *interp; /* The interpreter that the limit callback was
* attached to. This is not the interpreter
* that the callback runs in! */
long type; /* The type of callback that this is. */
} ScriptLimitCallbackKey;
/*
|
| ︙ | ︙ | |||
218 219 220 221 222 223 224 | Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc, Tcl_Obj *const objv[]); static int AliasDelete(Tcl_Interp *interp, Tcl_Interp *slaveInterp, Tcl_Obj *namePtr); static int AliasDescribe(Tcl_Interp *interp, Tcl_Interp *slaveInterp, Tcl_Obj *objPtr); static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp); | | < < | | < | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 | Tcl_Obj *namePtr, Tcl_Obj *targetPtr, int objc, Tcl_Obj *const objv[]); static int AliasDelete(Tcl_Interp *interp, Tcl_Interp *slaveInterp, Tcl_Obj *namePtr); static int AliasDescribe(Tcl_Interp *interp, Tcl_Interp *slaveInterp, Tcl_Obj *objPtr); static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp); 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 SlaveBgerror(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *const objv[]); static Tcl_Interp * SlaveCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr, int safe); static int SlaveDebugCmd(Tcl_Interp *interp, Tcl_Interp *slaveInterp, |
| ︙ | ︙ | |||
250 251 252 253 254 255 256 | Tcl_Interp *slaveInterp); static int SlaveInvokeHidden(Tcl_Interp *interp, Tcl_Interp *slaveInterp, const char *namespaceName, int objc, Tcl_Obj *const objv[]); static int SlaveMarkTrusted(Tcl_Interp *interp, Tcl_Interp *slaveInterp); | | | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 | Tcl_Interp *slaveInterp); static int SlaveInvokeHidden(Tcl_Interp *interp, Tcl_Interp *slaveInterp, const char *namespaceName, int objc, Tcl_Obj *const objv[]); static int SlaveMarkTrusted(Tcl_Interp *interp, Tcl_Interp *slaveInterp); static Tcl_CmdDeleteProc SlaveObjCmdDeleteProc; static int SlaveRecursionLimit(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *const objv[]); static int SlaveCommandLimitCmd(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int consumedObjc, int objc, Tcl_Obj *const objv[]); static int SlaveTimeLimitCmd(Tcl_Interp *interp, |
| ︙ | ︙ | |||
332 333 334 335 336 337 338 |
} PkgName;
int
Tcl_Init(
Tcl_Interp *interp) /* Interpreter to initialize. */
{
PkgName pkgName = {NULL, "Tcl"};
| | | 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 |
} PkgName;
int
Tcl_Init(
Tcl_Interp *interp) /* Interpreter to initialize. */
{
PkgName pkgName = {NULL, "Tcl"};
PkgName **names = (PkgName **)TclInitPkgFiles(interp);
int result = TCL_ERROR;
pkgName.nextPtr = *names;
*names = &pkgName;
if (tclPreInitScript != NULL) {
if (Tcl_EvalEx(interp, tclPreInitScript, -1, 0) == TCL_ERROR) {
goto end;
|
| ︙ | ︙ | |||
481 482 483 484 485 486 487 |
TclInterpInit(
Tcl_Interp *interp) /* Interpreter to initialize. */
{
InterpInfo *interpInfoPtr;
Master *masterPtr;
Slave *slavePtr;
| | | 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 |
TclInterpInit(
Tcl_Interp *interp) /* Interpreter to initialize. */
{
InterpInfo *interpInfoPtr;
Master *masterPtr;
Slave *slavePtr;
interpInfoPtr = (InterpInfo *)ckalloc(sizeof(InterpInfo));
((Interp *) interp)->interpInfo = interpInfoPtr;
masterPtr = &interpInfoPtr->master;
Tcl_InitHashTable(&masterPtr->slaveTable, TCL_STRING_KEYS);
masterPtr->targetsPtr = NULL;
slavePtr = &interpInfoPtr->slave;
|
| ︙ | ︙ | |||
521 522 523 524 525 526 527 | * Cleans up storage. Sets the interpInfoPtr field of the interp to NULL. * *--------------------------------------------------------------------------- */ static void InterpInfoDeleteProc( | | | 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 |
* Cleans up storage. Sets the interpInfoPtr field of the interp to NULL.
*
*---------------------------------------------------------------------------
*/
static void
InterpInfoDeleteProc(
TCL_UNUSED(ClientData),
Tcl_Interp *interp) /* Interp being deleted. All commands for
* slave interps should already be deleted. */
{
InterpInfo *interpInfoPtr;
Slave *slavePtr;
Master *masterPtr;
Target *targetPtr;
|
| ︙ | ︙ | |||
578 579 580 581 582 583 584 |
*/
if (slavePtr->aliasTable.numEntries != 0) {
Tcl_Panic("InterpInfoDeleteProc: still exist aliases");
}
Tcl_DeleteHashTable(&slavePtr->aliasTable);
| | | | | | 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 |
*/
if (slavePtr->aliasTable.numEntries != 0) {
Tcl_Panic("InterpInfoDeleteProc: still exist aliases");
}
Tcl_DeleteHashTable(&slavePtr->aliasTable);
ckfree(interpInfoPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_InterpObjCmd --
*
* This function is invoked to process the "interp" Tcl command. See the
* user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_InterpObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv);
}
static int
NRInterpCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Interp *slaveInterp;
int index;
static const char *const options[] = {
|
| ︙ | ︙ | |||
782 783 784 785 786 787 788 |
/*
* Weird historical rules: "-safe" is accepted at the end, too.
*/
slavePtr = NULL;
last = 0;
for (i = 2; i < objc; i++) {
| | | 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 |
/*
* Weird historical rules: "-safe" is accepted at the end, too.
*/
slavePtr = 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;
|
| ︙ | ︙ | |||
995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 |
switch ((enum LimitTypes) limitType) {
case LIMIT_TYPE_COMMANDS:
return SlaveCommandLimitCmd(interp, slaveInterp, 4, objc,objv);
case LIMIT_TYPE_TIME:
return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv);
}
}
case OPT_MARKTRUSTED:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "path");
return TCL_ERROR;
}
slaveInterp = GetInterp(interp, objv[2]);
if (slaveInterp == NULL) {
| > | 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 |
switch ((enum LimitTypes) limitType) {
case LIMIT_TYPE_COMMANDS:
return SlaveCommandLimitCmd(interp, slaveInterp, 4, objc,objv);
case LIMIT_TYPE_TIME:
return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv);
}
}
break;
case OPT_MARKTRUSTED:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "path");
return TCL_ERROR;
}
slaveInterp = GetInterp(interp, objv[2]);
if (slaveInterp == NULL) {
|
| ︙ | ︙ | |||
1030 1031 1032 1033 1034 1035 1036 |
if (slaveInterp == NULL) {
return TCL_ERROR;
}
iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
resultPtr = Tcl_NewObj();
hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch);
for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
| | | 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 |
if (slaveInterp == NULL) {
return TCL_ERROR;
}
iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
resultPtr = Tcl_NewObj();
hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch);
for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
string = (char *)Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr);
Tcl_ListObjAppendElement(NULL, resultPtr,
Tcl_NewStringObj(string, -1));
}
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
case OPT_TRANSFER:
|
| ︙ | ︙ | |||
1096 1097 1098 1099 1100 1101 1102 |
aliasName = TclGetString(objv[3]);
iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"alias \"%s\" in path \"%s\" not found",
| | | | | 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 |
aliasName = TclGetString(objv[3]);
iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"alias \"%s\" in path \"%s\" not found",
aliasName, Tcl_GetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName,
NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *)Tcl_GetHashValue(hPtr);
if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"target interpreter for alias \"%s\" in path \"%s\" is "
"not my descendant", aliasName, Tcl_GetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
"TARGETSHROUDED", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
}
|
| ︙ | ︙ | |||
1184 1185 1186 1187 1188 1189 1190 |
const char *const *argv) /* These are the additional args. */
{
Tcl_Obj *slaveObjPtr, *targetObjPtr;
Tcl_Obj **objv;
int i;
int result;
| | | 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 |
const char *const *argv) /* These are the additional args. */
{
Tcl_Obj *slaveObjPtr, *targetObjPtr;
Tcl_Obj **objv;
int i;
int result;
objv = (Tcl_Obj **)TclStackAlloc(slaveInterp, sizeof(Tcl_Obj *) * argc);
for (i = 0; i < argc; i++) {
objv[i] = Tcl_NewStringObj(argv[i], -1);
Tcl_IncrRefCount(objv[i]);
}
slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1);
Tcl_IncrRefCount(slaveObjPtr);
|
| ︙ | ︙ | |||
1290 1291 1292 1293 1294 1295 1296 |
hPtr = Tcl_FindHashEntry(&iiPtr->slave.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;
}
| | | | 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 |
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"alias \"%s\" not found", aliasName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *)Tcl_GetHashValue(hPtr);
objc = aliasPtr->objc;
objv = &aliasPtr->objPtr;
if (targetInterpPtr != NULL) {
*targetInterpPtr = aliasPtr->targetInterp;
}
if (targetNamePtr != NULL) {
*targetNamePtr = TclGetString(objv[0]);
}
if (argcPtr != NULL) {
*argcPtr = objc - 1;
}
if (argvPtr != NULL) {
*argvPtr = (const char **)
ckalloc(sizeof(const char *) * (objc - 1));
for (i = 1; i < objc; i++) {
(*argvPtr)[i - 1] = TclGetString(objv[i]);
}
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
1352 1353 1354 1355 1356 1357 1358 |
hPtr = Tcl_FindHashEntry(&iiPtr->slave.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;
}
| | | 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 |
hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName);
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"alias \"%s\" not found", aliasName));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, NULL);
return TCL_ERROR;
}
aliasPtr = (Alias *)Tcl_GetHashValue(hPtr);
objc = aliasPtr->objc;
objv = &aliasPtr->objPtr;
if (targetInterpPtr != NULL) {
*targetInterpPtr = aliasPtr->targetInterp;
}
if (targetNamePtr != NULL) {
|
| ︙ | ︙ | |||
1421 1422 1423 1424 1425 1426 1427 |
/*
* OK, we are dealing with an alias, so traverse the chain of aliases. If
* we encounter the alias we are defining (or renaming to) any in the
* chain then we have a loop.
*/
| | | 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 |
/*
* OK, we are dealing with an alias, so traverse the chain of aliases. If
* we encounter the alias we are defining (or renaming to) any in the
* chain then we have a loop.
*/
aliasPtr = (Alias *)cmdPtr->objClientData;
nextAliasPtr = aliasPtr;
while (1) {
Tcl_Obj *cmdNamePtr;
/*
* If the target of the next alias in the chain is the same as the
* source alias, we have a loop.
|
| ︙ | ︙ | |||
1470 1471 1472 1473 1474 1475 1476 |
* Otherwise we do not have a loop.
*/
if (aliasCmdPtr->objProc != TclAliasObjCmd
&& aliasCmdPtr->objProc != TclLocalAliasObjCmd) {
return TCL_OK;
}
| | < < | 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 |
* Otherwise we do not have a loop.
*/
if (aliasCmdPtr->objProc != TclAliasObjCmd
&& aliasCmdPtr->objProc != TclLocalAliasObjCmd) {
return TCL_OK;
}
nextAliasPtr = (Alias *)aliasCmdPtr->objClientData;
}
}
/*
*----------------------------------------------------------------------
*
* AliasCreate --
*
|
| ︙ | ︙ | |||
1513 1514 1515 1516 1517 1518 1519 |
Tcl_HashEntry *hPtr;
Target *targetPtr;
Slave *slavePtr;
Master *masterPtr;
Tcl_Obj **prefv;
int isNew, i;
| | | 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 |
Tcl_HashEntry *hPtr;
Target *targetPtr;
Slave *slavePtr;
Master *masterPtr;
Tcl_Obj **prefv;
int isNew, i;
aliasPtr = (Alias *)ckalloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *));
aliasPtr->token = namePtr;
Tcl_IncrRefCount(aliasPtr->token);
aliasPtr->targetInterp = masterInterp;
aliasPtr->objc = objc + 1;
prefv = &aliasPtr->objPtr;
|
| ︙ | ︙ | |||
1564 1565 1566 1567 1568 1569 1570 | cmdPtr = (Command *) aliasPtr->slaveCmd; cmdPtr->clientData = NULL; cmdPtr->deleteProc = NULL; cmdPtr->deleteData = NULL; Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); | | | 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 | cmdPtr = (Command *) aliasPtr->slaveCmd; cmdPtr->clientData = NULL; cmdPtr->deleteProc = NULL; cmdPtr->deleteData = NULL; Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); ckfree(aliasPtr); /* * The result was already set by TclPreventAliasLoop. */ Tcl_Release(slaveInterp); Tcl_Release(masterInterp); |
| ︙ | ︙ | |||
1621 1622 1623 1624 1625 1626 1627 |
* because the alias may be pointing at a renamed alias, as in:
*
* interp alias {} foo {} bar # Create an alias "foo"
* rename foo zop # Now rename the alias
* interp alias {} foo {} zop # Now recreate "foo"...
*/
| | | 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 |
* because the alias may be pointing at a renamed alias, as in:
*
* interp alias {} foo {} bar # Create an alias "foo"
* rename foo zop # Now rename the alias
* interp alias {} foo {} zop # Now recreate "foo"...
*/
targetPtr = (Target *)ckalloc(sizeof(Target));
targetPtr->slaveCmd = aliasPtr->slaveCmd;
targetPtr->slaveInterp = slaveInterp;
masterPtr = &((InterpInfo*) ((Interp*) masterInterp)->interpInfo)->master;
targetPtr->nextPtr = masterPtr->targetsPtr;
targetPtr->prevPtr = NULL;
if (masterPtr->targetsPtr != NULL) {
|
| ︙ | ︙ | |||
1682 1683 1684 1685 1686 1687 1688 |
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;
}
| | | 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 |
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(slaveInterp, aliasPtr->slaveCmd);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1723 1724 1725 1726 1727 1728 1729 |
/*
* If the alias has been renamed in the slave, the master can still use
* the original name (with which it was created) to find the alias to
* describe it.
*/
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
| | | | 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 |
/*
* If the alias has been renamed in the slave, the master can still use
* the original name (with which it was created) to find the alias to
* describe it.
*/
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
hPtr = Tcl_FindHashEntry(&slavePtr->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;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1764 1765 1766 1767 1768 1769 1770 |
Alias *aliasPtr;
Slave *slavePtr;
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch);
for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) {
| | | 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 |
Alias *aliasPtr;
Slave *slavePtr;
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
entryPtr = Tcl_FirstHashEntry(&slavePtr->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;
}
/*
|
| ︙ | ︙ | |||
1805 1806 1807 1808 1809 1810 1811 |
static int
AliasNRCmd(
ClientData clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument vector. */
{
| | | 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 |
static int
AliasNRCmd(
ClientData clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument vector. */
{
Alias *aliasPtr = (Alias *)clientData;
int prefc, cmdc, i;
Tcl_Obj **prefv, **cmdv;
Tcl_Obj *listPtr;
List *listRep;
int flags = TCL_EVAL_INVOKE;
/*
|
| ︙ | ︙ | |||
1827 1828 1829 1830 1831 1832 1833 |
listPtr = Tcl_NewListObj(cmdc, NULL);
listRep = ListRepPtr(listPtr);
listRep->elemCount = cmdc;
cmdv = &listRep->elements;
prefv = &aliasPtr->objPtr;
| | | | 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 |
listPtr = Tcl_NewListObj(cmdc, NULL);
listRep = ListRepPtr(listPtr);
listRep->elemCount = cmdc;
cmdv = &listRep->elements;
prefv = &aliasPtr->objPtr;
memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *));
memcpy(cmdv+prefc, objv+1, (objc-1) * sizeof(Tcl_Obj *));
for (i=0; i<cmdc; i++) {
Tcl_IncrRefCount(cmdv[i]);
}
/*
* Use the ensemble rewriting machinery to ensure correct error messages:
|
| ︙ | ︙ | |||
1854 1855 1856 1857 1858 1859 1860 |
TclAliasObjCmd(
ClientData clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument vector. */
{
#define ALIAS_CMDV_PREALLOC 10
| | | | 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 |
TclAliasObjCmd(
ClientData clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument vector. */
{
#define ALIAS_CMDV_PREALLOC 10
Alias *aliasPtr = (Alias *)clientData;
Tcl_Interp *targetInterp = aliasPtr->targetInterp;
int result, prefc, cmdc, i;
Tcl_Obj **prefv, **cmdv;
Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
Interp *tPtr = (Interp *) targetInterp;
int isRootEnsemble;
/*
* Append the arguments to the command prefix and invoke the command in
* the target interp's global namespace.
*/
prefc = aliasPtr->objc;
prefv = &aliasPtr->objPtr;
cmdc = prefc + objc - 1;
if (cmdc <= ALIAS_CMDV_PREALLOC) {
cmdv = cmdArr;
} else {
cmdv = (Tcl_Obj **)TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *));
}
memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *));
memcpy(cmdv+prefc, objv+1, (objc-1) * sizeof(Tcl_Obj *));
Tcl_ResetResult(targetInterp);
|
| ︙ | ︙ | |||
1945 1946 1947 1948 1949 1950 1951 |
TclLocalAliasObjCmd(
ClientData clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument vector. */
{
#define ALIAS_CMDV_PREALLOC 10
| | | | 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 |
TclLocalAliasObjCmd(
ClientData clientData, /* Alias record. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument vector. */
{
#define ALIAS_CMDV_PREALLOC 10
Alias *aliasPtr = (Alias *)clientData;
int result, prefc, cmdc, i;
Tcl_Obj **prefv, **cmdv;
Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC];
Interp *iPtr = (Interp *) interp;
int isRootEnsemble;
/*
* Append the arguments to the command prefix and invoke the command in
* the global namespace.
*/
prefc = aliasPtr->objc;
prefv = &aliasPtr->objPtr;
cmdc = prefc + objc - 1;
if (cmdc <= ALIAS_CMDV_PREALLOC) {
cmdv = cmdArr;
} else {
cmdv = (Tcl_Obj **)TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *));
}
memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *));
memcpy(cmdv+prefc, objv+1, (objc-1) * sizeof(Tcl_Obj *));
for (i=0; i<cmdc; i++) {
Tcl_IncrRefCount(cmdv[i]);
|
| ︙ | ︙ | |||
2026 2027 2028 2029 2030 2031 2032 |
*----------------------------------------------------------------------
*/
static void
AliasObjCmdDeleteProc(
ClientData clientData) /* The alias record for this alias. */
{
| | | 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 |
*----------------------------------------------------------------------
*/
static void
AliasObjCmdDeleteProc(
ClientData clientData) /* The alias record for this alias. */
{
Alias *aliasPtr = (Alias *)clientData;
Target *targetPtr;
int i;
Tcl_Obj **objv;
Tcl_DecrRefCount(aliasPtr->token);
objv = &aliasPtr->objPtr;
for (i = 0; i < aliasPtr->objc; i++) {
|
| ︙ | ︙ | |||
2055 2056 2057 2058 2059 2060 2061 |
masterPtr->targetsPtr = targetPtr->nextPtr;
}
if (targetPtr->nextPtr != NULL) {
targetPtr->nextPtr->prevPtr = targetPtr->prevPtr;
}
| | | | 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 |
masterPtr->targetsPtr = targetPtr->nextPtr;
}
if (targetPtr->nextPtr != NULL) {
targetPtr->nextPtr->prevPtr = targetPtr->prevPtr;
}
ckfree(targetPtr);
ckfree(aliasPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateSlave --
*
|
| ︙ | ︙ | |||
2202 2203 2204 2205 2206 2207 2208 |
flags &= (CANCELED | TCL_CANCEL_UNWIND);
masterPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->master;
hPtr = Tcl_FirstHashEntry(&masterPtr->slaveTable, &hashSearch);
for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
| | | 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 |
flags &= (CANCELED | TCL_CANCEL_UNWIND);
masterPtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->master;
hPtr = Tcl_FirstHashEntry(&masterPtr->slaveTable, &hashSearch);
for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) {
slavePtr = (Slave *)Tcl_GetHashValue(hPtr);
iPtr = (Interp *) slavePtr->slaveInterp;
if (iPtr == NULL) {
continue;
}
if (flags == 0) {
|
| ︙ | ︙ | |||
2267 2268 2269 2270 2271 2272 2273 |
return TCL_ERROR;
}
iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK){
return TCL_ERROR;
}
Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(askingInterp),
| | | 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 |
return TCL_ERROR;
}
iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo;
if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK){
return TCL_ERROR;
}
Tcl_ListObjAppendElement(NULL, Tcl_GetObjResult(askingInterp),
Tcl_NewStringObj((const char *)Tcl_GetHashKey(&iiPtr->master.slaveTable,
iiPtr->slave.slaveEntryPtr), -1));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2315 2316 2317 2318 2319 2320 2321 |
masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo;
hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable,
TclGetString(objv[i]));
if (hPtr == NULL) {
searchInterp = NULL;
break;
}
| | | 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 |
masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo;
hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable,
TclGetString(objv[i]));
if (hPtr == NULL) {
searchInterp = NULL;
break;
}
slavePtr = (Slave *)Tcl_GetHashValue(hPtr);
searchInterp = slavePtr->slaveInterp;
if (searchInterp == NULL) {
break;
}
}
if (searchInterp == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
| ︙ | ︙ | |||
2541 2542 2543 2544 2545 2546 2547 |
static int
NRSlaveCmd(
ClientData clientData, /* Slave interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 |
static int
NRSlaveCmd(
ClientData clientData, /* Slave interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Interp *slaveInterp = (Tcl_Interp *)clientData;
int index;
static const char *const options[] = {
"alias", "aliases", "bgerror", "debug",
"eval", "expose", "hide", "hidden",
"issafe", "invokehidden", "limit", "marktrusted",
"recursionlimit", NULL
};
|
| ︙ | ︙ | |||
2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 |
switch ((enum LimitTypes) limitType) {
case LIMIT_TYPE_COMMANDS:
return SlaveCommandLimitCmd(interp, slaveInterp, 3, objc,objv);
case LIMIT_TYPE_TIME:
return SlaveTimeLimitCmd(interp, slaveInterp, 3, objc, objv);
}
}
case OPT_MARKTRUSTED:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
return SlaveMarkTrusted(interp, slaveInterp);
case OPT_RECLIMIT:
| > | 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 |
switch ((enum LimitTypes) limitType) {
case LIMIT_TYPE_COMMANDS:
return SlaveCommandLimitCmd(interp, slaveInterp, 3, objc,objv);
case LIMIT_TYPE_TIME:
return SlaveTimeLimitCmd(interp, slaveInterp, 3, objc, objv);
}
}
break;
case OPT_MARKTRUSTED:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
return SlaveMarkTrusted(interp, slaveInterp);
case OPT_RECLIMIT:
|
| ︙ | ︙ | |||
2744 2745 2746 2747 2748 2749 2750 |
*/
static void
SlaveObjCmdDeleteProc(
ClientData clientData) /* The SlaveRecord for the command. */
{
Slave *slavePtr; /* Interim storage for Slave record. */
| | | 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 |
*/
static void
SlaveObjCmdDeleteProc(
ClientData clientData) /* The SlaveRecord for the command. */
{
Slave *slavePtr; /* Interim storage for Slave record. */
Tcl_Interp *slaveInterp = (Tcl_Interp *)clientData;
/* And for a slave interp. */
slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave;
/*
* Unlink the slave from its master interpreter.
*/
|
| ︙ | ︙ | |||
3084 3085 3086 3087 3088 3089 3090 |
hTblPtr = ((Interp *) slaveInterp)->hiddenCmdTablePtr;
if (hTblPtr != NULL) {
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
Tcl_ListObjAppendElement(NULL, listObjPtr,
| | | 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 |
hTblPtr = ((Interp *) slaveInterp)->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;
}
/*
|
| ︙ | ︙ | |||
3287 3288 3289 3290 3291 3292 3293 |
* place, but...)
*/
/*
* No env array in a safe slave.
*/
| | | | | | 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 |
* place, but...)
*/
/*
* No env array in a safe slave.
*/
Tcl_UnsetVar2(interp, "env", NULL, TCL_GLOBAL_ONLY);
/*
* Remove unsafe parts of tcl_platform
*/
Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY);
Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY);
Tcl_UnsetVar2(interp, "tcl_platform", "user", TCL_GLOBAL_ONLY);
/*
* Unset path informations variables (the only one remaining is [info
* nameofexecutable])
*/
Tcl_UnsetVar2(interp, "tclDefaultLibrary", NULL, TCL_GLOBAL_ONLY);
Tcl_UnsetVar2(interp, "tcl_library", NULL, TCL_GLOBAL_ONLY);
Tcl_UnsetVar2(interp, "tcl_pkgPath", NULL, TCL_GLOBAL_ONLY);
/*
* Remove the standard channels from the interpreter; safe interpreters do
* not ordinarily have access to stdin, stdout and stderr.
*
* NOTE: These channels are not added to the interpreter by the
* Tcl_CreateInterp call, but may be added later, by another I/O
|
| ︙ | ︙ | |||
3358 3359 3360 3361 3362 3363 3364 |
*----------------------------------------------------------------------
*/
int
Tcl_LimitExceeded(
Tcl_Interp *interp)
{
| | | 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 |
*----------------------------------------------------------------------
*/
int
Tcl_LimitExceeded(
Tcl_Interp *interp)
{
Interp *iPtr = (Interp *) interp;
return iPtr->limit.exceeded != 0;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3389 3390 3391 3392 3393 3394 3395 |
*----------------------------------------------------------------------
*/
int
Tcl_LimitReady(
Tcl_Interp *interp)
{
| | | | 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 |
*----------------------------------------------------------------------
*/
int
Tcl_LimitReady(
Tcl_Interp *interp)
{
Interp *iPtr = (Interp *) interp;
if (iPtr->limit.active != 0) {
int ticker = ++iPtr->limit.granularityTicker;
if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) &&
((iPtr->limit.cmdGranularity == 1) ||
(ticker % iPtr->limit.cmdGranularity == 0))) {
return 1;
}
if ((iPtr->limit.active & TCL_LIMIT_TIME) &&
|
| ︙ | ︙ | |||
3436 3437 3438 3439 3440 3441 3442 |
*/
int
Tcl_LimitCheck(
Tcl_Interp *interp)
{
Interp *iPtr = (Interp *) interp;
| | | 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 |
*/
int
Tcl_LimitCheck(
Tcl_Interp *interp)
{
Interp *iPtr = (Interp *) interp;
int ticker = iPtr->limit.granularityTicker;
if (Tcl_InterpDeleted(interp)) {
return TCL_OK;
}
if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) &&
((iPtr->limit.cmdGranularity == 1) ||
|
| ︙ | ︙ | |||
3556 3557 3558 3559 3560 3561 3562 |
* LIMIT_HANDLER_DELETED flag.
*/
if (handlerPtr->flags & LIMIT_HANDLER_DELETED) {
if (handlerPtr->deleteProc != NULL) {
handlerPtr->deleteProc(handlerPtr->clientData);
}
| | | 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 |
* LIMIT_HANDLER_DELETED flag.
*/
if (handlerPtr->flags & LIMIT_HANDLER_DELETED) {
if (handlerPtr->deleteProc != NULL) {
handlerPtr->deleteProc(handlerPtr->clientData);
}
ckfree(handlerPtr);
}
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3593 3594 3595 3596 3597 3598 3599 |
LimitHandler *handlerPtr;
/*
* Convert everything into a real deletion callback.
*/
if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_DYNAMIC) {
| | | | 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 |
LimitHandler *handlerPtr;
/*
* Convert everything into a real deletion callback.
*/
if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_DYNAMIC) {
deleteProc = (Tcl_LimitHandlerDeleteProc *) Tcl_Free;
}
/*
* Allocate a handler record.
*/
handlerPtr = (LimitHandler *)ckalloc(sizeof(LimitHandler));
handlerPtr->flags = 0;
handlerPtr->handlerProc = handlerProc;
handlerPtr->clientData = clientData;
handlerPtr->deleteProc = deleteProc;
handlerPtr->prevPtr = NULL;
/*
|
| ︙ | ︙ | |||
3719 3720 3721 3722 3723 3724 3725 |
* go away when the handler returns.
*/
if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
if (handlerPtr->deleteProc != NULL) {
handlerPtr->deleteProc(handlerPtr->clientData);
}
| | | 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 |
* go away when the handler returns.
*/
if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
if (handlerPtr->deleteProc != NULL) {
handlerPtr->deleteProc(handlerPtr->clientData);
}
ckfree(handlerPtr);
}
return;
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
3779 3780 3781 3782 3783 3784 3785 |
* go away when the handler returns.
*/
if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
if (handlerPtr->deleteProc != NULL) {
handlerPtr->deleteProc(handlerPtr->clientData);
}
| | | 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 |
* go away when the handler returns.
*/
if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
if (handlerPtr->deleteProc != NULL) {
handlerPtr->deleteProc(handlerPtr->clientData);
}
ckfree(handlerPtr);
}
}
/*
* Delete all time-limit handlers.
*/
|
| ︙ | ︙ | |||
3812 3813 3814 3815 3816 3817 3818 |
* go away when the handler returns.
*/
if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
if (handlerPtr->deleteProc != NULL) {
handlerPtr->deleteProc(handlerPtr->clientData);
}
| | | 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 |
* go away when the handler returns.
*/
if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) {
if (handlerPtr->deleteProc != NULL) {
handlerPtr->deleteProc(handlerPtr->clientData);
}
ckfree(handlerPtr);
}
}
/*
* Delete the timer callback that is used to trap limits that occur in
* [vwait]s...
*/
|
| ︙ | ︙ | |||
4057 4058 4059 4060 4061 4062 4063 |
*----------------------------------------------------------------------
*/
static void
TimeLimitCallback(
ClientData clientData)
{
| | | | 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 |
*----------------------------------------------------------------------
*/
static void
TimeLimitCallback(
ClientData clientData)
{
Tcl_Interp *interp = (Tcl_Interp *)clientData;
Interp *iPtr = (Interp *)clientData;
int code;
Tcl_Preserve(interp);
iPtr->limit.timeEvent = NULL;
/*
* Must reset the granularity ticker here to force an immediate full
|
| ︙ | ︙ | |||
4201 4202 4203 4204 4205 4206 4207 |
*----------------------------------------------------------------------
*/
static void
DeleteScriptLimitCallback(
ClientData clientData)
{
| | | | 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 |
*----------------------------------------------------------------------
*/
static void
DeleteScriptLimitCallback(
ClientData clientData)
{
ScriptLimitCallback *limitCBPtr = (ScriptLimitCallback *)clientData;
Tcl_DecrRefCount(limitCBPtr->scriptObj);
if (limitCBPtr->entryPtr != NULL) {
Tcl_DeleteHashEntry(limitCBPtr->entryPtr);
}
ckfree(limitCBPtr);
}
/*
*----------------------------------------------------------------------
*
* CallScriptLimitCallback --
*
|
| ︙ | ︙ | |||
4231 4232 4233 4234 4235 4236 4237 |
*
*----------------------------------------------------------------------
*/
static void
CallScriptLimitCallback(
ClientData clientData,
| | | | 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 |
*
*----------------------------------------------------------------------
*/
static void
CallScriptLimitCallback(
ClientData clientData,
TCL_UNUSED(Tcl_Interp *))
{
ScriptLimitCallback *limitCBPtr = (ScriptLimitCallback *)clientData;
int code;
if (Tcl_InterpDeleted(limitCBPtr->interp)) {
return;
}
Tcl_Preserve(limitCBPtr->interp);
code = Tcl_EvalObjEx(limitCBPtr->interp, limitCBPtr->scriptObj,
|
| ︙ | ︙ | |||
4301 4302 4303 4304 4305 4306 4307 |
}
return;
}
hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, &key,
&isNew);
if (!isNew) {
| | | | 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 |
}
return;
}
hashPtr = Tcl_CreateHashEntry(&iPtr->limit.callbacks, &key,
&isNew);
if (!isNew) {
limitCBPtr = (ScriptLimitCallback *)Tcl_GetHashValue(hashPtr);
limitCBPtr->entryPtr = NULL;
Tcl_LimitRemoveHandler(targetInterp, type, CallScriptLimitCallback,
limitCBPtr);
}
limitCBPtr = (ScriptLimitCallback *)ckalloc(sizeof(ScriptLimitCallback));
limitCBPtr->interp = interp;
limitCBPtr->scriptObj = scriptObj;
limitCBPtr->entryPtr = hashPtr;
limitCBPtr->type = type;
Tcl_IncrRefCount(scriptObj);
Tcl_LimitAddHandler(targetInterp, type, CallScriptLimitCallback,
|
| ︙ | ︙ | |||
4496 4497 4498 4499 4500 4501 4502 |
Tcl_Obj *dictPtr;
TclNewObj(dictPtr);
key.interp = slaveInterp;
key.type = TCL_LIMIT_COMMANDS;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
if (hPtr != NULL) {
| | | 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 |
Tcl_Obj *dictPtr;
TclNewObj(dictPtr);
key.interp = slaveInterp;
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 {
|
| ︙ | ︙ | |||
4538 4539 4540 4541 4542 4543 4544 |
}
switch ((enum Options) index) {
case OPT_CMD:
key.interp = slaveInterp;
key.type = TCL_LIMIT_COMMANDS;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
if (hPtr != NULL) {
| | | 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 |
}
switch ((enum Options) index) {
case OPT_CMD:
key.interp = slaveInterp;
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(
|
| ︙ | ︙ | |||
4560 4561 4562 4563 4564 4565 4566 |
break;
}
return TCL_OK;
} else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
return TCL_ERROR;
} else {
| < | | 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 |
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, limitLen = 0;
Tcl_Obj *scriptObj = NULL, *granObj = NULL, *limitObj = NULL;
int gran = 0, limit = 0;
for (i=consumedObjc ; i<objc ; i+=2) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
4685 4686 4687 4688 4689 4690 4691 |
Tcl_Obj *dictPtr;
TclNewObj(dictPtr);
key.interp = slaveInterp;
key.type = TCL_LIMIT_TIME;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
if (hPtr != NULL) {
| | | 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 |
Tcl_Obj *dictPtr;
TclNewObj(dictPtr);
key.interp = slaveInterp;
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 {
|
| ︙ | ︙ | |||
4733 4734 4735 4736 4737 4738 4739 |
}
switch ((enum Options) index) {
case OPT_CMD:
key.interp = slaveInterp;
key.type = TCL_LIMIT_TIME;
hPtr = Tcl_FindHashEntry(&iPtr->limit.callbacks, (char *) &key);
if (hPtr != NULL) {
| | | 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 |
}
switch ((enum Options) index) {
case OPT_CMD:
key.interp = slaveInterp;
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(
|
| ︙ | ︙ | |||
4766 4767 4768 4769 4770 4771 4772 |
break;
}
return TCL_OK;
} else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
return TCL_ERROR;
} else {
| < | | 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 |
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(slaveInterp, &limitMoment);
|
| ︙ | ︙ |
Changes to generic/tclLink.c.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 | * Copyright (c) 2019 Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" | | | | | | 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 |
* Copyright (c) 2019 Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclTomMath.h"
#include <math.h>
/*
* For each linked variable there is a data structure of the following type,
* which describes the link and is the clientData for the trace set on the Tcl
* variable.
*/
typedef struct Link {
Tcl_Interp *interp; /* Interpreter containing Tcl variable. */
Namespace *nsPtr; /* Namespace containing Tcl variable */
Tcl_Obj *varName; /* Name of variable (must be global). This is
* needed during trace callbacks, since the
* actual variable may be aliased at that time
* via upvar. */
void *addr; /* Location of C variable. */
int bytes; /* Size of C variable array. This is 0 when
* single variables, and >0 used for array
* variables. */
int numElems; /* Number of elements in C variable array.
* Zero for single variables. */
int type; /* Type of link (TCL_LINK_INT, etc.). */
union {
char c;
unsigned char uc;
int i;
unsigned int ui;
|
| ︙ | ︙ | |||
160 161 162 163 164 165 166 |
Tcl_Obj *objPtr;
Link *linkPtr;
Namespace *dummy;
const char *name;
int code;
linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
| | | | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 |
Tcl_Obj *objPtr;
Link *linkPtr;
Namespace *dummy;
const char *name;
int code;
linkPtr = (Link *) Tcl_VarTraceInfo2(interp, varName, NULL,
TCL_GLOBAL_ONLY, LinkTraceProc, NULL);
if (linkPtr != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"variable '%s' is already linked", varName));
return TCL_ERROR;
}
linkPtr = (Link *)ckalloc(sizeof(Link));
linkPtr->interp = interp;
linkPtr->nsPtr = NULL;
linkPtr->varName = Tcl_NewStringObj(varName, -1);
Tcl_IncrRefCount(linkPtr->varName);
linkPtr->addr = addr;
linkPtr->type = type & ~TCL_LINK_READ_ONLY;
#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \
|
| ︙ | ︙ | |||
241 242 243 244 245 246 247 |
const char *varName, /* Name of a global variable in interp. */
void *addr, /* Address of a C variable to be linked to
* varName. If NULL then the necessary space
* will be allocated and returned as the
* interpreter result. */
int type, /* Type of C variable: TCL_LINK_INT, etc. Also
* may have TCL_LINK_READ_ONLY OR'ed in. */
| | | > > > > > > > > | 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 |
const char *varName, /* Name of a global variable in interp. */
void *addr, /* Address of a C variable to be linked to
* varName. If NULL then the necessary space
* will be allocated and returned as the
* interpreter result. */
int type, /* Type of C variable: TCL_LINK_INT, etc. Also
* may have TCL_LINK_READ_ONLY OR'ed in. */
int size) /* Size of C variable array, >1 if array */
{
Tcl_Obj *objPtr;
Link *linkPtr;
Namespace *dummy;
const char *name;
int code;
if (size < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"wrong array size given", -1));
return TCL_ERROR;
}
linkPtr = (Link *)ckalloc(sizeof(Link));
linkPtr->type = type & ~TCL_LINK_READ_ONLY;
#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \
|| defined(_WIN32) || defined(__CYGWIN__))
if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) {
linkPtr->type = TCL_LINK_LONG;
} else if (linkPtr->type == 12 /* legacy TCL_LINK_ULONG */) {
linkPtr->type = TCL_LINK_ULONG;
}
#endif
linkPtr->numElems = size;
if (type & TCL_LINK_READ_ONLY) {
linkPtr->flags = LINK_READ_ONLY;
} else {
linkPtr->flags = 0;
}
|
| ︙ | ︙ | |||
315 316 317 318 319 320 321 |
/*
* If no address is given create one and use as address the
* not needed linkPtr->lastValue
*/
if (addr == NULL) {
| | | | | 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 |
/*
* If no address is given create one and use as address the
* not needed linkPtr->lastValue
*/
if (addr == NULL) {
linkPtr->lastValue.aryPtr = ckalloc(linkPtr->bytes);
linkPtr->flags |= LINK_ALLOC_LAST;
addr = (char *) &linkPtr->lastValue.cPtr;
}
break;
case TCL_LINK_CHARS:
case TCL_LINK_BINARY:
linkPtr->bytes = size * sizeof(char);
break;
default:
LinkFree(linkPtr);
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad linked array variable type", -1));
return TCL_ERROR;
}
/*
* Allocate C variable space in case no address is given
*/
if (addr == NULL) {
linkPtr->addr = ckalloc(linkPtr->bytes);
linkPtr->flags |= LINK_ALLOC_ADDR;
} else {
linkPtr->addr = addr;
}
/*
* If necessary create space for last used value.
*/
if (size > 1) {
linkPtr->lastValue.aryPtr = ckalloc(linkPtr->bytes);
linkPtr->flags |= LINK_ALLOC_LAST;
}
/*
* Initialize allocated space.
*/
|
| ︙ | ︙ | |||
523 524 525 526 527 528 529 |
int type, intValue;
if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) {
if (type == TCL_NUMBER_INT) {
*widePtr = *((const Tcl_WideInt *) clientData);
return (*widePtr < 0);
} else if (type == TCL_NUMBER_BIG) {
| | | | | | 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 |
int type, intValue;
if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) {
if (type == TCL_NUMBER_INT) {
*widePtr = *((const Tcl_WideInt *) clientData);
return (*widePtr < 0);
} else if (type == TCL_NUMBER_BIG) {
mp_int *numPtr = (mp_int *)clientData;
Tcl_WideUInt value = 0;
union {
Tcl_WideUInt value;
unsigned char bytes[sizeof(Tcl_WideUInt)];
} scratch;
size_t numBytes;
unsigned char *bytes = scratch.bytes;
if (numPtr->sign || (MP_OKAY != mp_to_ubin(numPtr,
bytes, sizeof(Tcl_WideUInt), &numBytes))) {
/*
* If the sign bit is set (a negative value) or if the value
* can't possibly fit in the bits of an unsigned wide, there's
* no point in doing further conversion.
*/
return 1;
}
|
| ︙ | ︙ | |||
616 617 618 619 620 621 622 | /* * Mark an object as holding a weird double. */ static int SetInvalidRealFromAny( | | | | | | | | | | 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 |
/*
* Mark an object as holding a weird double.
*/
static int
SetInvalidRealFromAny(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr)
{
const char *str;
const char *endPtr;
str = TclGetString(objPtr);
if ((objPtr->length == 1) && (str[0] == '.')) {
objPtr->typePtr = &invalidRealType;
objPtr->internalRep.doubleValue = 0.0;
return TCL_OK;
}
if (TclParseNumber(NULL, objPtr, NULL, str, objPtr->length, &endPtr,
TCL_PARSE_DECIMAL_ONLY) == TCL_OK) {
/*
* If number is followed by [eE][+-]?, then it is an invalid
* double, but it could be the start of a valid double.
*/
if (*endPtr == 'e' || *endPtr == 'E') {
++endPtr;
if (*endPtr == '+' || *endPtr == '-') {
++endPtr;
}
|
| ︙ | ︙ | |||
655 656 657 658 659 660 661 |
}
}
}
return TCL_ERROR;
}
/*
| | | | | < | | | | | | | | | 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 |
}
}
}
return TCL_ERROR;
}
/*
* This function checks for integer representations, which are valid
* when linking with C variables, but which are invalid in other
* contexts in Tcl. Handled are "+", "-", "", "0x", "0b", "0d" and "0o"
* (upperand lowercase). See bug [39f6304c2e].
*/
static int
GetInvalidIntFromObj(
Tcl_Obj *objPtr,
int *intPtr)
{
const char *str = TclGetString(objPtr);
if ((objPtr->length == 0) || ((objPtr->length == 2) && (str[0] == '0')
&& strchr("xXbBoOdD", str[1]))) {
*intPtr = 0;
return TCL_OK;
} else if ((objPtr->length == 1) && strchr("+-", str[0])) {
*intPtr = (str[0] == '+');
return TCL_OK;
}
return TCL_ERROR;
}
/*
* This function checks for double representations, which are valid
* when linking with C variables, but which are invalid in other
* contexts in Tcl. Handled are "+", "-", "", ".", "0x", "0b" and "0o"
* (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e].
*/
static int
GetInvalidDoubleFromObj(
Tcl_Obj *objPtr,
double *doublePtr)
{
|
| ︙ | ︙ | |||
734 735 736 737 738 739 740 |
*----------------------------------------------------------------------
*/
static char *
LinkTraceProc(
ClientData clientData, /* Contains information about the link. */
Tcl_Interp *interp, /* Interpreter containing Tcl variable. */
| | | > > > | | | 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 |
*----------------------------------------------------------------------
*/
static char *
LinkTraceProc(
ClientData clientData, /* Contains information about the link. */
Tcl_Interp *interp, /* Interpreter containing Tcl variable. */
TCL_UNUSED(const char *) /*name1*/,
TCL_UNUSED(const char *) /*name2*/,
/* Links can only be made to global variables,
* so we can find them with need to resolve
* caller-supplied name in caller context. */
int flags) /* Miscellaneous additional information. */
{
Link *linkPtr = (Link *)clientData;
int changed;
int valueLength;
const char *value;
char **pp;
Tcl_Obj *valueObj;
int valueInt;
Tcl_WideInt valueWide;
Tcl_WideUInt valueUWide;
double valueDouble;
|
| ︙ | ︙ | |||
764 765 766 767 768 769 770 |
if (flags & TCL_TRACE_UNSETS) {
if (Tcl_InterpDeleted(interp) || TclNamespaceDeleted(linkPtr->nsPtr)) {
Tcl_DecrRefCount(linkPtr->varName);
LinkFree(linkPtr);
} else if (flags & TCL_TRACE_DESTROYED) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
| | | 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 |
if (flags & TCL_TRACE_UNSETS) {
if (Tcl_InterpDeleted(interp) || TclNamespaceDeleted(linkPtr->nsPtr)) {
Tcl_DecrRefCount(linkPtr->varName);
LinkFree(linkPtr);
} else if (flags & TCL_TRACE_DESTROYED) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
Tcl_TraceVar2(interp, Tcl_GetString(linkPtr->varName), NULL,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr);
}
return NULL;
}
/*
|
| ︙ | ︙ | |||
882 883 884 885 886 887 888 |
/*
* Special cases.
*/
switch (linkPtr->type) {
case TCL_LINK_STRING:
| | > | | | | 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 |
/*
* Special cases.
*/
switch (linkPtr->type) {
case TCL_LINK_STRING:
value = TclGetString(valueObj);
valueLength = valueObj->length + 1;
pp = (char **) linkPtr->addr;
*pp = (char *)ckrealloc(*pp, valueLength);
memcpy(*pp, value, valueLength);
return NULL;
case TCL_LINK_CHARS:
value = (char *) Tcl_GetStringFromObj(valueObj, &valueLength);
valueLength++; /* include end of string char */
if (valueLength > linkPtr->bytes) {
return (char *) "wrong size of char* value";
}
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength);
memcpy(linkPtr->addr, value, (size_t) valueLength);
} else {
linkPtr->lastValue.c = '\0';
LinkedVar(char) = linkPtr->lastValue.c;
}
return NULL;
case TCL_LINK_BINARY:
value = (char *) Tcl_GetByteArrayFromObj(valueObj, &valueLength);
if (valueLength != linkPtr->bytes) {
return (char *) "wrong size of binary value";
}
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength);
memcpy(linkPtr->addr, value, (size_t) valueLength);
} else {
|
| ︙ | ︙ | |||
933 934 935 936 937 938 939 |
/*
* If we're working with an array of numbers, extract the Tcl list.
*/
if (linkPtr->flags & LINK_ALLOC_LAST) {
if (Tcl_ListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR
| | | 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 |
/*
* If we're working with an array of numbers, extract the Tcl list.
*/
if (linkPtr->flags & LINK_ALLOC_LAST) {
if (Tcl_ListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR
|| objc != linkPtr->numElems) {
return (char *) "wrong dimension";
}
}
switch (linkPtr->type) {
case TCL_LINK_INT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
|
| ︙ | ︙ | |||
1173 1174 1175 1176 1177 1178 1179 |
}
break;
case TCL_LINK_ULONG:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetUWide(objv[i], &valueUWide)
| | | | 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 |
}
break;
case TCL_LINK_ULONG:
if (linkPtr->flags & LINK_ALLOC_LAST) {
for (i=0; i < objc; i++) {
if (GetUWide(objv[i], &valueUWide)
|| (valueUWide > ULONG_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *)
"variable array must have unsigned long value";
}
linkPtr->lastValue.ulPtr[i] = (unsigned long) valueUWide;
}
} else {
if (GetUWide(valueObj, &valueUWide)
|| (valueUWide > ULONG_MAX)) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned long value";
}
LinkedVar(unsigned long) = linkPtr->lastValue.ul =
(unsigned long) valueUWide;
}
|
| ︙ | ︙ | |||
1273 1274 1275 1276 1277 1278 1279 |
static Tcl_Obj *
ObjValue(
Link *linkPtr) /* Structure describing linked variable. */
{
char *p;
Tcl_Obj *resultObj, **objv;
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 |
static Tcl_Obj *
ObjValue(
Link *linkPtr) /* Structure describing linked variable. */
{
char *p;
Tcl_Obj *resultObj, **objv;
int i;
switch (linkPtr->type) {
case TCL_LINK_INT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewIntObj(linkPtr->lastValue.iPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.i = LinkedVar(int);
return Tcl_NewIntObj(linkPtr->lastValue.i);
case TCL_LINK_WIDE_INT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.wPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.w = LinkedVar(Tcl_WideInt);
return Tcl_NewWideIntObj(linkPtr->lastValue.w);
case TCL_LINK_DOUBLE:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.dPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.d = LinkedVar(double);
return Tcl_NewDoubleObj(linkPtr->lastValue.d);
case TCL_LINK_BOOLEAN:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewBooleanObj(linkPtr->lastValue.iPtr[i] != 0);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.i = LinkedVar(int);
return Tcl_NewBooleanObj(linkPtr->lastValue.i);
case TCL_LINK_CHAR:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewIntObj(linkPtr->lastValue.cPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.c = LinkedVar(char);
return Tcl_NewIntObj(linkPtr->lastValue.c);
case TCL_LINK_UCHAR:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewIntObj(linkPtr->lastValue.ucPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.uc = LinkedVar(unsigned char);
return Tcl_NewIntObj(linkPtr->lastValue.uc);
case TCL_LINK_SHORT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewIntObj(linkPtr->lastValue.sPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.s = LinkedVar(short);
return Tcl_NewIntObj(linkPtr->lastValue.s);
case TCL_LINK_USHORT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewIntObj(linkPtr->lastValue.usPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.us = LinkedVar(unsigned short);
return Tcl_NewIntObj(linkPtr->lastValue.us);
case TCL_LINK_UINT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.uiPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
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++) {
objv[i] = Tcl_NewWideIntObj(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++) {
objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.ulPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.ul = LinkedVar(unsigned long);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul);
#endif
case TCL_LINK_FLOAT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.fPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.f = LinkedVar(float);
return Tcl_NewDoubleObj(linkPtr->lastValue.f);
case TCL_LINK_WIDE_UINT:
if (linkPtr->flags & LINK_ALLOC_LAST) {
memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes);
objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *));
for (i=0; i < linkPtr->numElems; i++) {
objv[i] = Tcl_NewWideIntObj((Tcl_WideInt)
linkPtr->lastValue.uwPtr[i]);
}
resultObj = Tcl_NewListObj(linkPtr->numElems, objv);
ckfree(objv);
return resultObj;
}
linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw);
case TCL_LINK_STRING:
p = LinkedVar(char *);
|
| ︙ | ︙ | |||
1511 1512 1513 1514 1515 1516 1517 |
LinkFree(
Link *linkPtr) /* Structure describing linked variable. */
{
if (linkPtr->nsPtr) {
TclNsDecrRefCount(linkPtr->nsPtr);
}
if (linkPtr->flags & LINK_ALLOC_ADDR) {
| | | | | 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 |
LinkFree(
Link *linkPtr) /* Structure describing linked variable. */
{
if (linkPtr->nsPtr) {
TclNsDecrRefCount(linkPtr->nsPtr);
}
if (linkPtr->flags & LINK_ALLOC_ADDR) {
ckfree(linkPtr->addr);
}
if (linkPtr->flags & LINK_ALLOC_LAST) {
ckfree(linkPtr->lastValue.aryPtr);
}
ckfree((char *) linkPtr);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclListObj.c.
| ︙ | ︙ | |||
58 59 60 61 62 63 64 |
Tcl_StoreIntRep((objPtr), &tclListType, &ir); \
} while (0)
#define ListGetIntRep(objPtr, listRepPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &tclListType); \
| | | | | | | < | | | | < | | | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 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 |
Tcl_StoreIntRep((objPtr), &tclListType, &ir); \
} while (0)
#define ListGetIntRep(objPtr, listRepPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &tclListType); \
(listRepPtr) = irPtr ? (List *)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
#define ListResetIntRep(objPtr, listRepPtr) \
TclFetchIntRep((objPtr), &tclListType)->twoPtrValue.ptr1 = (listRepPtr)
#ifndef TCL_MIN_ELEMENT_GROWTH
#define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *)
#endif
/*
*----------------------------------------------------------------------
*
* NewListIntRep --
*
* Creates a list internal rep with space for objc elements. objc
* must be > 0. If objv!=NULL, initializes with the first objc values
* in that array. If objv==NULL, initalize list internal rep to have
* 0 elements, with space to add objc more. Flag value "p" indicates
* how to behave on failure.
*
* Results:
* A new List struct with refCount 0 is returned. If some failure
* prevents this then if p=0, NULL is returned and otherwise the
* routine panics.
*
* Side effects:
* The ref counts of the elements in objv are incremented since the
* resulting list now refers to them.
*
*----------------------------------------------------------------------
*/
static List *
NewListIntRep(
int objc,
|
| ︙ | ︙ | |||
120 121 122 123 124 125 126 |
if (p) {
Tcl_Panic("max length of a Tcl list (%d elements) exceeded",
LIST_MAX);
}
return NULL;
}
| | | | 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 |
if (p) {
Tcl_Panic("max length of a Tcl list (%d elements) exceeded",
LIST_MAX);
}
return NULL;
}
listRepPtr = (List *)attemptckalloc(LIST_SIZE(objc));
if (listRepPtr == NULL) {
if (p) {
Tcl_Panic("list creation failed: unable to alloc %u bytes",
LIST_SIZE(objc));
}
return NULL;
}
listRepPtr->canonicalFlag = 0;
listRepPtr->refCount = 0;
|
| ︙ | ︙ | |||
152 153 154 155 156 157 158 |
}
return listRepPtr;
}
/*
*----------------------------------------------------------------------
*
| | > > > > > > > | > > > > > | > | < > > < > > > | | | | | < | | | 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 |
}
return listRepPtr;
}
/*
*----------------------------------------------------------------------
*
* AttemptNewList --
*
* Creates a list internal rep with space for objc elements. objc
* must be > 0. If objv!=NULL, initializes with the first objc values
* in that array. If objv==NULL, initalize list internal rep to have
* 0 elements, with space to add objc more.
*
* Results:
* A new List struct with refCount 0 is returned. If some failure
* prevents this then NULL is returned, and an error message is left
* in the interp result, unless interp is NULL.
*
* Side effects:
* The ref counts of the elements in objv are incremented since the
* resulting list now refers to them.
*
*----------------------------------------------------------------------
*/
static List *
AttemptNewList(
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
List *listRepPtr = NewListIntRep(objc, objv, 0);
if (interp != NULL && listRepPtr == NULL) {
if (objc > LIST_MAX) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max length of a Tcl list (%d elements) exceeded",
LIST_MAX));
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"list creation failed: unable to alloc %u bytes",
LIST_SIZE(objc)));
}
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return listRepPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_NewListObj --
*
* This function is normally called when not debugging: i.e., when
* TCL_MEM_DEBUG is not defined. It creates a new list object from an
* (objc,objv) array: that is, each of the objc elements of the array
* referenced by objv is inserted as an element into a new Tcl object.
*
* When TCL_MEM_DEBUG is defined, this function just returns the result
* of calling the debugging version Tcl_DbNewListObj.
*
* Results:
* A new list object is returned that is initialized from the object
* pointers in objv. If objc is less than or equal to zero, an empty
* object is returned. The new object's string representation is left
* NULL. The resulting new list object has ref count 0.
*
* Side effects:
* The ref counts of the elements in objv are incremented since the
* resulting list now refers to them.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewListObj
|
| ︙ | ︙ | |||
251 252 253 254 255 256 257 |
return listPtr;
}
#endif /* if TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
| | > > > | | | | | > > > > > > > > > > > | 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 |
return listPtr;
}
#endif /* if TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_DbNewListObj --
*
* This function is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. It creates new list objects. It is the same
* as the Tcl_NewListObj function above except that it calls
* Tcl_DbCkalloc directly with the file name and line number from its
* caller. This simplifies debugging since then the [memory active]
* command will report the correct file name and line number when
* reporting objects that haven't been freed.
*
* When TCL_MEM_DEBUG is not defined, this function just returns the
* result of calling Tcl_NewListObj.
*
* Results:
* A new list object is returned that is initialized from the object
* pointers in objv. If objc is less than or equal to zero, an empty
* object is returned. The new object's string representation is left
* NULL. The new list object has ref count 0.
*
* Side effects:
* The ref counts of the elements in objv are incremented since the
* resulting list now refers to them.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
|
| ︙ | ︙ | |||
305 306 307 308 309 310 311 |
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewListObj(
int objc, /* Count of objects referenced by objv. */
Tcl_Obj *const objv[], /* An array of pointers to Tcl objects. */
| | < | < | > > > | > > > > > > > > | 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 |
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewListObj(
int objc, /* Count of objects referenced by objv. */
Tcl_Obj *const objv[], /* An array of pointers to Tcl objects. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewListObj(objc, objv);
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_SetListObj --
*
* Modify an object to be a list containing each of the objc elements of
* the object array referenced by objv.
*
* Results:
* None.
*
* Side effects:
* The object is made a list object and is initialized from the object
* pointers in objv. If objc is less than or equal to zero, an empty
* object is returned. The new object's string representation is left
* NULL. The ref counts of the elements in objv are incremented since the
* list now refers to them. The object's old string and internal
* representations are freed and its type is set NULL.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetListObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
|
| ︙ | ︙ | |||
363 364 365 366 367 368 369 | } /* *---------------------------------------------------------------------- * * TclListObjCopy -- * | | | | | | | | | < | | < | 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 |
}
/*
*----------------------------------------------------------------------
*
* TclListObjCopy --
*
* Makes a "pure list" copy of a list value. This provides for the C
* level a counterpart of the [lrange $list 0 end] command, while using
* internals details to be as efficient as possible.
*
* Results:
* Normally returns a pointer to a new Tcl_Obj, that contains the same
* list value as *listPtr does. The returned Tcl_Obj has a refCount of
* zero. If *listPtr does not hold a list, NULL is returned, and if
* interp is non-NULL, an error message is recorded there.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclListObjCopy(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
|
| ︙ | ︙ | |||
489 490 491 492 493 494 495 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjGetElements -- * | | | < < | > | | > > > | | | | | | < < < < < | < > | | | | < | | 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 |
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjGetElements --
*
* This function returns an (objc,objv) array of the elements in a list
* object.
*
* Results:
* The return value is normally TCL_OK; in this case *objcPtr is set to
* the count of list elements and *objvPtr is set to a pointer to an
* array of (*objcPtr) pointers to each list element. If listPtr does not
* refer to a list object and the object can not be converted to one,
* TCL_ERROR is returned and an error message will be left in the
* interpreter's result if interp is not NULL.
*
* The objects referenced by the returned array should be treated as
* readonly and their ref counts are _not_ incremented; the caller must
* do that if it holds on to a reference. Furthermore, the pointer and
* length returned by this function may change as soon as any function is
* called on the list object; be careful about retaining the pointer in a
* local data structure.
*
* Side effects:
* The possible conversion of the object referenced by listPtr
* to a list object.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjGetElements(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *listPtr, /* List object for which an element array is
* to be returned. */
int *objcPtr, /* Where to store the count of objects
* referenced by objv. */
Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of
* pointers to the list's objects. */
{
List *listRepPtr;
ListGetIntRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
int result, length;
(void) Tcl_GetStringFromObj(listPtr, &length);
if (length == 0) {
*objcPtr = 0;
*objvPtr = NULL;
return TCL_OK;
}
result = SetListFromAny(interp, listPtr);
if (result != TCL_OK) {
|
| ︙ | ︙ | |||
557 558 559 560 561 562 563 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjAppendList -- * | | > | < | < < < | < < | | < | | | | | < | | 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 |
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjAppendList --
*
* This function appends the elements in the list value referenced by
* elemListPtr to the list value referenced by listPtr.
*
* Results:
* The return value is normally TCL_OK. If listPtr or elemListPtr do not
* refer to list values, TCL_ERROR is returned and an error message is
* left in the interpreter's result if interp is not NULL.
*
* Side effects:
* The reference counts of the elements in elemListPtr are incremented
* since the list now refers to them. listPtr and elemListPtr are
* converted, if necessary, to list objects. Also, appending the new
* elements may cause listObj's array of element pointers to grow.
* listPtr's old string representation, if any, is invalidated.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjAppendList(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *listPtr, /* List object to append elements to. */
Tcl_Obj *elemListPtr) /* List obj with elements to append. */
{
int objc;
Tcl_Obj **objv;
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList");
|
| ︙ | ︙ | |||
616 617 618 619 620 621 622 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjAppendElement -- * | | > > > | < | < | < < < | | | | < < | > | | | | | < | | 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 |
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjAppendElement --
*
* This function is a special purpose version of Tcl_ListObjAppendList:
* it appends a single object referenced by objPtr to the list object
* referenced by listPtr. If listPtr is not already a list object, an
* attempt will be made to convert it to one.
*
* Results:
* The return value is normally TCL_OK; in this case objPtr is added to
* the end of listPtr's list. If listPtr does not refer to a list object
* and the object can not be converted to one, TCL_ERROR is returned and
* an error message will be left in the interpreter's result if interp is
* not NULL.
*
* Side effects:
* The ref count of objPtr is incremented since the list now refers to
* it. listPtr will be converted, if necessary, to a list object. Also,
* appending the new element may cause listObj's array of element
* pointers to grow. listPtr's old string representation, if any, is
* invalidated.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjAppendElement(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *listPtr, /* List object to append objPtr to. */
Tcl_Obj *objPtr) /* Object to append to listPtr's list. */
{
List *listRepPtr, *newPtr = NULL;
int numElems, numRequired, needGrow, isShared, attempt;
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement");
}
ListGetIntRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
int result, length;
(void) Tcl_GetStringFromObj(listPtr, &length);
if (length == 0) {
Tcl_SetListObj(listPtr, 1, &objPtr);
return TCL_OK;
}
result = SetListFromAny(interp, listPtr);
if (result != TCL_OK) {
return result;
|
| ︙ | ︙ | |||
693 694 695 696 697 698 699 |
if (needGrow && !isShared) {
/*
* Need to grow + unshared intrep => try to realloc
*/
attempt = 2 * numRequired;
if (attempt <= LIST_MAX) {
| | | | | 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 |
if (needGrow && !isShared) {
/*
* Need to grow + unshared intrep => try to realloc
*/
attempt = 2 * numRequired;
if (attempt <= LIST_MAX) {
newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr == NULL) {
attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
if (attempt > LIST_MAX) {
attempt = LIST_MAX;
}
newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr == NULL) {
attempt = numRequired;
newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr) {
listRepPtr = newPtr;
listRepPtr->maxElemCount = attempt;
needGrow = 0;
}
}
|
| ︙ | ︙ | |||
762 763 764 765 766 767 768 |
listRepPtr->refCount--;
} else {
/*
* Old intrep to be freed, re-use refCounts.
*/
memcpy(dst, src, numElems * sizeof(Tcl_Obj *));
| | | 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 |
listRepPtr->refCount--;
} else {
/*
* Old intrep to be freed, re-use refCounts.
*/
memcpy(dst, src, numElems * sizeof(Tcl_Obj *));
ckfree(listRepPtr);
}
listRepPtr = newPtr;
}
ListResetIntRep(listPtr, listRepPtr);
listRepPtr->refCount++;
TclFreeIntRep(listPtr);
ListSetIntRep(listPtr, listRepPtr);
|
| ︙ | ︙ | |||
795 796 797 798 799 800 801 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjIndex -- * | | | | | > | < | | | | | < | < < | | < | | | | | < | | 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 |
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjIndex --
*
* This function returns a pointer to the index'th object from the list
* referenced by listPtr. The first element has index 0. If index is
* negative or greater than or equal to the number of elements in the
* list, a NULL is returned. If listPtr is not a list object, an attempt
* will be made to convert it to a list.
*
* Results:
* The return value is normally TCL_OK; in this case objPtrPtr is set to
* the Tcl_Obj pointer for the index'th list element or NULL if index is
* out of range. This object should be treated as readonly and its ref
* count is _not_ incremented; the caller must do that if it holds on to
* the reference. If listPtr does not refer to a list and can't be
* converted to one, TCL_ERROR is returned and an error message is left
* in the interpreter's result if interp is not NULL.
*
* Side effects:
* listPtr will be converted, if necessary, to a list object.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjIndex(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *listPtr, /* List object to index into. */
int index, /* Index of element to return. */
Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */
{
List *listRepPtr;
ListGetIntRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
int result, length;
(void) Tcl_GetStringFromObj(listPtr, &length);
if (length == 0) {
*objPtrPtr = NULL;
return TCL_OK;
}
result = SetListFromAny(interp, listPtr);
if (result != TCL_OK) {
return result;
|
| ︙ | ︙ | |||
860 861 862 863 864 865 866 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjLength -- * | | > > | < | < | > > | < < | | < | | | | < | | > > > | | | < > | | < < < | | | > > > | < | | | < < | < | < > | | | | | | 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 |
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjLength --
*
* This function returns the number of elements in a list object. If the
* object is not already a list object, an attempt will be made to
* convert it to one.
*
* Results:
* The return value is normally TCL_OK; in this case *intPtr will be set
* to the integer count of list elements. If listPtr does not refer to a
* list object and the object can not be converted to one, TCL_ERROR is
* returned and an error message will be left in the interpreter's result
* if interp is not NULL.
*
* Side effects:
* The possible conversion of the argument object to a list object.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjLength(
Tcl_Interp *interp, /* Used to report errors if not NULL. */
Tcl_Obj *listPtr, /* List object whose #elements to return. */
int *intPtr) /* The resulting int is stored here. */
{
List *listRepPtr;
ListGetIntRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
int result, length;
(void) Tcl_GetStringFromObj(listPtr, &length);
if (length == 0) {
*intPtr = 0;
return TCL_OK;
}
result = SetListFromAny(interp, listPtr);
if (result != TCL_OK) {
return result;
}
ListGetIntRep(listPtr, listRepPtr);
}
*intPtr = listRepPtr->elemCount;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ListObjReplace --
*
* This function replaces zero or more elements of the list referenced by
* listPtr with the objects from an (objc,objv) array. The objc elements
* of the array referenced by objv replace the count elements in listPtr
* starting at first.
*
* If the argument first is zero or negative, it refers to the first
* element. If first is greater than or equal to the number of elements
* in the list, then no elements are deleted; the new elements are
* appended to the list. Count gives the number of elements to replace.
* If count is zero or negative then no elements are deleted; the new
* elements are simply inserted before first.
*
* The argument objv refers to an array of objc pointers to the new
* elements to be added to listPtr in place of those that were deleted.
* If objv is NULL, no new elements are added. If listPtr is not a list
* object, an attempt will be made to convert it to one.
*
* Results:
* The return value is normally TCL_OK. If listPtr does not refer to a
* list object and can not be converted to one, TCL_ERROR is returned and
* an error message will be left in the interpreter's result if interp is
* not NULL.
*
* Side effects:
* The ref counts of the objc elements in objv are incremented since the
* resulting list now refers to them. Similarly, the ref counts for
* replaced objects are decremented. listPtr is converted, if necessary,
* to a list object. listPtr's old string representation, if any, is
* freed.
*
*----------------------------------------------------------------------
*/
int
Tcl_ListObjReplace(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *listPtr, /* List object whose elements to replace. */
int first, /* Index of first element to replace. */
int count, /* Number of elements to replace. */
int objc, /* Number of objects to insert. */
Tcl_Obj *const objv[]) /* An array of objc pointers to Tcl objects to
* insert. */
{
List *listRepPtr;
Tcl_Obj **elemPtrs;
int needGrow, numElems, numRequired, numAfterLast, start, i, j, isShared;
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
}
ListGetIntRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
int length;
(void) Tcl_GetStringFromObj(listPtr, &length);
if (length == 0) {
if (objc == 0) {
return TCL_OK;
}
Tcl_SetListObj(listPtr, objc, NULL);
} else {
int result = SetListFromAny(interp, listPtr);
|
| ︙ | ︙ | |||
1030 1031 1032 1033 1034 1035 1036 |
}
if (needGrow && !isShared) {
/* Try to use realloc */
List *newPtr = NULL;
int attempt = 2 * numRequired;
if (attempt <= LIST_MAX) {
| | | | | 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 |
}
if (needGrow && !isShared) {
/* Try to use realloc */
List *newPtr = NULL;
int attempt = 2 * numRequired;
if (attempt <= LIST_MAX) {
newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr == NULL) {
attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
if (attempt > LIST_MAX) {
attempt = LIST_MAX;
}
newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr == NULL) {
attempt = numRequired;
newPtr = (List *)attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
}
if (newPtr) {
listRepPtr = newPtr;
ListResetIntRep(listPtr, listRepPtr);
elemPtrs = &listRepPtr->elements;
listRepPtr->maxElemCount = attempt;
needGrow = numRequired > listRepPtr->maxElemCount;
|
| ︙ | ︙ | |||
1076 1077 1078 1079 1080 1081 1082 |
start = first + count;
numAfterLast = numElems - start;
shift = objc - count; /* numNewElems - numDeleted */
if ((numAfterLast > 0) && (shift != 0)) {
Tcl_Obj **src = elemPtrs + start;
| | | 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 |
start = first + count;
numAfterLast = numElems - start;
shift = objc - count; /* numNewElems - numDeleted */
if ((numAfterLast > 0) && (shift != 0)) {
Tcl_Obj **src = elemPtrs + start;
memmove(src+shift, src, (size_t) numAfterLast * sizeof(Tcl_Obj*));
}
} else {
/*
* Cannot use the current List struct; it is shared, too small, or
* both. Allocate a new struct and insert elements into it.
*/
|
| ︙ | ︙ | |||
1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 |
listRepPtr = AttemptNewList(NULL, numRequired + growth, NULL);
if (listRepPtr == NULL) {
listRepPtr = AttemptNewList(interp, numRequired, NULL);
if (listRepPtr == NULL) {
for (i = 0; i < objc; i++) {
/* See bug 3598580 */
Tcl_DecrRefCount(objv[i]);
}
return TCL_ERROR;
}
}
}
ListResetIntRep(listPtr, listRepPtr);
| > > > > | 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 |
listRepPtr = AttemptNewList(NULL, numRequired + growth, NULL);
if (listRepPtr == NULL) {
listRepPtr = AttemptNewList(interp, numRequired, NULL);
if (listRepPtr == NULL) {
for (i = 0; i < objc; i++) {
/* See bug 3598580 */
#if TCL_MAJOR_VERSION > 8
Tcl_DecrRefCount(objv[i]);
#else
objv[i]->refCount--;
#endif
}
return TCL_ERROR;
}
}
}
ListResetIntRep(listPtr, listRepPtr);
|
| ︙ | ︙ | |||
1168 1169 1170 1171 1172 1173 1174 |
start = first + count;
numAfterLast = numElems - start;
if (numAfterLast > 0) {
memcpy(elemPtrs + first + objc, oldPtrs + start,
(size_t) numAfterLast * sizeof(Tcl_Obj *));
}
| | | 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 |
start = first + count;
numAfterLast = numElems - start;
if (numAfterLast > 0) {
memcpy(elemPtrs + first + objc, oldPtrs + start,
(size_t) numAfterLast * sizeof(Tcl_Obj *));
}
ckfree(oldListRepPtr);
}
}
/*
* Insert the new elements into elemPtrs before "first".
*/
|
| ︙ | ︙ | |||
1205 1206 1207 1208 1209 1210 1211 | } /* *---------------------------------------------------------------------- * * TclLindexList -- * | | | | | | | | < < | > > > > > | | | 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 |
}
/*
*----------------------------------------------------------------------
*
* TclLindexList --
*
* This procedure handles the 'lindex' command when objc==3.
*
* Results:
* Returns a pointer to the object extracted, or NULL if an error
* occurred. The returned object already includes one reference count for
* the pointer returned.
*
* Side effects:
* None.
*
* Notes:
* This procedure is implemented entirely as a wrapper around
* TclLindexFlat. All it does is reconfigure the argument format into the
* form required by TclLindexFlat, while taking care to manage shimmering
* in such a way that we tend to keep the most useful intreps and/or
* avoid the most expensive conversions.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclLindexList(
Tcl_Interp *interp, /* Tcl interpreter. */
Tcl_Obj *listPtr, /* List being unpacked. */
Tcl_Obj *argPtr) /* Index or index list. */
{
int index; /* Index into the list. */
Tcl_Obj *indexListCopy;
List *listRepPtr;
/*
* Determine whether argPtr designates a list or a single index. We have
* to be careful about the order of the checks to avoid repeated
* shimmering; see TIP#22 and TIP#33 for the details.
*/
ListGetIntRep(argPtr, listRepPtr);
if ((listRepPtr == NULL)
&& TclGetIntForIndexM(NULL , argPtr, INT_MAX - 1, &index) == TCL_OK) {
/*
* argPtr designates a single index.
*/
return TclLindexFlat(interp, listPtr, 1, &argPtr);
}
|
| ︙ | ︙ | |||
1284 1285 1286 1287 1288 1289 1290 |
Tcl_DecrRefCount(indexListCopy);
return listPtr;
}
/*
*----------------------------------------------------------------------
*
| | | | | > > > < < > | > > > > | | < < | | 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 |
Tcl_DecrRefCount(indexListCopy);
return listPtr;
}
/*
*----------------------------------------------------------------------
*
* TclLindexFlat --
*
* This procedure is the core of the 'lindex' command, with all index
* arguments presented as a flat list.
*
* Results:
* Returns a pointer to the object extracted, or NULL if an error
* occurred. The returned object already includes one reference count for
* the pointer returned.
*
* Side effects:
* None.
*
* Notes:
* The reference count of the returned object includes one reference
* corresponding to the pointer returned. Thus, the calling code will
* usually do something like:
* Tcl_SetObjResult(interp, result);
* Tcl_DecrRefCount(result);
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclLindexFlat(
Tcl_Interp *interp, /* Tcl interpreter. */
Tcl_Obj *listPtr, /* Tcl object representing the list. */
int indexCount, /* Count of indices. */
Tcl_Obj *const indexArray[])/* Array of pointers to Tcl objects that
* represent the indices in the list. */
{
int i;
Tcl_IncrRefCount(listPtr);
for (i=0 ; i<indexCount && listPtr ; i++) {
int index, listLen = 0;
Tcl_Obj **elemPtrs = NULL, *sublistCopy;
/*
* Here we make a private copy of the current sublist, so we avoid any
* shimmering issues that might invalidate the elemPtr array below
* while we are still using it. See test lindex-8.4.
*/
|
| ︙ | ︙ | |||
1340 1341 1342 1343 1344 1345 1346 |
break;
}
TclListObjGetElements(NULL, sublistCopy, &listLen, &elemPtrs);
if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
&index) == TCL_OK) {
| | | | 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 |
break;
}
TclListObjGetElements(NULL, sublistCopy, &listLen, &elemPtrs);
if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1,
&index) == TCL_OK) {
if (index<0 || index>=listLen) {
/*
* Index is out of range. Break out of loop with empty result.
* First check remaining indices for validity
*/
while (++i < indexCount) {
if (TclGetIntForIndexM(interp, indexArray[i], INT_MAX - 1, &index)
!= TCL_OK) {
Tcl_DecrRefCount(sublistCopy);
return NULL;
}
}
listPtr = Tcl_NewObj();
} else {
|
| ︙ | ︙ | |||
1374 1375 1376 1377 1378 1379 1380 | } /* *---------------------------------------------------------------------- * * TclLsetList -- * | | | > > | | > < > | > > > > | | | 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 |
}
/*
*----------------------------------------------------------------------
*
* TclLsetList --
*
* Core of the 'lset' command when objc == 4. Objv[2] may be either a
* scalar index or a list of indices.
* It also handles 'lpop' when given a NULL value.
*
* Results:
* Returns the new value of the list variable, or NULL if there was an
* error. The returned object includes one reference count for the
* pointer returned.
*
* Side effects:
* None.
*
* Notes:
* This procedure is implemented entirely as a wrapper around
* TclLsetFlat. All it does is reconfigure the argument format into the
* form required by TclLsetFlat, while taking care to manage shimmering
* in such a way that we tend to keep the most useful intreps and/or
* avoid the most expensive conversions.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclLsetList(
Tcl_Interp *interp, /* Tcl interpreter. */
Tcl_Obj *listPtr, /* Pointer to the list being modified. */
Tcl_Obj *indexArgPtr, /* Index or index-list arg to 'lset'. */
Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */
{
int indexCount = 0; /* Number of indices in the index list. */
Tcl_Obj **indices = NULL; /* Vector of indices in the index list. */
Tcl_Obj *retValuePtr; /* Pointer to the list to be returned. */
int index; /* Current index in the list - discarded. */
Tcl_Obj *indexListCopy;
List *listRepPtr;
/*
* Determine whether the index arg designates a list or a single index.
* We have to be careful about the order of the checks to avoid repeated
* shimmering; see TIP #22 and #23 for details.
*/
ListGetIntRep(indexArgPtr, listRepPtr);
if (listRepPtr == NULL
&& TclGetIntForIndexM(NULL, indexArgPtr, INT_MAX - 1, &index) == TCL_OK) {
/*
* indexArgPtr designates a single index.
*/
return TclLsetFlat(interp, listPtr, 1, &indexArgPtr, valuePtr);
}
|
| ︙ | ︙ | |||
1449 1450 1451 1452 1453 1454 1455 | *---------------------------------------------------------------------- * * TclLsetFlat -- * * Core engine of the 'lset' command. * It also handles 'lpop' when given a NULL value. * | | | > | < > | > | | < < | < < | | | | < < < | < | | > | | > > | | | < | | 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 |
*----------------------------------------------------------------------
*
* TclLsetFlat --
*
* Core engine of the 'lset' command.
* It also handles 'lpop' when given a NULL value.
*
* Results:
* Returns the new value of the list variable, or NULL if an error
* occurred. The returned object includes one reference count for the
* pointer returned.
*
* Side effects:
* On entry, the reference count of the variable value does not reflect
* any references held on the stack. The first action of this function is
* to determine whether the object is shared, and to duplicate it if it
* is. The reference count of the duplicate is incremented. At this
* point, the reference count will be 1 for either case, so that the
* object will appear to be unshared.
*
* If an error occurs, and the object has been duplicated, the reference
* count on the duplicate is decremented so that it is now 0: this
* dismisses any memory that was allocated by this function.
*
* If no error occurs, the reference count of the original object is
* incremented if the object has not been duplicated, and nothing is done
* to a reference count of the duplicate. Now the reference count of an
* unduplicated object is 2 (the returned pointer, plus the one stored in
* the variable). The reference count of a duplicate object is 1,
* reflecting that the returned pointer is the only active reference. The
* caller is expected to store the returned value back in the variable
* and decrement its reference count. (INST_STORE_* does exactly this.)
*
* Surgery is performed on the unshared list value to produce the result.
* TclLsetFlat maintains a linked list of Tcl_Obj's whose string
* representations must be spoilt by threading via 'ptr2' of the
* two-pointer internal representation. On entry to TclLsetFlat, the
* values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any
* Tcl_Obj that has been modified is set to NULL.
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclLsetFlat(
Tcl_Interp *interp, /* Tcl interpreter. */
Tcl_Obj *listPtr, /* Pointer to the list being modified. */
int indexCount, /* Number of index args. */
Tcl_Obj *const indexArray[],
/* Index args. */
Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */
{
int index, result, len;
Tcl_Obj *subListPtr, *retValuePtr, *chainPtr;
Tcl_ObjIntRep *irPtr;
/*
* If there are no indices, simply return the new value. (Without
* indices, [lset] is a synonym for [set].
* [lpop] does not use this but protect for NULL valuePtr just in case.
|
| ︙ | ︙ | |||
1571 1572 1573 1574 1575 1576 1577 | /* ...the index we're trying to use isn't an index at all. */ result = TCL_ERROR; indexArray++; break; } indexArray++; | | | | | | < | | | | 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 |
/* ...the index we're trying to use isn't an index at all. */
result = TCL_ERROR;
indexArray++;
break;
}
indexArray++;
if (index < 0 || index > elemCount
|| (valuePtr == NULL && index >= elemCount)) {
/* ...the index points outside the sublist. */
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"index \"%s\" out of range", Tcl_GetString(indexArray[-1])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
"OUTOFRANGE", NULL);
}
result = TCL_ERROR;
break;
}
/*
* No error conditions. As long as we're not yet on the last index,
* determine the next sublist for the next pass through the loop, and
* take steps to make sure it is an unshared copy, as we intend to
* modify it.
*/
if (--indexCount) {
parentList = subListPtr;
if (index == elemCount) {
subListPtr = Tcl_NewObj();
} else {
subListPtr = elemPtrs[index];
}
if (Tcl_IsShared(subListPtr)) {
subListPtr = Tcl_DuplicateObj(subListPtr);
}
/*
* Replace the original elemPtr[index] in parentList with a copy
* we know to be unshared. This call will also deal with the
* situation where parentList shares its intrep with other
* Tcl_Obj's. Dealing with the shared intrep case can cause
* subListPtr to become shared again, so detect that case and make
* and store another copy.
*/
if (index == elemCount) {
Tcl_ListObjAppendElement(NULL, parentList, subListPtr);
} else {
TclListObjSetElement(NULL, parentList, index, subListPtr);
}
if (Tcl_IsShared(subListPtr)) {
subListPtr = Tcl_DuplicateObj(subListPtr);
TclListObjSetElement(NULL, parentList, index, subListPtr);
|
| ︙ | ︙ | |||
1658 1659 1660 1661 1662 1663 1664 | List *listRepPtr; /* * Clear away our intrep surgery mess. */ irPtr = TclFetchIntRep(objPtr, &tclListType); | | | | 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 |
List *listRepPtr;
/*
* Clear away our intrep surgery mess.
*/
irPtr = TclFetchIntRep(objPtr, &tclListType);
listRepPtr = (List *)irPtr->twoPtrValue.ptr1;
chainPtr = (Tcl_Obj *)irPtr->twoPtrValue.ptr2;
if (result == TCL_OK) {
/*
* We're going to store valuePtr, so spoil string reps of all
* containing lists.
*/
|
| ︙ | ︙ | |||
1701 1702 1703 1704 1705 1706 1707 |
* proper list - or something convertible to one - above).
*/
len = -1;
TclListObjLength(NULL, subListPtr, &len);
if (valuePtr == NULL) {
Tcl_ListObjReplace(NULL, subListPtr, index, 1, 0, NULL);
| | | < < < | < | < < < < < | | < < < < | | | | | < | | < > | | > > | 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 |
* proper list - or something convertible to one - above).
*/
len = -1;
TclListObjLength(NULL, subListPtr, &len);
if (valuePtr == NULL) {
Tcl_ListObjReplace(NULL, subListPtr, index, 1, 0, NULL);
} else if (index == len) {
Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr);
} else {
TclListObjSetElement(NULL, subListPtr, index, valuePtr);
TclInvalidateStringRep(subListPtr);
}
Tcl_IncrRefCount(retValuePtr);
return retValuePtr;
}
/*
*----------------------------------------------------------------------
*
* TclListObjSetElement --
*
* Set a single element of a list to a specified value
*
* Results:
* The return value is normally TCL_OK. If listPtr does not refer to a
* list object and cannot be converted to one, TCL_ERROR is returned and
* an error message will be left in the interpreter result if interp is
* not NULL. Similarly, if index designates an element outside the range
* [0..listLength-1], where listLength is the count of elements in the
* list object designated by listPtr, TCL_ERROR is returned and an error
* message is left in the interpreter result.
*
* Side effects:
* Tcl_Panic if listPtr designates a shared object. Otherwise, attempts
* to convert it to a list with a non-shared internal rep. Decrements the
* ref count of the object at the specified index within the list,
* replaces with the object designated by valuePtr, and increments the
* ref count of the replacement object.
*
* It is the caller's responsibility to invalidate the string
* representation of the object.
*
*----------------------------------------------------------------------
*/
int
TclListObjSetElement(
Tcl_Interp *interp, /* Tcl interpreter; used for error reporting
|
| ︙ | ︙ | |||
1777 1778 1779 1780 1781 1782 1783 |
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "TclListObjSetElement");
}
ListGetIntRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
| | < | | | | | | | | | | 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 |
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "TclListObjSetElement");
}
ListGetIntRep(listPtr, listRepPtr);
if (listRepPtr == NULL) {
int result, length;
(void) Tcl_GetStringFromObj(listPtr, &length);
if (length == 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"index \"%d\" out of range", index));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX",
"OUTOFRANGE", NULL);
}
return TCL_ERROR;
}
result = SetListFromAny(interp, listPtr);
if (result != TCL_OK) {
return result;
}
ListGetIntRep(listPtr, listRepPtr);
}
elemCount = listRepPtr->elemCount;
/*
* Ensure that the index is in bounds.
*/
if (index<0 || index>=elemCount) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"index \"%d\" out of range", index));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX",
"OUTOFRANGE", NULL);
}
return TCL_ERROR;
}
/*
* If the internal rep is shared, replace it with an unshared copy.
*/
|
| ︙ | ︙ | |||
1882 1883 1884 1885 1886 1887 1888 | } /* *---------------------------------------------------------------------- * * FreeListInternalRep -- * | | | | > > | 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 | } /* *---------------------------------------------------------------------- * * FreeListInternalRep -- * * Deallocate the storage associated with a list object's internal * representation. * * Results: * None. * * Side effects: * Frees listPtr's List* internal representation, if no longer shared. * May decrement the ref counts of element objects, which may free them. * *---------------------------------------------------------------------- */ static void |
| ︙ | ︙ | |||
1909 1910 1911 1912 1913 1914 1915 |
if (listRepPtr->refCount-- <= 1) {
Tcl_Obj **elemPtrs = &listRepPtr->elements;
int i, numElems = listRepPtr->elemCount;
for (i = 0; i < numElems; i++) {
Tcl_DecrRefCount(elemPtrs[i]);
}
| | | | > > | | 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 |
if (listRepPtr->refCount-- <= 1) {
Tcl_Obj **elemPtrs = &listRepPtr->elements;
int i, numElems = listRepPtr->elemCount;
for (i = 0; i < numElems; i++) {
Tcl_DecrRefCount(elemPtrs[i]);
}
ckfree(listRepPtr);
}
}
/*
*----------------------------------------------------------------------
*
* DupListInternalRep --
*
* Initialize the internal representation of a list Tcl_Obj to share the
* internal representation of an existing list object.
*
* Results:
* None.
*
* Side effects:
* The reference count of the List internal rep is incremented.
*
*----------------------------------------------------------------------
*/
static void
DupListInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
|
| ︙ | ︙ | |||
1945 1946 1947 1948 1949 1950 1951 | } /* *---------------------------------------------------------------------- * * SetListFromAny -- * | | | < | < | < > | < | < | | 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 |
}
/*
*----------------------------------------------------------------------
*
* SetListFromAny --
*
* Attempt to generate a list internal form for the Tcl object "objPtr".
*
* Results:
* The return value is TCL_OK or TCL_ERROR. If an error occurs during
* conversion, an error message is left in the interpreter's result
* unless "interp" is NULL.
*
* Side effects:
* If no error occurs, a list is stored as "objPtr"s internal
* representation.
*
*----------------------------------------------------------------------
*/
static int
SetListFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
|
| ︙ | ︙ | |||
2014 2015 2016 2017 2018 2019 2020 |
*elemPtrs++ = keyPtr;
*elemPtrs++ = valuePtr;
Tcl_IncrRefCount(keyPtr);
Tcl_IncrRefCount(valuePtr);
Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
}
} else {
| | < | 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 |
*elemPtrs++ = keyPtr;
*elemPtrs++ = valuePtr;
Tcl_IncrRefCount(keyPtr);
Tcl_IncrRefCount(valuePtr);
Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done);
}
} else {
int estCount, length;
const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length);
/*
* Allocate enough space to hold a (Tcl_Obj *) for each
* (possible) list element.
*/
|
| ︙ | ︙ | |||
2039 2040 2041 2042 2043 2044 2045 |
/*
* Each iteration, parse and store a list element.
*/
while (nextElem < limit) {
const char *elemStart;
char *check;
| | < | | 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 |
/*
* Each iteration, parse and store a list element.
*/
while (nextElem < limit) {
const char *elemStart;
char *check;
int elemSize, literal;
if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem,
&elemStart, &nextElem, &elemSize, &literal)) {
fail:
while (--elemPtrs >= &listRepPtr->elements) {
Tcl_DecrRefCount(*elemPtrs);
}
ckfree(listRepPtr);
return TCL_ERROR;
}
if (elemStart == limit) {
break;
}
TclNewObj(*elemPtrs);
|
| ︙ | ︙ | |||
2093 2094 2095 2096 2097 2098 2099 | } /* *---------------------------------------------------------------------- * * UpdateStringOfList -- * | | < | | | > | > | | > | < | 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 |
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfList --
*
* Update the string representation for a list object. Note: This
* function does not invalidate an existing old string rep so storage
* will be lost if this has not already been done.
*
* Results:
* None.
*
* Side effects:
* The object's string is set to a valid string that results from the
* list-to-string conversion. This string will be empty if the list has
* no elements. The list internal representation should not be NULL and
* we assume it is not NULL.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfList(
Tcl_Obj *listPtr) /* List object with string rep to update. */
{
# define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
int numElems, i, length, bytesNeeded = 0;
const char *elem, *start;
char *dst;
Tcl_Obj **elemPtrs;
List *listRepPtr;
ListGetIntRep(listPtr, listRepPtr);
|
| ︙ | ︙ | |||
2154 2155 2156 2157 2158 2159 2160 |
if (numElems <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
/*
* We know numElems <= LIST_MAX, so this is safe.
*/
| | > > > > > > | | 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 |
if (numElems <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
/*
* We know numElems <= LIST_MAX, so this is safe.
*/
flagPtr = (char *)ckalloc(numElems);
}
elemPtrs = &listRepPtr->elements;
for (i = 0; i < numElems; i++) {
flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
elem = TclGetStringFromObj(elemPtrs[i], &length);
bytesNeeded += TclScanElement(elem, length, flagPtr+i);
if (bytesNeeded < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
}
if (bytesNeeded > INT_MAX - numElems + 1) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
bytesNeeded += numElems - 1;
/*
* Pass 2: copy into string rep buffer.
*/
start = dst = Tcl_InitStringRep(listPtr, NULL, bytesNeeded);
TclOOM(dst, bytesNeeded);
for (i = 0; i < numElems; i++) {
flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
elem = TclGetStringFromObj(elemPtrs[i], &length);
dst += TclConvertElement(elem, length, dst, flagPtr[i]);
*dst++ = ' ';
}
/* Set the string length to what was actually written, the safe choice */
(void) Tcl_InitStringRep(listPtr, NULL, dst - 1 - start);
if (flagPtr != localFlags) {
ckfree(flagPtr);
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclLiteral.c.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 | /* * Function prototypes for static functions in this file: */ static int AddLocalLiteralEntry(CompileEnv *envPtr, Tcl_Obj *objPtr, int localHash); static void ExpandLocalLiteralArray(CompileEnv *envPtr); | | | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | /* * Function prototypes for static functions in this file: */ static int AddLocalLiteralEntry(CompileEnv *envPtr, Tcl_Obj *objPtr, int localHash); static void ExpandLocalLiteralArray(CompileEnv *envPtr); static unsigned HashString(const char *string, int length); #ifdef TCL_COMPILE_DEBUG static LiteralEntry * LookupLiteralEntry(Tcl_Interp *interp, Tcl_Obj *objPtr); #endif static void RebuildLiteralTable(LiteralTable *tablePtr); /* |
| ︙ | ︙ | |||
54 55 56 57 58 59 60 | * The literal table is made ready for use. * *---------------------------------------------------------------------- */ void TclInitLiteralTable( | | | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
* The literal table is made ready for use.
*
*----------------------------------------------------------------------
*/
void
TclInitLiteralTable(
LiteralTable *tablePtr)
/* Pointer to table structure, which is
* supplied by the caller. */
{
#if (TCL_SMALL_HASH_TABLE != 4)
Tcl_Panic("%s: TCL_SMALL_HASH_TABLE is %d, not 4", "TclInitLiteralTable",
TCL_SMALL_HASH_TABLE);
#endif
|
| ︙ | ︙ | |||
110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 |
* Release remaining literals in the table. Note that releasing a literal
* might release other literals, modifying the table, so we restart the
* search from the bucket chain we last found an entry.
*/
#ifdef TCL_COMPILE_DEBUG
TclVerifyGlobalLiteralTable((Interp *) interp);
#endif /*TCL_COMPILE_DEBUG*/
/*
* We used to call TclReleaseLiteral for each literal in the table, which
* is rather inefficient as it causes one lookup-by-hash for each
* reference to the literal. We now rely at interp-deletion on each
* bytecode object to release its references to the literal Tcl_Obj
* without requiring that it updates the global table itself, and deal
* here only with the table.
*/
for (i=0 ; i<tablePtr->numBuckets ; i++) {
entryPtr = tablePtr->buckets[i];
while (entryPtr != NULL) {
objPtr = entryPtr->objPtr;
TclDecrRefCount(objPtr);
nextPtr = entryPtr->nextPtr;
| > > | | | 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 |
* Release remaining literals in the table. Note that releasing a literal
* might release other literals, modifying the table, so we restart the
* search from the bucket chain we last found an entry.
*/
#ifdef TCL_COMPILE_DEBUG
TclVerifyGlobalLiteralTable((Interp *) interp);
#else
(void)interp;
#endif /*TCL_COMPILE_DEBUG*/
/*
* We used to call TclReleaseLiteral for each literal in the table, which
* is rather inefficient as it causes one lookup-by-hash for each
* reference to the literal. We now rely at interp-deletion on each
* bytecode object to release its references to the literal Tcl_Obj
* without requiring that it updates the global table itself, and deal
* here only with the table.
*/
for (i=0 ; i<tablePtr->numBuckets ; i++) {
entryPtr = tablePtr->buckets[i];
while (entryPtr != NULL) {
objPtr = entryPtr->objPtr;
TclDecrRefCount(objPtr);
nextPtr = entryPtr->nextPtr;
ckfree(entryPtr);
entryPtr = nextPtr;
}
}
/*
* Free up the table's bucket array if it was dynamically allocated.
*/
if (tablePtr->buckets != tablePtr->staticBuckets) {
ckfree(tablePtr->buckets);
}
}
/*
*----------------------------------------------------------------------
*
* TclCreateLiteral --
|
| ︙ | ︙ | |||
172 173 174 175 176 177 178 |
*/
Tcl_Obj *
TclCreateLiteral(
Interp *iPtr,
const char *bytes, /* The start of the string. Note that this is
* not a NUL-terminated string. */
| | | | | | | | | | | 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 |
*/
Tcl_Obj *
TclCreateLiteral(
Interp *iPtr,
const char *bytes, /* The start of the string. Note that this is
* not a NUL-terminated string. */
int length, /* Number of bytes in the string. */
unsigned hash, /* The string's hash. If -1, it will be
* computed here. */
int *newPtr,
Namespace *nsPtr,
int flags,
LiteralEntry **globalPtrPtr)
{
LiteralTable *globalTablePtr = &iPtr->literalTable;
LiteralEntry *globalPtr;
unsigned int globalHash;
Tcl_Obj *objPtr;
/*
* Is it in the interpreter's global literal table?
*/
if (hash == (unsigned) -1) {
hash = HashString(bytes, length);
}
globalHash = (hash & globalTablePtr->mask);
for (globalPtr=globalTablePtr->buckets[globalHash] ; globalPtr!=NULL;
globalPtr = globalPtr->nextPtr) {
objPtr = globalPtr->objPtr;
if (globalPtr->nsPtr == nsPtr) {
/*
* Literals should always have UTF-8 representations... but this
* is not guaranteed so we need to be careful anyway.
*
* https://stackoverflow.com/q/54337750/301832
*/
int objLength;
const char *objBytes = TclGetStringFromObj(objPtr, &objLength);
if ((objLength == length) && ((length == 0)
|| ((objBytes[0] == bytes[0])
&& (memcmp(objBytes, bytes, length) == 0)))) {
/*
* A literal was found: return it
*/
if (newPtr) {
*newPtr = 0;
}
if (globalPtrPtr) {
*globalPtrPtr = globalPtr;
}
if (flags & LITERAL_ON_HEAP) {
ckfree(bytes);
}
if (globalPtr->refCount != (unsigned) -1) {
globalPtr->refCount++;
}
return objPtr;
}
}
}
if (!newPtr) {
if ((flags & LITERAL_ON_HEAP)) {
ckfree(bytes);
}
return NULL;
}
/*
* The literal is new to the interpreter.
*/
|
| ︙ | ︙ | |||
268 269 270 271 272 273 274 |
/*
* Yes, add it to the global literal table.
*/
#ifdef TCL_COMPILE_DEBUG
if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be",
| | | | 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 |
/*
* Yes, add it to the global literal table.
*/
#ifdef TCL_COMPILE_DEBUG
if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) {
Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be",
"TclRegisterLiteral", (length>60? 60 : length), bytes);
}
#endif
globalPtr = (LiteralEntry *)ckalloc(sizeof(LiteralEntry));
globalPtr->objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
globalPtr->refCount = 1;
globalPtr->nsPtr = nsPtr;
globalPtr->nextPtr = globalTablePtr->buckets[globalHash];
globalTablePtr->buckets[globalHash] = globalPtr;
globalTablePtr->numEntries++;
|
| ︙ | ︙ | |||
308 309 310 311 312 313 314 |
if ((entryPtr == globalPtr) && (entryPtr->objPtr == objPtr)) {
found = 1;
}
}
}
if (!found) {
Tcl_Panic("%s: literal \"%.*s\" wasn't global",
| | | 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 |
if ((entryPtr == globalPtr) && (entryPtr->objPtr == objPtr)) {
found = 1;
}
}
}
if (!found) {
Tcl_Panic("%s: literal \"%.*s\" wasn't global",
"TclRegisterLiteral", (length>60? 60 : length), bytes);
}
}
#endif /*TCL_COMPILE_DEBUG*/
#ifdef TCL_COMPILE_STATS
iPtr->stats.numLiteralsCreated++;
iPtr->stats.totalLitStringBytes += (double) (length + 1);
|
| ︙ | ︙ | |||
345 346 347 348 349 350 351 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclFetchLiteral(
CompileEnv *envPtr, /* Points to the CompileEnv from which to
* fetch the registered literal value. */
| | | | 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclFetchLiteral(
CompileEnv *envPtr, /* Points to the CompileEnv from which to
* fetch the registered literal value. */
unsigned int index) /* Index of the desired literal, as returned
* by prior call to TclRegisterLiteral() */
{
if (index >= (unsigned int) envPtr->literalArrayNext) {
return NULL;
}
return envPtr->literalArrayPtr[index].objPtr;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
385 386 387 388 389 390 391 |
*----------------------------------------------------------------------
*/
int
TclRegisterLiteral(
void *ePtr, /* Points to the CompileEnv in whose object
* array an object is found or created. */
| | | | > | | | | | 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 |
*----------------------------------------------------------------------
*/
int
TclRegisterLiteral(
void *ePtr, /* Points to the CompileEnv in whose object
* array an object is found or created. */
const char *bytes, /* Points to string for which to find or
* create an object in CompileEnv's object
* array. */
int length, /* Number of bytes in the string. If < 0, the
* string consists of all bytes up to the
* first null character. */
int flags) /* If LITERAL_ON_HEAP then the caller already
* malloc'd bytes and ownership is passed to
* this function. If LITERAL_CMD_NAME then
* the literal should not be shared accross
* namespaces. */
{
CompileEnv *envPtr = (CompileEnv *)ePtr;
Interp *iPtr = envPtr->iPtr;
LiteralTable *localTablePtr = &envPtr->localLitTable;
LiteralEntry *globalPtr, *localPtr;
Tcl_Obj *objPtr;
unsigned hash;
unsigned int localHash;
int objIndex, isNew;
Namespace *nsPtr;
if (length < 0) {
length = (bytes ? strlen(bytes) : 0);
}
hash = HashString(bytes, length);
/*
* Is the literal already in the CompileEnv's local literal array? If so,
* just return its index.
*/
localHash = (hash & localTablePtr->mask);
for (localPtr=localTablePtr->buckets[localHash] ; localPtr!=NULL;
localPtr = localPtr->nextPtr) {
objPtr = localPtr->objPtr;
if ((objPtr->length == length) && ((length == 0)
|| ((objPtr->bytes[0] == bytes[0])
&& (memcmp(objPtr->bytes, bytes, length) == 0)))) {
if ((flags & LITERAL_ON_HEAP)) {
ckfree(bytes);
}
objIndex = (localPtr - envPtr->literalArrayPtr);
#ifdef TCL_COMPILE_DEBUG
TclVerifyLocalLiteralTable(envPtr);
#endif /*TCL_COMPILE_DEBUG*/
return objIndex;
|
| ︙ | ︙ | |||
457 458 459 460 461 462 463 |
}
/*
* Is it in the interpreter's global literal table? If not, create it.
*/
globalPtr = NULL;
| | | | | | 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 |
}
/*
* Is it in the interpreter's global literal table? If not, create it.
*/
globalPtr = NULL;
objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &isNew, nsPtr, flags,
&globalPtr);
objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash);
#ifdef TCL_COMPILE_DEBUG
if (globalPtr != NULL && globalPtr->refCount + 1 < 2) {
Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d",
"TclRegisterLiteral", (length>60? 60 : length), bytes,
globalPtr->refCount);
}
TclVerifyLocalLiteralTable(envPtr);
#endif /*TCL_COMPILE_DEBUG*/
return objIndex;
}
|
| ︙ | ︙ | |||
494 495 496 497 498 499 500 |
*----------------------------------------------------------------------
*/
static LiteralEntry *
LookupLiteralEntry(
Tcl_Interp *interp, /* Interpreter for which objPtr was created to
* hold a literal. */
| | | | | 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 |
*----------------------------------------------------------------------
*/
static LiteralEntry *
LookupLiteralEntry(
Tcl_Interp *interp, /* Interpreter for which objPtr was created to
* hold a literal. */
Tcl_Obj *objPtr) /* Points to a Tcl object holding a literal
* that was previously created by a call to
* TclRegisterLiteral. */
{
Interp *iPtr = (Interp *) interp;
LiteralTable *globalTablePtr = &iPtr->literalTable;
LiteralEntry *entryPtr;
const char *bytes;
int length, globalHash;
bytes = TclGetStringFromObj(objPtr, &length);
globalHash = (HashString(bytes, length) & globalTablePtr->mask);
for (entryPtr=globalTablePtr->buckets[globalHash] ; entryPtr!=NULL;
entryPtr=entryPtr->nextPtr) {
if (entryPtr->objPtr == objPtr) {
return entryPtr;
|
| ︙ | ︙ | |||
540 541 542 543 544 545 546 |
*----------------------------------------------------------------------
*/
void
TclHideLiteral(
Tcl_Interp *interp, /* Interpreter for which objPtr was created to
* hold a literal. */
| | | > | 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 |
*----------------------------------------------------------------------
*/
void
TclHideLiteral(
Tcl_Interp *interp, /* Interpreter for which objPtr was created to
* hold a literal. */
CompileEnv *envPtr,/* Points to CompileEnv whose literal array
* contains the entry being hidden. */
int index) /* The index of the entry in the literal
* array. */
{
LiteralEntry **nextPtrPtr, *entryPtr, *lPtr;
LiteralTable *localTablePtr = &envPtr->localLitTable;
unsigned int localHash;
int length;
const char *bytes;
Tcl_Obj *newObjPtr;
lPtr = &envPtr->literalArrayPtr[index];
/*
* To avoid unwanted sharing we need to copy the object and remove it from
|
| ︙ | ︙ | |||
603 604 605 606 607 608 609 | * literal object. * *---------------------------------------------------------------------- */ int TclAddLiteralObj( | | | | | 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 |
* literal object.
*
*----------------------------------------------------------------------
*/
int
TclAddLiteralObj(
CompileEnv *envPtr,/* Points to CompileEnv in whose literal array
* the object is to be inserted. */
Tcl_Obj *objPtr, /* The object to insert into the array. */
LiteralEntry **litPtrPtr) /* The location where the pointer to the new
* literal entry should be stored. May be
* NULL. */
{
LiteralEntry *lPtr;
int objIndex;
if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) {
ExpandLocalLiteralArray(envPtr);
}
objIndex = envPtr->literalArrayNext;
envPtr->literalArrayNext++;
lPtr = &envPtr->literalArrayPtr[objIndex];
lPtr->objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
lPtr->refCount = (unsigned) -1; /* i.e., unused */
lPtr->nextPtr = NULL;
if (litPtrPtr) {
*litPtrPtr = lPtr;
}
return objIndex;
|
| ︙ | ︙ | |||
652 653 654 655 656 657 658 | * array of the CompileEnv's literal array if it becomes too large. * *---------------------------------------------------------------------- */ static int AddLocalLiteralEntry( | | | | 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 |
* array of the CompileEnv's literal array if it becomes too large.
*
*----------------------------------------------------------------------
*/
static int
AddLocalLiteralEntry(
CompileEnv *envPtr,/* Points to CompileEnv in whose literal array
* the object is to be inserted. */
Tcl_Obj *objPtr, /* The literal to add to the CompileEnv. */
int localHash) /* Hash value for the literal's string. */
{
LiteralTable *localTablePtr = &envPtr->localLitTable;
LiteralEntry *localPtr;
int objIndex;
objIndex = TclAddLiteralObj(envPtr, objPtr, &localPtr);
/*
* Add the literal to the local table.
|
| ︙ | ︙ | |||
684 685 686 687 688 689 690 |
RebuildLiteralTable(localTablePtr);
}
#ifdef TCL_COMPILE_DEBUG
TclVerifyLocalLiteralTable(envPtr);
{
char *bytes;
| | | | | 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 |
RebuildLiteralTable(localTablePtr);
}
#ifdef TCL_COMPILE_DEBUG
TclVerifyLocalLiteralTable(envPtr);
{
char *bytes;
int length, found;
size_t i;
found = 0;
for (i=0 ; i<localTablePtr->numBuckets ; i++) {
for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL ;
localPtr=localPtr->nextPtr) {
if (localPtr->objPtr == objPtr) {
found = 1;
}
}
}
if (!found) {
bytes = TclGetStringFromObj(objPtr, &length);
Tcl_Panic("%s: literal \"%.*s\" wasn't found locally",
"AddLocalLiteralEntry", (length>60? 60 : length), bytes);
}
}
#endif /*TCL_COMPILE_DEBUG*/
return objIndex;
}
|
| ︙ | ︙ | |||
730 731 732 733 734 735 736 | * The local literal table is updated to refer to the new entries. * *---------------------------------------------------------------------- */ static void ExpandLocalLiteralArray( | | | 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 |
* The local literal table is updated to refer to the new entries.
*
*----------------------------------------------------------------------
*/
static void
ExpandLocalLiteralArray(
CompileEnv *envPtr)/* Points to the CompileEnv whose object array
* must be enlarged. */
{
/*
* The current allocated local literal entries are stored between elements
* 0 and (envPtr->literalArrayNext - 1) [inclusive].
*/
|
| ︙ | ︙ | |||
752 753 754 755 756 757 758 |
if (currBytes == newSize) {
Tcl_Panic("max size of Tcl literal array (%" TCL_Z_MODIFIER "u literals) exceeded",
currElems);
}
if (envPtr->mallocedLiteralArray) {
| | | | | | 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 |
if (currBytes == newSize) {
Tcl_Panic("max size of Tcl literal array (%" TCL_Z_MODIFIER "u literals) exceeded",
currElems);
}
if (envPtr->mallocedLiteralArray) {
newArrayPtr = (LiteralEntry *)ckrealloc(currArrayPtr, newSize);
} else {
/*
* envPtr->literalArrayPtr isn't a ckalloc'd pointer, so we must
* code a ckrealloc equivalent for ourselves.
*/
newArrayPtr = (LiteralEntry *)ckalloc(newSize);
memcpy(newArrayPtr, currArrayPtr, currBytes);
envPtr->mallocedLiteralArray = 1;
}
/*
* Update the local literal table's bucket array.
*/
|
| ︙ | ︙ | |||
812 813 814 815 816 817 818 |
*----------------------------------------------------------------------
*/
void
TclReleaseLiteral(
Tcl_Interp *interp, /* Interpreter for which objPtr was created to
* hold a literal. */
| | | | > | | | | 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 |
*----------------------------------------------------------------------
*/
void
TclReleaseLiteral(
Tcl_Interp *interp, /* Interpreter for which objPtr was created to
* hold a literal. */
Tcl_Obj *objPtr) /* Points to a literal object that was
* previously created by a call to
* TclRegisterLiteral. */
{
Interp *iPtr = (Interp *) interp;
LiteralTable *globalTablePtr;
LiteralEntry *entryPtr, *prevPtr;
const char *bytes;
int length;
unsigned int index;
if (iPtr == NULL) {
goto done;
}
globalTablePtr = &iPtr->literalTable;
bytes = TclGetStringFromObj(objPtr, &length);
index = (HashString(bytes, length) & globalTablePtr->mask);
/*
* Check to see if the object is in the global literal table and remove
* this reference. The object may not be in the table if it is a hidden
* local literal.
*/
for (prevPtr=NULL, entryPtr=globalTablePtr->buckets[index];
entryPtr!=NULL ; prevPtr=entryPtr, entryPtr=entryPtr->nextPtr) {
if (entryPtr->objPtr == objPtr) {
/*
* If the literal is no longer being used by any ByteCode, delete
* the entry then remove the reference corresponding to the global
* literal table entry (decrement the ref count of the object).
*/
if ((entryPtr->refCount != (unsigned)-1) && (entryPtr->refCount-- <= 1)) {
if (prevPtr == NULL) {
globalTablePtr->buckets[index] = entryPtr->nextPtr;
} else {
prevPtr->nextPtr = entryPtr->nextPtr;
}
ckfree(entryPtr);
globalTablePtr->numEntries--;
TclDecrRefCount(objPtr);
#ifdef TCL_COMPILE_STATS
iPtr->stats.currentLitStringBytes -= (double) (length + 1);
#endif /*TCL_COMPILE_STATS*/
|
| ︙ | ︙ | |||
889 890 891 892 893 894 895 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | | 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static unsigned
HashString(
const char *string, /* String for which to compute hash value. */
int length) /* Number of bytes in the string. */
{
unsigned int result = 0;
/*
* I tried a zillion different hash functions and asked many other people
* for advice. Many people had their own favorite functions, all
* different, but no-one had much idea why they were good ones. I chose
* the one below (multiply by 9 and add new character) because of the
* following reasons:
|
| ︙ | ︙ | |||
955 956 957 958 959 960 961 | * Memory gets reallocated and entries get rehashed into new buckets. * *---------------------------------------------------------------------- */ static void RebuildLiteralTable( | | | | | > > | | 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 |
* Memory gets reallocated and entries get rehashed into new buckets.
*
*----------------------------------------------------------------------
*/
static void
RebuildLiteralTable(
LiteralTable *tablePtr)
/* Local or global table to enlarge. */
{
LiteralEntry **oldBuckets;
LiteralEntry **oldChainPtr, **newChainPtr;
LiteralEntry *entryPtr;
LiteralEntry **bucketPtr;
const char *bytes;
unsigned int oldSize, index;
int count, length;
oldSize = tablePtr->numBuckets;
oldBuckets = tablePtr->buckets;
/*
* Allocate and initialize the new bucket array, and set up hashing
* constants for new array size.
*/
if (oldSize > UINT_MAX/(4 * sizeof(LiteralEntry *))) {
/*
* Memory allocator limitations will not let us create the
* next larger table size. Best option is to limp along
* with what we have.
*/
return;
}
tablePtr->numBuckets *= 4;
tablePtr->buckets = (LiteralEntry **)ckalloc(
tablePtr->numBuckets * sizeof(LiteralEntry*));
for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets;
count>0 ; count--, newChainPtr++) {
*newChainPtr = NULL;
}
tablePtr->rebuildSize *= 4;
tablePtr->mask = (tablePtr->mask << 2) + 3;
|
| ︙ | ︙ | |||
1013 1014 1015 1016 1017 1018 1019 |
}
/*
* Free up the old bucket array, if it was dynamically allocated.
*/
if (oldBuckets != tablePtr->staticBuckets) {
| | | 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 |
}
/*
* Free up the old bucket array, if it was dynamically allocated.
*/
if (oldBuckets != tablePtr->staticBuckets) {
ckfree(oldBuckets);
}
}
/*
*----------------------------------------------------------------------
*
* TclInvalidateCmdLiteral --
|
| ︙ | ︙ | |||
1086 1087 1088 1089 1090 1091 1092 |
*/
char *
TclLiteralStats(
LiteralTable *tablePtr) /* Table for which to produce stats. */
{
#define NUM_COUNTERS 10
| | > > | | 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 |
*/
char *
TclLiteralStats(
LiteralTable *tablePtr) /* Table for which to produce stats. */
{
#define NUM_COUNTERS 10
size_t count[NUM_COUNTERS];
int overflow;
size_t i, j;
double average, tmp;
LiteralEntry *entryPtr;
char *result, *p;
/*
* Compute a histogram of bucket usage. For each bucket chain i, j is the
* number of entries in the chain.
*/
|
| ︙ | ︙ | |||
1120 1121 1122 1123 1124 1125 1126 |
average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;
}
/*
* Print out the histogram and a few other pieces of information.
*/
| | | | | 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 |
average += (tmp+1.0)*(tmp/tablePtr->numEntries)/2.0;
}
/*
* Print out the histogram and a few other pieces of information.
*/
result = (char *)ckalloc(NUM_COUNTERS*60 + 300);
sprintf(result, "%d entries in table, %d buckets\n",
tablePtr->numEntries, tablePtr->numBuckets);
p = result + strlen(result);
for (i=0 ; i<NUM_COUNTERS ; i++) {
sprintf(p, "number of buckets with %" TCL_Z_MODIFIER "u entries: %" TCL_Z_MODIFIER "u\n",
i, count[i]);
p += strlen(p);
}
sprintf(p, "number of buckets with %d or more entries: %d\n",
NUM_COUNTERS, overflow);
p += strlen(p);
sprintf(p, "average search distance for entry: %.1f", average);
return result;
}
#endif /*TCL_COMPILE_STATS*/
|
| ︙ | ︙ | |||
1159 1160 1161 1162 1163 1164 1165 |
*/
void
TclVerifyLocalLiteralTable(
CompileEnv *envPtr) /* Points to CompileEnv whose literal table is
* to be validated. */
{
| | | | > > | | | | | 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 |
*/
void
TclVerifyLocalLiteralTable(
CompileEnv *envPtr) /* Points to CompileEnv whose literal table is
* to be validated. */
{
LiteralTable *localTablePtr = &envPtr->localLitTable;
LiteralEntry *localPtr;
char *bytes;
size_t i, count;
int length;
count = 0;
for (i=0 ; i<localTablePtr->numBuckets ; i++) {
for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL;
localPtr=localPtr->nextPtr) {
count++;
if (localPtr->refCount != (unsigned)-1) {
bytes = TclGetStringFromObj(localPtr->objPtr, &length);
Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %u",
"TclVerifyLocalLiteralTable",
(length>60? 60 : length), bytes, localPtr->refCount);
}
if (localPtr->objPtr->bytes == NULL) {
Tcl_Panic("%s: literal has NULL string rep",
"TclVerifyLocalLiteralTable");
}
}
}
if (count != localTablePtr->numEntries) {
Tcl_Panic("%s: local literal table had %" TCL_Z_MODIFIER "u entries, should be %u",
"TclVerifyLocalLiteralTable", count,
localTablePtr->numEntries);
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1208 1209 1210 1211 1212 1213 1214 |
*/
void
TclVerifyGlobalLiteralTable(
Interp *iPtr) /* Points to interpreter whose global literal
* table is to be validated. */
{
| | | | > > | | | | 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 |
*/
void
TclVerifyGlobalLiteralTable(
Interp *iPtr) /* Points to interpreter whose global literal
* table is to be validated. */
{
LiteralTable *globalTablePtr = &iPtr->literalTable;
LiteralEntry *globalPtr;
char *bytes;
size_t i, count;
int length;
count = 0;
for (i=0 ; i<globalTablePtr->numBuckets ; i++) {
for (globalPtr=globalTablePtr->buckets[i] ; globalPtr!=NULL;
globalPtr=globalPtr->nextPtr) {
count++;
if (globalPtr->refCount + 1 < 2) {
bytes = TclGetStringFromObj(globalPtr->objPtr, &length);
Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d",
"TclVerifyGlobalLiteralTable",
(length>60? 60 : length), bytes, globalPtr->refCount);
}
if (globalPtr->objPtr->bytes == NULL) {
Tcl_Panic("%s: literal has NULL string rep",
"TclVerifyGlobalLiteralTable");
}
}
}
if (count != globalTablePtr->numEntries) {
Tcl_Panic("%s: global literal table had %" TCL_Z_MODIFIER "u entries, should be %u",
"TclVerifyGlobalLiteralTable", count,
globalTablePtr->numEntries);
}
}
#endif /*TCL_COMPILE_DEBUG*/
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
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 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_LoadObjCmd(
TCL_UNUSED(ClientData),
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;
Tcl_DString unloadName, safeUnloadName;
InterpPackage *ipFirstPtr, *ipPtr;
int code, namesMatch, filesMatch, offset;
const char *symbols[2];
Tcl_PackageInitProc *initProc;
const char *p, *fullFileName, *packageName;
Tcl_LoadHandle loadHandle;
Tcl_UniChar ch = 0;
unsigned len;
int index, flags = 0;
Tcl_Obj *const *savedobjv = objv;
static const char *const options[] = {
"-global", "-lazy", "--", NULL
};
enum options {
LOAD_GLOBAL, LOAD_LAZY, LOAD_LAST
|
| ︙ | ︙ | |||
161 162 163 164 165 166 167 |
if ((objc < 2) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?packageName? ?interp?");
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
return TCL_ERROR;
}
| | | | | 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 |
if ((objc < 2) || (objc > 4)) {
Tcl_WrongNumArgs(interp, 1, savedobjv, "?-global? ?-lazy? ?--? fileName ?packageName? ?interp?");
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
return TCL_ERROR;
}
fullFileName = Tcl_GetString(objv[1]);
Tcl_DStringInit(&pkgName);
Tcl_DStringInit(&initName);
Tcl_DStringInit(&safeInitName);
Tcl_DStringInit(&unloadName);
Tcl_DStringInit(&safeUnloadName);
Tcl_DStringInit(&tmp);
packageName = NULL;
if (objc >= 3) {
packageName = Tcl_GetString(objv[2]);
if (packageName[0] == '\0') {
packageName = NULL;
}
}
if ((fullFileName[0] == 0) && (packageName == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must specify either file name or package name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY",
NULL);
code = TCL_ERROR;
goto done;
}
/*
* Figure out which interpreter we're going to load the package into.
*/
target = interp;
if (objc == 4) {
const char *slaveIntName = Tcl_GetString(objv[3]);
target = Tcl_GetSlave(interp, slaveIntName);
if (target == NULL) {
code = TCL_ERROR;
goto done;
}
}
|
| ︙ | ︙ | |||
267 268 269 270 271 272 273 |
/*
* Scan through the list of packages already loaded in the target
* interpreter. If the package we want is already loaded there, then
* there's nothing for us to do.
*/
if (pkgPtr != NULL) {
| | | 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 |
/*
* Scan through the list of packages already loaded in the target
* interpreter. If the package we want is already loaded there, then
* there's nothing for us to do.
*/
if (pkgPtr != NULL) {
ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL);
for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
if (ipPtr->pkgPtr == pkgPtr) {
code = TCL_OK;
goto done;
}
}
}
|
| ︙ | ︙ | |||
320 321 322 323 324 325 326 | * 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); | | | 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 |
* 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__
if ((pkgGuess[0] == 'c') && (pkgGuess[1] == 'y')
&& (pkgGuess[2] == 'g')) {
|
| ︙ | ︙ | |||
397 398 399 400 401 402 403 | goto done; } /* * Create a new record to describe this package. */ | | | | | 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 | goto done; } /* * Create a new record to describe this package. */ pkgPtr = (LoadedPackage *)ckalloc(sizeof(LoadedPackage)); len = strlen(fullFileName) + 1; pkgPtr->fileName = (char *)ckalloc(len); memcpy(pkgPtr->fileName, fullFileName, len); len = Tcl_DStringLength(&pkgName) + 1; pkgPtr->packageName = (char *)ckalloc(len); memcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName), len); pkgPtr->loadHandle = loadHandle; pkgPtr->initProc = initProc; pkgPtr->safeInitProc = (Tcl_PackageInitProc *) Tcl_FindSymbol(interp, loadHandle, Tcl_DStringValue(&safeInitName)); pkgPtr->unloadProc = (Tcl_PackageUnloadProc *) |
| ︙ | ︙ | |||
466 467 468 469 470 471 472 473 |
/*
* Test for whether the initialization failed. If so, transfer the error
* from the target interpreter to the originating one.
*/
if (code != TCL_OK) {
Interp *iPtr = (Interp *) target;
| > | | | | > | 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 |
/*
* Test for whether the initialization failed. If so, transfer the error
* from the target interpreter to the originating one.
*/
if (code != TCL_OK) {
#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
Interp *iPtr = (Interp *) target;
if (iPtr->result && *(iPtr->result) && !iPtr->freeProc) {
/*
* A call to Tcl_InitStubs() determined the caller extension and
* this interp are incompatible in their stubs mechanisms, and
* recorded the error in the oldest legacy place we have to do so.
*/
Tcl_SetObjResult(target, Tcl_NewStringObj(iPtr->result, -1));
iPtr->result = &tclEmptyString;
iPtr->freeProc = NULL;
}
#endif /* defined(TCL_NO_DEPRECATED) */
Tcl_TransferResult(target, code, interp);
goto done;
}
/*
* Record the fact that the package has been loaded in the target
* interpreter.
|
| ︙ | ︙ | |||
501 502 503 504 505 506 507 |
Tcl_MutexUnlock(&packageMutex);
/*
* Refetch ipFirstPtr: loading the package may have introduced additional
* static packages at the head of the linked list!
*/
| | | | 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 |
Tcl_MutexUnlock(&packageMutex);
/*
* Refetch ipFirstPtr: loading the package may have introduced additional
* static packages at the head of the linked list!
*/
ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL);
ipPtr = (InterpPackage *)ckalloc(sizeof(InterpPackage));
ipPtr->pkgPtr = pkgPtr;
ipPtr->nextPtr = ipFirstPtr;
Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr);
done:
Tcl_DStringFree(&pkgName);
Tcl_DStringFree(&initName);
|
| ︙ | ︙ | |||
536 537 538 539 540 541 542 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_UnloadObjCmd( | | | 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_UnloadObjCmd(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
560 561 562 563 564 565 566 |
enum options {
UNLOAD_NOCOMPLAIN, UNLOAD_KEEPLIB, UNLOAD_LAST
};
for (i = 1; i < objc; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
&index) != TCL_OK) {
| | | 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 |
enum options {
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]);
if (fullFileName[0] == '-') {
/*
* It looks like the command contains an option so signal an
* error
*/
return TCL_ERROR;
|
| ︙ | ︙ | |||
600 601 602 603 604 605 606 |
"?-switch ...? fileName ?packageName? ?interp?");
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
return TCL_ERROR;
}
| | | | | 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 |
"?-switch ...? fileName ?packageName? ?interp?");
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
return TCL_ERROR;
}
fullFileName = Tcl_GetString(objv[i]);
Tcl_DStringInit(&pkgName);
Tcl_DStringInit(&tmp);
packageName = NULL;
if (objc - i >= 2) {
packageName = Tcl_GetString(objv[i+1]);
if (packageName[0] == '\0') {
packageName = NULL;
}
}
if ((fullFileName[0] == 0) && (packageName == NULL)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"must specify either file name or package name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY",
NULL);
code = TCL_ERROR;
goto done;
}
/*
* Figure out which interpreter we're going to load the package into.
*/
target = interp;
if (objc - i == 3) {
const char *slaveIntName = Tcl_GetString(objv[i + 2]);
target = Tcl_GetSlave(interp, slaveIntName);
if (target == NULL) {
return TCL_ERROR;
}
}
|
| ︙ | ︙ | |||
714 715 716 717 718 719 720 |
* Scan through the list of packages already loaded in the target
* interpreter. If the package we want is already loaded there, then we
* should proceed with unloading.
*/
code = TCL_ERROR;
if (pkgPtr != NULL) {
| | | 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 |
* Scan through the list of packages already loaded in the target
* interpreter. If the package we want is already loaded there, then we
* should proceed with unloading.
*/
code = TCL_ERROR;
if (pkgPtr != NULL) {
ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL);
for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
if (ipPtr->pkgPtr == pkgPtr) {
code = TCL_OK;
break;
}
}
}
|
| ︙ | ︙ | |||
869 870 871 872 873 874 875 | } } /* * Remove this library from the interpreter's library cache. */ | | | | | | | | 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 |
}
}
/*
* Remove this library from the interpreter's library cache.
*/
ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL);
ipPtr = ipFirstPtr;
if (ipPtr->pkgPtr == defaultPtr) {
ipFirstPtr = ipFirstPtr->nextPtr;
} else {
InterpPackage *ipPrevPtr;
for (ipPrevPtr = ipPtr; ipPtr != NULL;
ipPrevPtr = ipPtr, ipPtr = ipPtr->nextPtr) {
if (ipPtr->pkgPtr == defaultPtr) {
ipPrevPtr->nextPtr = ipPtr->nextPtr;
break;
}
}
}
Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc,
ipFirstPtr);
ckfree(defaultPtr->fileName);
ckfree(defaultPtr->packageName);
ckfree(defaultPtr);
ckfree(ipPtr);
Tcl_MutexUnlock(&packageMutex);
} else {
code = TCL_ERROR;
}
}
#else
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
|
| ︙ | ︙ | |||
976 977 978 979 980 981 982 |
/*
* If the package is not yet recorded as being loaded statically, add it
* to the list now.
*/
if (pkgPtr == NULL) {
| | | | | | | 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 |
/*
* If the package is not yet recorded as being loaded statically, add it
* to the list now.
*/
if (pkgPtr == NULL) {
pkgPtr = (LoadedPackage *)ckalloc(sizeof(LoadedPackage));
pkgPtr->fileName = (char *)ckalloc(1);
pkgPtr->fileName[0] = 0;
pkgPtr->packageName = (char *)ckalloc(strlen(pkgName) + 1);
strcpy(pkgPtr->packageName, pkgName);
pkgPtr->loadHandle = NULL;
pkgPtr->initProc = initProc;
pkgPtr->safeInitProc = safeInitProc;
Tcl_MutexLock(&packageMutex);
pkgPtr->nextPtr = firstPackagePtr;
firstPackagePtr = pkgPtr;
Tcl_MutexUnlock(&packageMutex);
}
if (interp != NULL) {
/*
* If we're loading the package into an interpreter, determine whether
* it's already loaded.
*/
ipFirstPtr = (InterpPackage *)Tcl_GetAssocData(interp, "tclLoad", NULL);
for (ipPtr = ipFirstPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
if (ipPtr->pkgPtr == pkgPtr) {
return;
}
}
/*
* Package isn't loaded in the current interp yet. Mark it as now being
* loaded.
*/
ipPtr = (InterpPackage *)ckalloc(sizeof(InterpPackage));
ipPtr->pkgPtr = pkgPtr;
ipPtr->nextPtr = ipFirstPtr;
Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr);
}
}
/*
|
| ︙ | ︙ | |||
1085 1086 1087 1088 1089 1090 1091 |
return TCL_OK;
}
target = Tcl_GetSlave(interp, targetName);
if (target == NULL) {
return TCL_ERROR;
}
| | | 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 |
return TCL_OK;
}
target = Tcl_GetSlave(interp, targetName);
if (target == NULL) {
return TCL_ERROR;
}
ipPtr = (InterpPackage *)Tcl_GetAssocData(target, "tclLoad", NULL);
/*
* Return information about all of the available packages.
*/
if (packageName) {
resultObj = NULL;
|
| ︙ | ︙ | |||
1146 1147 1148 1149 1150 1151 1152 |
*----------------------------------------------------------------------
*/
static void
LoadCleanupProc(
ClientData clientData, /* Pointer to first InterpPackage structure
* for interp. */
| | | | | 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 |
*----------------------------------------------------------------------
*/
static void
LoadCleanupProc(
ClientData clientData, /* Pointer to first InterpPackage structure
* for interp. */
TCL_UNUSED(Tcl_Interp *))
{
InterpPackage *ipPtr, *nextPtr;
ipPtr = (InterpPackage *)clientData;
while (ipPtr != NULL) {
nextPtr = ipPtr->nextPtr;
ckfree(ipPtr);
ipPtr = nextPtr;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1204 1205 1206 1207 1208 1209 1210 |
*/
if (pkgPtr->fileName[0] != '\0') {
Tcl_FSUnloadFile(NULL, pkgPtr->loadHandle);
}
#endif
| | | | | 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 |
*/
if (pkgPtr->fileName[0] != '\0') {
Tcl_FSUnloadFile(NULL, pkgPtr->loadHandle);
}
#endif
ckfree(pkgPtr->fileName);
ckfree(pkgPtr->packageName);
ckfree(pkgPtr);
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclMain.c.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | * Copyright (c) 2000 Ajuba Solutions. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* | | | | < < < < < < < < < < | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | * Copyright (c) 2000 Ajuba Solutions. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ /* * On Windows, this file needs to be compiled twice, once with UNICODE and * _UNICODE defined. This way both Tcl_Main and Tcl_MainExW can be * implemented, sharing the same source code. */ #include "tclInt.h" /* * The default prompt used when the user has not overridden it. */ #define DEFAULT_PRIMARY_PROMPT "% " |
| ︙ | ︙ | |||
49 50 51 52 53 54 55 | #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 64 65 66 |
#ifndef _WIN32
# define TCHAR char
# define TEXT(arg) arg
# define _tcscmp strcmp
#endif
static inline 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
* source directory to make their own modified versions).
*/
|
| ︙ | ︙ | |||
137 138 139 140 141 142 143 | */ MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void); static void Prompt(Tcl_Interp *interp, InteractiveState *isPtr); static void StdinProc(ClientData clientData, int mask); static void FreeMainInterp(ClientData clientData); | | | 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 | */ MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void); static void Prompt(Tcl_Interp *interp, InteractiveState *isPtr); static void StdinProc(ClientData clientData, int mask); static void FreeMainInterp(ClientData clientData); #if !defined(_WIN32) || defined(UNICODE) && !defined(TCL_ASCII_MAIN) static Tcl_ThreadDataKey dataKey; /* *---------------------------------------------------------------------- * * Tcl_SetStartupScript -- * |
| ︙ | ︙ | |||
218 219 220 221 222 223 224 |
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (encodingPtr != NULL) {
if (tsdPtr->encoding == NULL) {
*encodingPtr = NULL;
} else {
| | | 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 |
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (encodingPtr != NULL) {
if (tsdPtr->encoding == NULL) {
*encodingPtr = NULL;
} else {
*encodingPtr = Tcl_GetString(tsdPtr->encoding);
}
}
return tsdPtr->path;
}
/*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
282 283 284 285 286 287 288 |
}
}
}
}
Tcl_DStringFree(&temp);
}
}
| | | | 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 |
}
}
}
}
Tcl_DStringFree(&temp);
}
}
#endif /* !UNICODE */
/*----------------------------------------------------------------------
*
* Tcl_MainEx --
*
* Main program for tclsh and most other Tcl-based applications.
*
* Results:
* None. This function never returns (it exits the process when it's
* done).
*
* Side effects:
* This function initializes the Tcl world and then starts interpreting
* commands; almost anything could happen, depending on the script being
* interpreted.
*
*----------------------------------------------------------------------
*/
void
Tcl_MainEx(
int argc, /* Number of arguments. */
TCHAR **argv, /* Array of argument strings. */
Tcl_AppInitProc *appInitProc,
/* Application-specific initialization
* function to call after most initialization
* but before starting to execute commands. */
|
| ︙ | ︙ | |||
344 345 346 347 348 349 350 |
* -encoding ENCODING FILENAME
* or like
* FILENAME
*/
if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
&& ('-' != argv[3][0])) {
| | | | | | | | 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 |
* -encoding ENCODING FILENAME
* or like
* FILENAME
*/
if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
&& ('-' != argv[3][0])) {
Tcl_Obj *value = NewNativeObj(argv[2]);
Tcl_SetStartupScript(NewNativeObj(argv[3]),
Tcl_GetString(value));
Tcl_DecrRefCount(value);
argc -= 3;
argv += 3;
} else if ((argc > 1) && ('-' != argv[1][0])) {
Tcl_SetStartupScript(NewNativeObj(argv[1]), NULL);
argc--;
argv++;
}
}
path = Tcl_GetStartupScript(&encodingName);
if (path == NULL) {
appName = NewNativeObj(argv[0]);
} else {
appName = path;
}
Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY);
argc--;
argv++;
Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(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.
*/
|
| ︙ | ︙ | |||
465 466 467 468 469 470 471 |
Tcl_IncrRefCount(is.commandPtr);
/*
* Get a new value for tty if anyone writes to ::tcl_interactive
*/
| | | | | 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 |
Tcl_IncrRefCount(is.commandPtr);
/*
* Get a new value for tty if anyone writes to ::tcl_interactive
*/
Tcl_LinkVar(interp, "tcl_interactive", &is.tty, TCL_LINK_BOOLEAN);
is.input = Tcl_GetStdChannel(TCL_STDIN);
while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) {
mainLoopProc = TclGetMainLoop();
if (mainLoopProc == NULL) {
int length;
if (is.tty) {
Prompt(interp, &is);
if (Tcl_InterpDeleted(interp)) {
break;
}
if (Tcl_LimitExceeded(interp)) {
break;
}
is.input = Tcl_GetStdChannel(TCL_STDIN);
if (is.input == NULL) {
break;
}
}
if (Tcl_IsShared(is.commandPtr)) {
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_DuplicateObj(is.commandPtr);
Tcl_IncrRefCount(is.commandPtr);
}
length = Tcl_GetsObj(is.input, is.commandPtr);
if (length < 0) {
if (Tcl_InputBlocked(is.input)) {
/*
* This can only happen if stdin has been set to
* non-blocking. In that case cycle back and try again.
* This sets up a tight polling loop (since we have no
* event loop running). If this causes bad CPU hogging, we
* might try toggling the blocking on stdin instead.
|
| ︙ | ︙ | |||
535 536 537 538 539 540 541 | is.prompt = PROMPT_START; /* * The final newline is syntactically redundant, and causes some * error messages troubles deeper in, so lop it back off. */ | | | | 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 |
is.prompt = PROMPT_START;
/*
* The final newline is syntactically redundant, and causes some
* error messages troubles deeper in, so lop it back off.
*/
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);
is.commandPtr = Tcl_NewObj();
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);
}
} else if (is.tty) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultPtr);
TclGetStringFromObj(resultPtr, &length);
chan = Tcl_GetStdChannel(TCL_STDOUT);
if ((length > 0) && chan) {
Tcl_WriteObj(chan, resultPtr);
Tcl_WriteChars(chan, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
}
|
| ︙ | ︙ | |||
638 639 640 641 642 643 644 |
* maybe we've blown up because of an exceeded limit. We still want to
* cleanup and exit.
*/
Tcl_Exit(exitCode);
}
| | | 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 |
* maybe we've blown up because of an exceeded limit. We still want to
* cleanup and exit.
*/
Tcl_Exit(exitCode);
}
#if !defined(_WIN32) || defined(UNICODE)
/*
*---------------------------------------------------------------
*
* Tcl_SetMainLoop --
*
* Sets an alternative main loop function.
|
| ︙ | ︙ | |||
729 730 731 732 733 734 735 |
finalize = ((fin != NULL) && strcmp(fin, "0"));
if (fin != NULL) {
Tcl_DStringFree(&ds);
}
return finalize;
#endif /* PURIFY */
}
| | < | | < | | | 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 |
finalize = ((fin != NULL) && strcmp(fin, "0"));
if (fin != NULL) {
Tcl_DStringFree(&ds);
}
return finalize;
#endif /* PURIFY */
}
#endif /* UNICODE */
/*
*----------------------------------------------------------------------
*
* StdinProc --
*
* This function is invoked by the event dispatcher whenever standard
* input becomes readable. It grabs the next line of input characters,
* adds them to a command being assembled, and executes the command if
* it's complete.
*
* Results:
* None.
*
* Side effects:
* Could be almost arbitrary, depending on the command that's typed.
*
*----------------------------------------------------------------------
*/
static void
StdinProc(
ClientData clientData, /* The state of interactive cmd line */
TCL_UNUSED(int) /*mask*/)
{
int code, length;
InteractiveState *isPtr = (InteractiveState *)clientData;
Tcl_Channel chan = isPtr->input;
Tcl_Obj *commandPtr = isPtr->commandPtr;
Tcl_Interp *interp = isPtr->interp;
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_DuplicateObj(commandPtr);
Tcl_IncrRefCount(commandPtr);
}
length = Tcl_GetsObj(chan, commandPtr);
if (length < 0) {
if (Tcl_InputBlocked(chan)) {
return;
}
if (isPtr->tty) {
/*
* Would be better to find a way to exit the mainLoop? Or perhaps
* evaluate [exit]? Leaving as is for now due to compatibility
|
| ︙ | ︙ | |||
797 798 799 800 801 802 803 |
}
Tcl_AppendToObj(commandPtr, "\n", 1);
if (!TclObjCommandComplete(commandPtr)) {
isPtr->prompt = PROMPT_CONTINUE;
goto prompt;
}
isPtr->prompt = PROMPT_START;
| | | 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 |
}
Tcl_AppendToObj(commandPtr, "\n", 1);
if (!TclObjCommandComplete(commandPtr)) {
isPtr->prompt = PROMPT_CONTINUE;
goto prompt;
}
isPtr->prompt = PROMPT_START;
TclGetStringFromObj(commandPtr, &length);
Tcl_SetObjLength(commandPtr, --length);
/*
* Disable the stdin channel handler while evaluating the command;
* otherwise if the command re-enters the event loop we might process
* commands from stdin before the current command is finished. Among other
* things, this will trash the text of the command being evaluated.
|
| ︙ | ︙ | |||
828 829 830 831 832 833 834 |
Tcl_WriteChars(chan, "\n", 1);
}
} else if (isPtr->tty) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
chan = Tcl_GetStdChannel(TCL_STDOUT);
Tcl_IncrRefCount(resultPtr);
| | | 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 |
Tcl_WriteChars(chan, "\n", 1);
}
} else if (isPtr->tty) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
chan = Tcl_GetStdChannel(TCL_STDOUT);
Tcl_IncrRefCount(resultPtr);
TclGetStringFromObj(resultPtr, &length);
if ((length > 0) && (chan != NULL)) {
Tcl_WriteObj(chan, resultPtr);
Tcl_WriteChars(chan, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
}
|
| ︙ | ︙ | |||
930 931 932 933 934 935 936 |
*----------------------------------------------------------------------
*/
static void
FreeMainInterp(
ClientData clientData)
{
| | | 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 |
*----------------------------------------------------------------------
*/
static void
FreeMainInterp(
ClientData clientData)
{
Tcl_Interp *interp = (Tcl_Interp *)clientData;
/*if (TclInExit()) return;*/
if (!Tcl_InterpDeleted(interp)) {
Tcl_DeleteInterp(interp);
}
Tcl_SetStartupScript(NULL, NULL);
|
| ︙ | ︙ |
Changes to generic/tclNamesp.c.
| ︙ | ︙ | |||
29 30 31 32 33 34 35 |
/*
* Thread-local storage used to avoid having a global lock on data that is not
* limited to a single interpreter.
*/
typedef struct {
| | | | 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 |
/*
* Thread-local storage used to avoid having a global lock on data that is not
* limited to a single interpreter.
*/
typedef struct {
unsigned long numNsCreated; /* Count of the number of namespaces created
* within the thread. This value is used as a
* unique id for each namespace. Cannot be
* per-interp because the nsId is used to
* distinguish objects which can be passed
* around between interps in the same thread,
* but does not need to be global because
* object internal reps are always per-thread
* anyway. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* This structure contains a cached pointer to a namespace that is the result
* of resolving the namespace's name in some other namespace. It is the
* internal representation for a nsName object. It contains the pointer along
* with some information that is used to check the cached pointer's validity.
*/
typedef struct ResolvedNsName {
Namespace *nsPtr; /* A cached pointer to the Namespace that the
* name resolved to. */
Namespace *refNsPtr; /* Points to the namespace context in which
* the name was resolved. NULL if the name is
* fully qualified and thus the resolution
* does not depend on the context. */
size_t refCount; /* Reference count: 1 for each nsName object
|
| ︙ | ︙ | |||
88 89 90 91 92 93 94 | Tcl_Interp *interp, const char *name1, const char *name2, int flags); static void FreeNsNameInternalRep(Tcl_Obj *objPtr); static int GetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); static int InvokeImportedNRCmd(ClientData clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); | | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | < | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 | Tcl_Interp *interp, const char *name1, const char *name2, int flags); static void FreeNsNameInternalRep(Tcl_Obj *objPtr); static int GetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); static int InvokeImportedNRCmd(ClientData clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static Tcl_ObjCmdProc NamespaceChildrenCmd; static Tcl_ObjCmdProc NamespaceCodeCmd; static Tcl_ObjCmdProc NamespaceCurrentCmd; static Tcl_ObjCmdProc NamespaceDeleteCmd; static Tcl_ObjCmdProc NamespaceEvalCmd; static Tcl_ObjCmdProc NRNamespaceEvalCmd; static Tcl_ObjCmdProc NamespaceExistsCmd; static Tcl_ObjCmdProc NamespaceExportCmd; static Tcl_ObjCmdProc NamespaceForgetCmd; static void NamespaceFree(Namespace *nsPtr); static Tcl_ObjCmdProc NamespaceImportCmd; static Tcl_ObjCmdProc NamespaceInscopeCmd; static Tcl_ObjCmdProc NRNamespaceInscopeCmd; static Tcl_ObjCmdProc NamespaceOriginCmd; static Tcl_ObjCmdProc NamespaceParentCmd; static Tcl_ObjCmdProc NamespacePathCmd; static Tcl_ObjCmdProc NamespaceQualifiersCmd; static Tcl_ObjCmdProc NamespaceTailCmd; static Tcl_ObjCmdProc NamespaceUpvarCmd; static Tcl_ObjCmdProc NamespaceUnknownCmd; static Tcl_ObjCmdProc NamespaceWhichCmd; static int SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UnlinkNsPath(Namespace *nsPtr); static Tcl_NRPostProc NsEval_Callback; /* * This structure defines a Tcl object type that contains a namespace |
| ︙ | ︙ | |||
162 163 164 165 166 167 168 |
Tcl_StoreIntRep((objPtr), &nsNameType, &ir); \
} while (0)
#define NsNameGetIntRep(objPtr, nnPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &nsNameType); \
| | | 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 |
Tcl_StoreIntRep((objPtr), &nsNameType, &ir); \
} while (0)
#define NsNameGetIntRep(objPtr, nnPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &nsNameType); \
(nnPtr) = irPtr ? (ResolvedNsName *)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
* Array of values describing how to implement each standard subcommand of the
* "namespace" command.
*/
|
| ︙ | ︙ | |||
236 237 238 239 240 241 242 | * None. * *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_GetCurrentNamespace( | | | 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Namespace *
Tcl_GetCurrentNamespace(
Tcl_Interp *interp)/* Interpreter whose current namespace is
* being queried. */
{
return TclGetCurrentNamespace(interp);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
260 261 262 263 264 265 266 | * None. * *---------------------------------------------------------------------- */ Tcl_Namespace * Tcl_GetGlobalNamespace( | | | 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Namespace *
Tcl_GetGlobalNamespace(
Tcl_Interp *interp)/* Interpreter whose global namespace should
* be returned. */
{
return TclGetGlobalNamespace(interp);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
312 313 314 315 316 317 318 |
* created in the frame. If 0, the frame is
* for a "namespace eval" or "namespace
* inscope" command and var references are
* treated as references to namespace
* variables. */
{
Interp *iPtr = (Interp *) interp;
| | | < | 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 |
* created in the frame. If 0, the frame is
* for a "namespace eval" or "namespace
* inscope" command and var references are
* treated as references to namespace
* variables. */
{
Interp *iPtr = (Interp *) interp;
CallFrame *framePtr = (CallFrame *) callFramePtr;
Namespace *nsPtr;
if (namespacePtr == NULL) {
nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
} else {
nsPtr = (Namespace *) namespacePtr;
/*
* TODO: Examine whether it would be better to guard based on NS_DYING
* or NS_KILLED. It appears that these are not tested because they can
* be set in a global interp that has been [namespace delete]d, but
* which never really completely goes away because of lingering global
* things like ::errorInfo and [::unknown] and hidden commands.
* Review of those designs might permit stricter checking here.
*/
if (nsPtr->flags & NS_DEAD) {
Tcl_Panic("Trying to push call frame for dead namespace");
}
}
nsPtr->activationCount++;
framePtr->nsPtr = nsPtr;
framePtr->isProcCallFrame = isProcCallFrame;
framePtr->objc = 0;
|
| ︙ | ︙ | |||
389 390 391 392 393 394 395 |
*----------------------------------------------------------------------
*/
void
Tcl_PopCallFrame(
Tcl_Interp *interp) /* Interpreter with call frame to pop. */
{
| | | | | | > | 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 |
*----------------------------------------------------------------------
*/
void
Tcl_PopCallFrame(
Tcl_Interp *interp) /* Interpreter with call frame to pop. */
{
Interp *iPtr = (Interp *) interp;
CallFrame *framePtr = iPtr->framePtr;
Namespace *nsPtr;
/*
* It's important to remove the call frame from the interpreter's stack of
* call frames before deleting local variables, so that traces invoked by
* the variable deletion don't see the partially-deleted frame.
*/
if (framePtr->callerPtr) {
iPtr->framePtr = framePtr->callerPtr;
iPtr->varFramePtr = framePtr->callerVarPtr;
} else {
/* Tcl_PopCallFrame: trying to pop rootCallFrame! */
}
if (framePtr->varTablePtr != NULL) {
TclDeleteVars(iPtr, framePtr->varTablePtr);
ckfree(framePtr->varTablePtr);
framePtr->varTablePtr = NULL;
}
if (framePtr->numCompiledLocals > 0) {
TclDeleteCompiledLocalVars(iPtr, framePtr);
if (framePtr->localCachePtr->refCount-- <= 1) {
TclFreeLocalCache(interp, framePtr->localCachePtr);
}
framePtr->localCachePtr = NULL;
}
/*
* Decrement the namespace's count of active call frames. If the namespace
* is "dying" and there are no more active call frames, call
* Tcl_DeleteNamespace to destroy it.
*/
nsPtr = framePtr->nsPtr;
nsPtr->activationCount--;
if ((nsPtr->flags & NS_DYING)
&& (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) {
Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
}
framePtr->nsPtr = NULL;
if (framePtr->tailcallPtr) {
TclSetTailcall(interp, framePtr->tailcallPtr);
}
|
| ︙ | ︙ | |||
475 476 477 478 479 480 481 |
* If new variables are created, they will be
* created in the frame. If 0, the frame is
* for a "namespace eval" or "namespace
* inscope" command and var references are
* treated as references to namespace
* variables. */
{
| | | 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 |
* If new variables are created, they will be
* created in the frame. If 0, the frame is
* for a "namespace eval" or "namespace
* inscope" command and var references are
* treated as references to namespace
* variables. */
{
*framePtrPtr = (Tcl_CallFrame *)TclStackAlloc(interp, sizeof(CallFrame));
return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr,
isProcCallFrame);
}
void
TclPopStackFrame(
Tcl_Interp *interp) /* Interpreter with call frame to pop. */
|
| ︙ | ︙ | |||
509 510 511 512 513 514 515 | * Read and unset traces are established on ::errorCode. * *---------------------------------------------------------------------- */ static char * EstablishErrorCodeTraces( | | | | | | 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 |
* Read and unset traces are established on ::errorCode.
*
*----------------------------------------------------------------------
*/
static char *
EstablishErrorCodeTraces(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
TCL_UNUSED(const char *) /*name1*/,
TCL_UNUSED(const char *) /*name2*/,
TCL_UNUSED(int) /*flags*/)
{
Tcl_TraceVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS,
ErrorCodeRead, NULL);
Tcl_TraceVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_UNSETS,
EstablishErrorCodeTraces, NULL);
return NULL;
}
|
| ︙ | ︙ | |||
541 542 543 544 545 546 547 | * None. * *---------------------------------------------------------------------- */ static char * ErrorCodeRead( | | | | | | 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 |
* None.
*
*----------------------------------------------------------------------
*/
static char *
ErrorCodeRead(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
TCL_UNUSED(const char *) /*name1*/,
TCL_UNUSED(const char *) /*name2*/,
TCL_UNUSED(int) /*flags*/)
{
Interp *iPtr = (Interp *) interp;
if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) {
return NULL;
}
if (iPtr->errorCode) {
|
| ︙ | ︙ | |||
583 584 585 586 587 588 589 | * Read and unset traces are established on ::errorInfo. * *---------------------------------------------------------------------- */ static char * EstablishErrorInfoTraces( | | | | | | 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 |
* Read and unset traces are established on ::errorInfo.
*
*----------------------------------------------------------------------
*/
static char *
EstablishErrorInfoTraces(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
TCL_UNUSED(const char *) /*name1*/,
TCL_UNUSED(const char *) /*name2*/,
TCL_UNUSED(int) /*flags*/)
{
Tcl_TraceVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS,
ErrorInfoRead, NULL);
Tcl_TraceVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_UNSETS,
EstablishErrorInfoTraces, NULL);
return NULL;
}
|
| ︙ | ︙ | |||
615 616 617 618 619 620 621 | * None. * *---------------------------------------------------------------------- */ static char * ErrorInfoRead( | | | | | | 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 |
* None.
*
*----------------------------------------------------------------------
*/
static char *
ErrorInfoRead(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
TCL_UNUSED(const char *) /*name1*/,
TCL_UNUSED(const char *) /*name2*/,
TCL_UNUSED(int) /*flags*/)
{
Interp *iPtr = (Interp *) interp;
if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) {
return NULL;
}
if (iPtr->errorInfo) {
|
| ︙ | ︙ | |||
674 675 676 677 678 679 680 |
ClientData clientData, /* One-word value to store with namespace. */
Tcl_NamespaceDeleteProc *deleteProc)
/* Function called to delete client data when
* the namespace is deleted. NULL if no
* function should be called. */
{
Interp *iPtr = (Interp *) interp;
| | | < | 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 |
ClientData clientData, /* One-word value to store with namespace. */
Tcl_NamespaceDeleteProc *deleteProc)
/* Function called to delete client data when
* the namespace is deleted. NULL if no
* function should be called. */
{
Interp *iPtr = (Interp *) interp;
Namespace *nsPtr, *ancestorPtr;
Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr;
Namespace *globalNsPtr = iPtr->globalNsPtr;
const char *simpleName;
Tcl_HashEntry *entryPtr;
Tcl_DString buffer1, buffer2;
Tcl_DString *namePtr, *buffPtr;
int newEntry, nameLen;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
const char *nameStr;
Tcl_DString tmpBuffer;
Tcl_DStringInit(&tmpBuffer);
/*
|
| ︙ | ︙ | |||
781 782 783 784 785 786 787 |
/*
* Create the new namespace and root it in its parent. Increment the count
* of namespaces created.
*/
doCreate:
| | | | 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 |
/*
* Create the new namespace and root it in its parent. Increment the count
* of namespaces created.
*/
doCreate:
nsPtr = (Namespace *)ckalloc(sizeof(Namespace));
nameLen = strlen(simpleName) + 1;
nsPtr->name = (char *)ckalloc(nameLen);
memcpy(nsPtr->name, simpleName, nameLen);
nsPtr->fullName = NULL; /* Set below. */
nsPtr->clientData = clientData;
nsPtr->deleteProc = deleteProc;
nsPtr->parentPtr = parentPtr;
#ifndef BREAK_NAMESPACE_COMPAT
Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS);
|
| ︙ | ︙ | |||
844 845 846 847 848 849 850 |
Tcl_DStringInit(&buffer1);
Tcl_DStringInit(&buffer2);
namePtr = &buffer1;
buffPtr = &buffer2;
for (ancestorPtr = nsPtr; ancestorPtr != NULL;
ancestorPtr = ancestorPtr->parentPtr) {
if (ancestorPtr != globalNsPtr) {
| | | 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 |
Tcl_DStringInit(&buffer1);
Tcl_DStringInit(&buffer2);
namePtr = &buffer1;
buffPtr = &buffer2;
for (ancestorPtr = nsPtr; ancestorPtr != NULL;
ancestorPtr = ancestorPtr->parentPtr) {
if (ancestorPtr != globalNsPtr) {
Tcl_DString *tempPtr = namePtr;
TclDStringAppendLiteral(buffPtr, "::");
Tcl_DStringAppend(buffPtr, ancestorPtr->name, -1);
TclDStringAppendDString(buffPtr, namePtr);
/*
* Clear the unwanted buffer or we end up appending to previous
|
| ︙ | ︙ | |||
871 872 873 874 875 876 877 |
namePtr = buffPtr;
buffPtr = tempPtr;
}
}
name = Tcl_DStringValue(namePtr);
nameLen = Tcl_DStringLength(namePtr);
| | | 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 |
namePtr = buffPtr;
buffPtr = tempPtr;
}
}
name = Tcl_DStringValue(namePtr);
nameLen = Tcl_DStringLength(namePtr);
nsPtr->fullName = (char *)ckalloc(nameLen + 1);
memcpy(nsPtr->fullName, name, nameLen + 1);
Tcl_DStringFree(&buffer1);
Tcl_DStringFree(&buffer2);
Tcl_DStringFree(&tmpBuffer);
/*
|
| ︙ | ︙ | |||
918 919 920 921 922 923 924 |
*----------------------------------------------------------------------
*/
void
Tcl_DeleteNamespace(
Tcl_Namespace *namespacePtr)/* Points to the namespace to delete. */
{
| | | 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 |
*----------------------------------------------------------------------
*/
void
Tcl_DeleteNamespace(
Tcl_Namespace *namespacePtr)/* Points to the namespace to delete. */
{
Namespace *nsPtr = (Namespace *) namespacePtr;
Interp *iPtr = (Interp *) nsPtr->interp;
Namespace *globalNsPtr = (Namespace *)
TclGetGlobalNamespace((Tcl_Interp *) iPtr);
Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Command *cmdPtr;
|
| ︙ | ︙ | |||
963 964 965 966 967 968 969 |
*
* NOTE: we could avoid traversing the ns's command list by keeping a
* separate list of coros.
*/
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
entryPtr != NULL;) {
| | | 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 |
*
* NOTE: we could avoid traversing the ns's command list by keeping a
* separate list of coros.
*/
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
entryPtr != NULL;) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
if (cmdPtr->nreProc == TclNRInterpCoroutine) {
Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr,
(Tcl_Command) cmdPtr);
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
} else {
entryPtr = Tcl_NextHashEntry(&search);
}
|
| ︙ | ︙ | |||
1019 1020 1021 1022 1023 1024 1025 |
* namespace's commands and variables are deleted but the structure isn't
* freed. Instead, NS_DEAD is OR'd into the structure's flags to allow the
* namespace resolution code to recognize that the namespace is "deleted".
* The structure's storage is freed by FreeNsNameInternalRep when its
* refCount reaches 0.
*/
| | | 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 |
* namespace's commands and variables are deleted but the structure isn't
* freed. Instead, NS_DEAD is OR'd into the structure's flags to allow the
* namespace resolution code to recognize that the namespace is "deleted".
* The structure's storage is freed by FreeNsNameInternalRep when its
* refCount reaches 0.
*/
if (nsPtr->activationCount - (nsPtr == globalNsPtr) > 0) {
nsPtr->flags |= NS_DYING;
if (nsPtr->parentPtr != NULL) {
entryPtr = Tcl_FindHashEntry(
TclGetNamespaceChildTable((Tcl_Namespace *)
nsPtr->parentPtr), nsPtr->name);
if (entryPtr != NULL) {
Tcl_DeleteHashEntry(entryPtr);
|
| ︙ | ︙ | |||
1058 1059 1060 1061 1062 1063 1064 |
TclDeleteNamespaceVars(nsPtr);
#ifndef BREAK_NAMESPACE_COMPAT
Tcl_DeleteHashTable(&nsPtr->childTable);
#else
if (nsPtr->childTablePtr != NULL) {
Tcl_DeleteHashTable(nsPtr->childTablePtr);
| | | 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 |
TclDeleteNamespaceVars(nsPtr);
#ifndef BREAK_NAMESPACE_COMPAT
Tcl_DeleteHashTable(&nsPtr->childTable);
#else
if (nsPtr->childTablePtr != NULL) {
Tcl_DeleteHashTable(nsPtr->childTablePtr);
ckfree(nsPtr->childTablePtr);
}
#endif
Tcl_DeleteHashTable(&nsPtr->cmdTable);
nsPtr ->flags |= NS_DEAD;
} else {
/*
|
| ︙ | ︙ | |||
1114 1115 1116 1117 1118 1119 1120 | * Deletes all commands, variables and namespaces in this namespace. * *---------------------------------------------------------------------- */ void TclTeardownNamespace( | | | | | | | | 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 |
* Deletes all commands, variables and namespaces in this namespace.
*
*----------------------------------------------------------------------
*/
void
TclTeardownNamespace(
Namespace *nsPtr) /* Points to the namespace to be dismantled
* and unlinked from its parent. */
{
Interp *iPtr = (Interp *) nsPtr->interp;
Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
int i;
/*
* Start by destroying the namespace's variable table, since variables
* might trigger traces. Variable table should be cleared but not freed!
* TclDeleteNamespaceVars frees it, so we reinitialize it afterwards.
*/
TclDeleteNamespaceVars(nsPtr);
TclInitVarHashTable(&nsPtr->varTable, nsPtr);
/*
* Delete all commands in this namespace. Be careful when traversing the
* hash table: when each command is deleted, it removes itself from the
* command table. Because of traces (and the desire to avoid the quadratic
* problems of just using Tcl_FirstHashEntry over and over, [Bug
* f97d4ee020]) we copy to a temporary array and then delete all those
* commands.
*/
while (nsPtr->cmdTable.numEntries > 0) {
int length = nsPtr->cmdTable.numEntries;
Command **cmds = (Command **)TclStackAlloc((Tcl_Interp *) iPtr,
sizeof(Command *) * length);
i = 0;
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
cmds[i] = (Command *)Tcl_GetHashValue(entryPtr);
cmds[i]->refCount++;
i++;
}
for (i = 0 ; i < length ; i++) {
Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr,
(Tcl_Command) cmds[i]);
TclCleanupCommandMacro(cmds[i]);
|
| ︙ | ︙ | |||
1213 1214 1215 1216 1217 1218 1219 |
* namespaces.
*
* Important: leave the hash table itself still live.
*/
#ifndef BREAK_NAMESPACE_COMPAT
while (nsPtr->childTable.numEntries > 0) {
| | | | | | | 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 |
* namespaces.
*
* Important: leave the hash table itself still live.
*/
#ifndef BREAK_NAMESPACE_COMPAT
while (nsPtr->childTable.numEntries > 0) {
int length = nsPtr->childTable.numEntries;
Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr,
sizeof(Namespace *) * length);
i = 0;
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
children[i] = (Namespace *)Tcl_GetHashValue(entryPtr);
children[i]->refCount++;
i++;
}
for (i = 0 ; i < length ; i++) {
Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
TclNsDecrRefCount(children[i]);
}
TclStackFree((Tcl_Interp *) iPtr, children);
}
#else
if (nsPtr->childTablePtr != NULL) {
while (nsPtr->childTablePtr->numEntries > 0) {
int length = nsPtr->childTablePtr->numEntries;
Namespace **children = (Namespace **)TclStackAlloc((Tcl_Interp *) iPtr,
sizeof(Namespace *) * length);
i = 0;
for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
entryPtr != NULL;
entryPtr = Tcl_NextHashEntry(&search)) {
children[i] = Tcl_GetHashValue(entryPtr);
|
| ︙ | ︙ | |||
1261 1262 1263 1264 1265 1266 1267 |
/*
* Free the namespace's export pattern array.
*/
if (nsPtr->exportArrayPtr != NULL) {
for (i = 0; i < nsPtr->numExportPatterns; i++) {
| | | | 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 |
/*
* Free the namespace's export pattern array.
*/
if (nsPtr->exportArrayPtr != NULL) {
for (i = 0; i < nsPtr->numExportPatterns; i++) {
ckfree(nsPtr->exportArrayPtr[i]);
}
ckfree(nsPtr->exportArrayPtr);
nsPtr->exportArrayPtr = NULL;
nsPtr->numExportPatterns = 0;
nsPtr->maxExportPatterns = 0;
}
/*
* Free any client data associated with the namespace.
|
| ︙ | ︙ | |||
1307 1308 1309 1310 1311 1312 1313 | * None. * *---------------------------------------------------------------------- */ static void NamespaceFree( | | | | | | 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 |
* None.
*
*----------------------------------------------------------------------
*/
static void
NamespaceFree(
Namespace *nsPtr) /* Points to the namespace to free. */
{
/*
* Most of the namespace's contents are freed when the namespace is
* deleted by Tcl_DeleteNamespace. All that remains is to free its names
* (for error messages), and the structure itself.
*/
ckfree(nsPtr->name);
ckfree(nsPtr->fullName);
ckfree(nsPtr);
}
/*
*----------------------------------------------------------------------
*
* TclNsDecrRefCount --
*
|
| ︙ | ︙ | |||
1386 1387 1388 1389 1390 1391 1392 |
* list before appending. */
{
#define INIT_EXPORT_PATTERNS 5
Namespace *nsPtr, *exportNsPtr, *dummyPtr;
Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
const char *simplePattern;
char *patternCpy;
| | | | | 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 |
* list before appending. */
{
#define INIT_EXPORT_PATTERNS 5
Namespace *nsPtr, *exportNsPtr, *dummyPtr;
Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
const char *simplePattern;
char *patternCpy;
int neededElems, len, i;
/*
* If the specified namespace is NULL, use the current namespace.
*/
if (namespacePtr == NULL) {
nsPtr = (Namespace *) currNsPtr;
} else {
nsPtr = (Namespace *) namespacePtr;
}
/*
* If resetListFirst is true (nonzero), clear the namespace's export
* pattern list.
*/
if (resetListFirst) {
if (nsPtr->exportArrayPtr != NULL) {
for (i = 0; i < nsPtr->numExportPatterns; i++) {
ckfree(nsPtr->exportArrayPtr[i]);
}
ckfree(nsPtr->exportArrayPtr);
nsPtr->exportArrayPtr = NULL;
TclInvalidateNsCmdLookup(nsPtr);
nsPtr->numExportPatterns = 0;
nsPtr->maxExportPatterns = 0;
}
}
|
| ︙ | ︙ | |||
1455 1456 1457 1458 1459 1460 1461 |
* pattern.
*/
neededElems = nsPtr->numExportPatterns + 1;
if (neededElems > nsPtr->maxExportPatterns) {
nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ?
2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS;
| | | | 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 |
* pattern.
*/
neededElems = nsPtr->numExportPatterns + 1;
if (neededElems > nsPtr->maxExportPatterns) {
nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ?
2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS;
nsPtr->exportArrayPtr = (char **)ckrealloc(nsPtr->exportArrayPtr,
sizeof(char *) * nsPtr->maxExportPatterns);
}
/*
* Add the pattern to the namespace's array of export patterns.
*/
len = strlen(pattern);
patternCpy = (char *)ckalloc(len + 1);
memcpy(patternCpy, pattern, len + 1);
nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy;
nsPtr->numExportPatterns++;
/*
* The list of commands actually exported from the namespace might have
|
| ︙ | ︙ | |||
1513 1514 1515 1516 1517 1518 1519 |
Tcl_Namespace *namespacePtr,/* Points to the namespace whose export
* pattern list is appended onto objPtr. NULL
* for the current namespace. */
Tcl_Obj *objPtr) /* Points to the Tcl object onto which the
* export pattern list is appended. */
{
Namespace *nsPtr;
| < | | 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 |
Tcl_Namespace *namespacePtr,/* Points to the namespace whose export
* pattern list is appended onto objPtr. NULL
* for the current namespace. */
Tcl_Obj *objPtr) /* Points to the Tcl object onto which the
* export pattern list is appended. */
{
Namespace *nsPtr;
int i, result;
/*
* If the specified namespace is NULL, use the current namespace.
*/
if (namespacePtr == NULL) {
nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
|
| ︙ | ︙ | |||
1583 1584 1585 1586 1587 1588 1589 |
int allowOverwrite) /* If nonzero, allow existing commands to be
* overwritten by imported commands. If 0,
* return an error if an imported cmd
* conflicts with an existing one. */
{
Namespace *nsPtr, *importNsPtr, *dummyPtr;
const char *simplePattern;
| | | 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 |
int allowOverwrite) /* If nonzero, allow existing commands to be
* overwritten by imported commands. If 0,
* return an error if an imported cmd
* conflicts with an existing one. */
{
Namespace *nsPtr, *importNsPtr, *dummyPtr;
const char *simplePattern;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
/*
* If the specified namespace is NULL, use the current namespace.
*/
if (namespacePtr == NULL) {
|
| ︙ | ︙ | |||
1676 1677 1678 1679 1680 1681 1682 |
return TCL_OK;
}
return DoImport(interp, nsPtr, hPtr, simplePattern, pattern,
importNsPtr, allowOverwrite);
}
for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search);
(hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) {
| | | 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 |
return TCL_OK;
}
return DoImport(interp, nsPtr, hPtr, simplePattern, pattern,
importNsPtr, allowOverwrite);
}
for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search);
(hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) {
char *cmdName = (char *)Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr);
if (Tcl_StringMatch(cmdName, simplePattern) &&
DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr,
allowOverwrite) == TCL_ERROR) {
return TCL_ERROR;
}
}
|
| ︙ | ︙ | |||
1716 1717 1718 1719 1720 1721 1722 |
Namespace *nsPtr,
Tcl_HashEntry *hPtr,
const char *cmdName,
const char *pattern,
Namespace *importNsPtr,
int allowOverwrite)
{
| | | 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 |
Namespace *nsPtr,
Tcl_HashEntry *hPtr,
const char *cmdName,
const char *pattern,
Namespace *importNsPtr,
int allowOverwrite)
{
int i = 0, exported = 0;
Tcl_HashEntry *found;
/*
* The command cmdName in the source namespace matches the pattern. Check
* whether it was exported. If it wasn't, we ignore it.
*/
|
| ︙ | ︙ | |||
1763 1764 1765 1766 1767 1768 1769 | Tcl_DStringAppend(&ds, cmdName, -1); /* * Check whether creating the new imported command in the current * namespace would create a cycle of imported command references. */ | | | | | | | | | 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 |
Tcl_DStringAppend(&ds, cmdName, -1);
/*
* Check whether creating the new imported command in the current
* namespace would create a cycle of imported command references.
*/
cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) {
Command *overwrite = (Command *)Tcl_GetHashValue(found);
Command *linkCmd = cmdPtr;
while (linkCmd->deleteProc == DeleteImportedCmd) {
dataPtr = (ImportedCmdData *)linkCmd->objClientData;
linkCmd = dataPtr->realCmdPtr;
if (overwrite == linkCmd) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"import pattern \"%s\" would create a loop"
" containing command \"%s\"",
pattern, Tcl_DStringValue(&ds)));
Tcl_DStringFree(&ds);
Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL);
return TCL_ERROR;
}
}
}
dataPtr = (ImportedCmdData *)ckalloc(sizeof(ImportedCmdData));
importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
TclInvokeImportedCmd, InvokeImportedNRCmd, dataPtr,
DeleteImportedCmd);
dataPtr->realCmdPtr = cmdPtr;
dataPtr->selfPtr = (Command *) importedCmd;
dataPtr->selfPtr->compileProc = cmdPtr->compileProc;
Tcl_DStringFree(&ds);
/*
* Create an ImportRef structure describing this new import command
* and add it to the import ref list in the "real" command.
*/
refPtr = (ImportRef *)ckalloc(sizeof(ImportRef));
refPtr->importedCmdPtr = (Command *) importedCmd;
refPtr->nextPtr = cmdPtr->importRefPtr;
cmdPtr->importRefPtr = refPtr;
} else {
Command *overwrite = (Command *)Tcl_GetHashValue(found);
if (overwrite->deleteProc == DeleteImportedCmd) {
ImportedCmdData *dataPtr = (ImportedCmdData *)overwrite->objClientData;
if (dataPtr->realCmdPtr == Tcl_GetHashValue(hPtr)) {
/*
* Repeated import of same command is acceptable.
*/
return TCL_OK;
|
| ︙ | ︙ | |||
1862 1863 1864 1865 1866 1867 1868 |
* removed. NULL for current namespace. */
const char *pattern) /* String pattern indicating which imported
* commands to remove. */
{
Namespace *nsPtr, *sourceNsPtr, *dummyPtr;
const char *simplePattern;
char *cmdName;
| | | 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 |
* removed. NULL for current namespace. */
const char *pattern) /* String pattern indicating which imported
* commands to remove. */
{
Namespace *nsPtr, *sourceNsPtr, *dummyPtr;
const char *simplePattern;
char *cmdName;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
/*
* If the specified namespace is NULL, use the current namespace.
*/
if (namespacePtr == NULL) {
|
| ︙ | ︙ | |||
1899 1900 1901 1902 1903 1904 1905 |
/*
* The pattern is simple. Delete any imported commands that match it.
*/
if (TclMatchIsTrivial(simplePattern)) {
hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (hPtr != NULL) {
| | | | | | | 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 |
/*
* The pattern is simple. Delete any imported commands that match it.
*/
if (TclMatchIsTrivial(simplePattern)) {
hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if (hPtr != NULL) {
Command *cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
if (cmdPtr && (cmdPtr->deleteProc == DeleteImportedCmd)) {
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
}
}
return TCL_OK;
}
for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
(hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) {
Command *cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
if (cmdPtr->deleteProc != DeleteImportedCmd) {
continue;
}
cmdName = (char *)Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
if (Tcl_StringMatch(cmdName, simplePattern)) {
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
}
}
return TCL_OK;
}
/*
* The pattern was namespace-qualified.
*/
for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL);
hPtr = Tcl_NextHashEntry(&search)) {
Tcl_CmdInfo info;
Tcl_Command token = (Tcl_Command)Tcl_GetHashValue(hPtr);
Tcl_Command origin = TclGetOriginalCommand(token);
if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) {
continue; /* Not an imported command. */
}
if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
/*
* Original not in namespace we're matching. Check the first link
* in the import chain.
*/
Command *cmdPtr = (Command *) token;
ImportedCmdData *dataPtr = (ImportedCmdData *)cmdPtr->objClientData;
Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr;
if (firstToken == origin) {
continue;
}
Tcl_GetCommandInfoFromToken(firstToken, &info);
if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
|
| ︙ | ︙ | |||
1989 1990 1991 1992 1993 1994 1995 |
*/
Tcl_Command
TclGetOriginalCommand(
Tcl_Command command) /* The imported command for which the original
* command should be returned. */
{
| | | | 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 |
*/
Tcl_Command
TclGetOriginalCommand(
Tcl_Command command) /* The imported command for which the original
* command should be returned. */
{
Command *cmdPtr = (Command *) command;
ImportedCmdData *dataPtr;
if (cmdPtr->deleteProc != DeleteImportedCmd) {
return NULL;
}
while (cmdPtr->deleteProc == DeleteImportedCmd) {
dataPtr = (ImportedCmdData *)cmdPtr->objClientData;
cmdPtr = dataPtr->realCmdPtr;
}
return (Tcl_Command) cmdPtr;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2030 2031 2032 2033 2034 2035 2036 |
InvokeImportedNRCmd(
ClientData clientData, /* Points to the imported command's
* ImportedCmdData structure. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
| | | 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 |
InvokeImportedNRCmd(
ClientData clientData, /* Points to the imported command's
* ImportedCmdData structure. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
ImportedCmdData *dataPtr = (ImportedCmdData *)clientData;
Command *realCmdPtr = dataPtr->realCmdPtr;
TclSkipTailcall(interp);
return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr);
}
int
|
| ︙ | ︙ | |||
2075 2076 2077 2078 2079 2080 2081 |
*/
static void
DeleteImportedCmd(
ClientData clientData) /* Points to the imported command's
* ImportedCmdData structure. */
{
| | | | | | 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 |
*/
static void
DeleteImportedCmd(
ClientData clientData) /* Points to the imported command's
* ImportedCmdData structure. */
{
ImportedCmdData *dataPtr = (ImportedCmdData *)clientData;
Command *realCmdPtr = dataPtr->realCmdPtr;
Command *selfPtr = dataPtr->selfPtr;
ImportRef *refPtr, *prevPtr;
prevPtr = NULL;
for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL;
refPtr = refPtr->nextPtr) {
if (refPtr->importedCmdPtr == selfPtr) {
/*
* Remove *refPtr from real command's list of imported commands
* that refer to it.
*/
if (prevPtr == NULL) { /* refPtr is first in list. */
realCmdPtr->importRefPtr = refPtr->nextPtr;
} else {
prevPtr->nextPtr = refPtr->nextPtr;
}
ckfree(refPtr);
ckfree(dataPtr);
return;
}
prevPtr = refPtr;
}
Tcl_Panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references");
}
|
| ︙ | ︙ | |||
2351 2352 2353 2354 2355 2356 2357 |
if (nsPtr->childTablePtr == NULL) {
entryPtr = NULL;
} else {
entryPtr = Tcl_FindHashEntry(nsPtr->childTablePtr, nsName);
}
#endif
if (entryPtr != NULL) {
| | | 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 |
if (nsPtr->childTablePtr == NULL) {
entryPtr = NULL;
} else {
entryPtr = Tcl_FindHashEntry(nsPtr->childTablePtr, nsName);
}
#endif
if (entryPtr != NULL) {
nsPtr = (Namespace *)Tcl_GetHashValue(entryPtr);
} else if (flags & TCL_CREATE_NS_IF_UNKNOWN) {
Tcl_CallFrame *framePtr;
(void) TclPushStackFrame(interp, &framePtr,
(Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0);
nsPtr = (Namespace *)
|
| ︙ | ︙ | |||
2386 2387 2388 2389 2390 2391 2392 |
if (altNsPtr->childTablePtr != NULL) {
entryPtr = Tcl_FindHashEntry(altNsPtr->childTablePtr, nsName);
} else {
entryPtr = NULL;
}
#endif
if (entryPtr != NULL) {
| | | 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 |
if (altNsPtr->childTablePtr != NULL) {
entryPtr = Tcl_FindHashEntry(altNsPtr->childTablePtr, nsName);
} else {
entryPtr = NULL;
}
#endif
if (entryPtr != NULL) {
altNsPtr = (Namespace *)Tcl_GetHashValue(entryPtr);
} else {
altNsPtr = NULL;
}
}
/*
* If both search paths have failed, return NULL results.
|
| ︙ | ︙ | |||
2498 2499 2500 2501 2502 2503 2504 |
* (current namespace if contextNsPtr is
* NULL), then in global namespace. */
Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag is set or
* if the name starts with "::". Otherwise,
* points to namespace in which to resolve
* name; if NULL, look up name in the current
* namespace. */
| | | 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 |
* (current namespace if contextNsPtr is
* NULL), then in global namespace. */
Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag is set or
* if the name starts with "::". Otherwise,
* points to namespace in which to resolve
* name; if NULL, look up name in the current
* namespace. */
int flags) /* Flags controlling namespace lookup: an OR'd
* combination of TCL_GLOBAL_ONLY and
* TCL_LEAVE_ERR_MSG flags. */
{
Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
const char *dummy;
/*
|
| ︙ | ︙ | |||
2569 2570 2571 2572 2573 2574 2575 |
* namespace if contextNsPtr is NULL), and
* TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY
* and TCL_NAMESPACE_ONLY are given,
* TCL_GLOBAL_ONLY is ignored. */
{
Interp *iPtr = (Interp *) interp;
Namespace *cxtNsPtr;
| | | | 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 |
* namespace if contextNsPtr is NULL), and
* TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY
* and TCL_NAMESPACE_ONLY are given,
* TCL_GLOBAL_ONLY is ignored. */
{
Interp *iPtr = (Interp *) interp;
Namespace *cxtNsPtr;
Tcl_HashEntry *entryPtr;
Command *cmdPtr;
const char *simpleName;
int result;
/*
* If this namespace has a command resolver, then give it first crack at
* the command resolution. If the interpreter has any command resolvers,
* consult them next. The command resolver functions may return a
|
| ︙ | ︙ | |||
2625 2626 2627 2628 2629 2630 2631 |
/*
* Find the namespace(s) that contain the command.
*/
cmdPtr = NULL;
if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2)
&& !(flags & TCL_NAMESPACE_ONLY)) {
| | | | | | | | 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 |
/*
* Find the namespace(s) that contain the command.
*/
cmdPtr = NULL;
if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2)
&& !(flags & TCL_NAMESPACE_ONLY)) {
int i;
Namespace *pathNsPtr, *realNsPtr, *dummyNsPtr;
(void) TclGetNamespaceForQualName(interp, name, cxtNsPtr,
TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
&simpleName);
if ((realNsPtr != NULL) && (simpleName != NULL)) {
if ((cxtNsPtr == realNsPtr)
|| !(realNsPtr->flags & NS_DYING)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
}
}
}
/*
* Next, check along the path.
*/
for (i=0 ; i<cxtNsPtr->commandPathLength && cmdPtr==NULL ; i++) {
pathNsPtr = cxtNsPtr->commandPathArray[i].nsPtr;
if (pathNsPtr == NULL) {
continue;
}
(void) TclGetNamespaceForQualName(interp, name, pathNsPtr,
TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
&simpleName);
if ((realNsPtr != NULL) && (simpleName != NULL)
&& !(realNsPtr->flags & NS_DYING)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
}
}
}
/*
* If we've still not found the command, look in the global namespace
* as a last resort.
*/
if (cmdPtr == NULL) {
(void) TclGetNamespaceForQualName(interp, name, NULL,
TCL_GLOBAL_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
&simpleName);
if ((realNsPtr != NULL) && (simpleName != NULL)
&& !(realNsPtr->flags & NS_DYING)) {
entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
}
}
}
} else {
Namespace *nsPtr[2];
int search;
TclGetNamespaceForQualName(interp, name, cxtNsPtr,
flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
/*
* Look for the command in the command table of its namespace. Be sure
* to check both possible search paths: from the specified namespace
* context and from the global namespace.
*/
for (search = 0; (search < 2) && (cmdPtr == NULL); search++) {
if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable,
simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *)Tcl_GetHashValue(entryPtr);
}
}
}
}
if (cmdPtr != NULL) {
cmdPtr->flags &= ~CMD_VIA_RESOLVER;
|
| ︙ | ︙ | |||
2755 2756 2757 2758 2759 2760 2761 |
void
TclResetShadowedCmdRefs(
Tcl_Interp *interp, /* Interpreter containing the new command. */
Command *newCmdPtr) /* Points to the new command. */
{
char *cmdName;
Tcl_HashEntry *hPtr;
| | | | | 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 |
void
TclResetShadowedCmdRefs(
Tcl_Interp *interp, /* Interpreter containing the new command. */
Command *newCmdPtr) /* Points to the new command. */
{
char *cmdName;
Tcl_HashEntry *hPtr;
Namespace *nsPtr;
Namespace *trailNsPtr, *shadowNsPtr;
Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
int found, i;
int trailFront = -1;
int trailSize = 5; /* Formerly NUM_TRAIL_ELEMS. */
Namespace **trailPtr = (Namespace **)TclStackAlloc(interp,
trailSize * sizeof(Namespace *));
/*
* Start at the namespace containing the new command, and work up through
* the list of parents. Stop just before the global namespace, since the
* global namespace can't "shadow" its own entries.
*
* The namespace "trail" list we build consists of the names of each
* namespace that encloses the new command, in order from outermost to
* innermost: for example, "a" then "b". Each iteration of this loop
* eventually extends the trail upwards by one namespace, nsPtr. We use
* this trail list to see if nsPtr (e.g. "a" in 2. above) could have
* now-invalid cached command references. This will happen if nsPtr
* (e.g. "a") contains a sequence of child namespaces (e.g. "b") such that
* there is a identically-named sequence of child namespaces starting from
* :: (e.g. "::b") whose tail namespace contains a command also named
* cmdName.
*/
cmdName = (char *)Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr);
for (nsPtr=newCmdPtr->nsPtr ; (nsPtr!=NULL) && (nsPtr!=globalNsPtr) ;
nsPtr=nsPtr->parentPtr) {
/*
* Find the maximal sequence of child namespaces contained in nsPtr
* such that there is a identically-named sequence of child namespaces
* starting from ::. shadowNsPtr will be the tail of this sequence, or
* the deepest namespace under :: that might contain a command now
|
| ︙ | ︙ | |||
2810 2811 2812 2813 2814 2815 2816 |
hPtr = Tcl_FindHashEntry(shadowNsPtr->childTablePtr,
trailNsPtr->name);
} else {
hPtr = NULL;
}
#endif
if (hPtr != NULL) {
| | | 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 |
hPtr = Tcl_FindHashEntry(shadowNsPtr->childTablePtr,
trailNsPtr->name);
} else {
hPtr = NULL;
}
#endif
if (hPtr != NULL) {
shadowNsPtr = (Namespace *)Tcl_GetHashValue(hPtr);
} else {
found = 0;
break;
}
}
/*
|
| ︙ | ︙ | |||
2851 2852 2853 2854 2855 2856 2857 |
* the trailPtr array.
*/
trailFront++;
if (trailFront == trailSize) {
int newSize = 2 * trailSize;
| | | 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 |
* the trailPtr array.
*/
trailFront++;
if (trailFront == trailSize) {
int newSize = 2 * trailSize;
trailPtr = (Namespace **)TclStackRealloc(interp, trailPtr,
newSize * sizeof(Namespace *));
trailSize = newSize;
}
trailPtr[trailFront] = nsPtr;
}
TclStackFree(interp, trailPtr);
}
|
| ︙ | ︙ | |||
2995 2996 2997 2998 2999 3000 3001 | * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceChildrenCmd( | | | | 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 |
* wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceChildrenCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Namespace *namespacePtr;
Namespace *nsPtr, *childNsPtr;
Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
const char *pattern = NULL;
Tcl_DString buffer;
Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Tcl_Obj *listPtr, *elemPtr;
/*
* Get a pointer to the specified namespace, or the current namespace.
*/
|
| ︙ | ︙ | |||
3052 3053 3054 3055 3056 3057 3058 |
/*
* Create a list containing the full names of all child namespaces whose
* names match the specified pattern, if any.
*/
listPtr = Tcl_NewListObj(0, NULL);
if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
| | | 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 |
/*
* Create a list containing the full names of all child namespaces whose
* names match the specified pattern, if any.
*/
listPtr = Tcl_NewListObj(0, NULL);
if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
unsigned int length = strlen(nsPtr->fullName);
if (strncmp(pattern, nsPtr->fullName, length) != 0) {
goto searchDone;
}
if (
#ifndef BREAK_NAMESPACE_COMPAT
Tcl_FindHashEntry(&nsPtr->childTable, pattern+length) != NULL
|
| ︙ | ︙ | |||
3079 3080 3081 3082 3083 3084 3085 |
#else
if (nsPtr->childTablePtr == NULL) {
goto searchDone;
}
entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
#endif
while (entryPtr != NULL) {
| | | 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 |
#else
if (nsPtr->childTablePtr == NULL) {
goto searchDone;
}
entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
#endif
while (entryPtr != NULL) {
childNsPtr = (Namespace *)Tcl_GetHashValue(entryPtr);
if ((pattern == NULL)
|| Tcl_StringMatch(childNsPtr->fullName, pattern)) {
elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1);
Tcl_ListObjAppendElement(interp, listPtr, elemPtr);
}
entryPtr = Tcl_NextHashEntry(&search);
}
|
| ︙ | ︙ | |||
3124 3125 3126 3127 3128 3129 3130 | * result in the interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceCodeCmd( | | | | | 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 |
* result in the interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceCodeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Namespace *currNsPtr;
Tcl_Obj *listPtr, *objPtr;
const char *arg;
int length;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "arg");
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
3205 3206 3207 3208 3209 3210 3211 | * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceCurrentCmd( | | | | 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 |
* wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceCurrentCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Namespace *currNsPtr;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, NULL);
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
3268 3269 3270 3271 3272 3273 3274 | * function returns an error message in the interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceDeleteCmd( | | | | 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 |
* function returns an error message in the interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceDeleteCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Namespace *namespacePtr;
const char *name;
int i;
if (objc < 1) {
Tcl_WrongNumArgs(interp, 1, objv, "?name name...?");
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
3356 3357 3358 3359 3360 3361 3362 |
{
return Tcl_NRCallObjProc(interp, NRNamespaceEvalCmd, clientData, objc,
objv);
}
static int
NRNamespaceEvalCmd(
| | | 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 |
{
return Tcl_NRCallObjProc(interp, NRNamespaceEvalCmd, clientData, objc,
objv);
}
static int
NRNamespaceEvalCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
CmdFrame *invoker;
int word;
|
| ︙ | ︙ | |||
3442 3443 3444 3445 3446 3447 3448 |
static int
NsEval_Callback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | | | | 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 |
static int
NsEval_Callback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Namespace *namespacePtr = (Tcl_Namespace *)data[0];
if (result == TCL_ERROR) {
int length = strlen(namespacePtr->fullName);
int limit = 200;
int overflow = (length > limit);
char *cmd = (char *)data[1];
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (in namespace %s \"%.*s%s\" script line %d)",
cmd,
(overflow ? limit : length), namespacePtr->fullName,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
/*
* Restore the previous "current" namespace.
*/
|
| ︙ | ︙ | |||
3488 3489 3490 3491 3492 3493 3494 | * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceExistsCmd( | | | 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 |
* wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceExistsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Namespace *namespacePtr;
if (objc != 2) {
|
| ︙ | ︙ | |||
3543 3544 3545 3546 3547 3548 3549 | * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceExportCmd( | | | 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 |
* wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceExportCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int firstArg, i;
if (objc < 1) {
|
| ︙ | ︙ | |||
3573 3574 3575 3576 3577 3578 3579 |
}
/*
* Process the optional "-clear" argument.
*/
firstArg = 1;
| | | | 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 |
}
/*
* Process the optional "-clear" argument.
*/
firstArg = 1;
if (strcmp("-clear", Tcl_GetString(objv[firstArg])) == 0) {
Tcl_Export(interp, NULL, "::", 1);
Tcl_ResetResult(interp);
firstArg++;
}
/*
* Add each pattern to the namespace's export pattern list.
*/
for (i = firstArg; i < objc; i++) {
int result = Tcl_Export(interp, NULL, Tcl_GetString(objv[i]), 0);
if (result != TCL_OK) {
return result;
}
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
3624 3625 3626 3627 3628 3629 3630 | * interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceForgetCmd( | | | | 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 |
* interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceForgetCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *pattern;
int i, result;
if (objc < 1) {
Tcl_WrongNumArgs(interp, 1, objv, "?pattern pattern...?");
return TCL_ERROR;
}
for (i = 1; i < objc; i++) {
|
| ︙ | ︙ | |||
3689 3690 3691 3692 3693 3694 3695 | * result object. * *---------------------------------------------------------------------- */ static int NamespaceImportCmd( | | | | 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 |
* result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceImportCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int allowOverwrite = 0;
const char *string, *pattern;
int i, result;
int firstArg;
if (objc < 1) {
Tcl_WrongNumArgs(interp, 1, objv, "?-force? ?pattern pattern...?");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
3729 3730 3731 3732 3733 3734 3735 |
Tcl_HashSearch search;
Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
Tcl_Obj *listPtr;
TclNewObj(listPtr);
for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
| | | | 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 |
Tcl_HashSearch search;
Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
Tcl_Obj *listPtr;
TclNewObj(listPtr);
for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Command *cmdPtr = (Command *)Tcl_GetHashValue(hPtr);
if (cmdPtr->deleteProc == DeleteImportedCmd) {
Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj(
(char *)Tcl_GetHashKey(&nsPtr->cmdTable, hPtr) ,-1));
}
}
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
3804 3805 3806 3807 3808 3809 3810 |
{
return Tcl_NRCallObjProc(interp, NRNamespaceInscopeCmd, clientData, objc,
objv);
}
static int
NRNamespaceInscopeCmd(
| | | 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 |
{
return Tcl_NRCallObjProc(interp, NRNamespaceInscopeCmd, clientData, objc,
objv);
}
static int
NRNamespaceInscopeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Namespace *namespacePtr;
CallFrame *framePtr, **framePtrPtr;
int i;
|
| ︙ | ︙ | |||
3849 3850 3851 3852 3853 3854 3855 |
* of extra arguments to form the command to evaluate.
*/
if (objc == 3) {
cmdObjPtr = objv[2];
} else {
Tcl_Obj *concatObjv[2];
| | | 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 |
* of extra arguments to form the command to evaluate.
*/
if (objc == 3) {
cmdObjPtr = objv[2];
} else {
Tcl_Obj *concatObjv[2];
Tcl_Obj *listPtr;
listPtr = Tcl_NewListObj(0, NULL);
for (i = 3; i < objc; i++) {
if (Tcl_ListObjAppendElement(interp, listPtr, objv[i]) != TCL_OK){
Tcl_DecrRefCount(listPtr); /* Free unneeded obj. */
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
3901 3902 3903 3904 3905 3906 3907 | * interpreter's result object. * *---------------------------------------------------------------------- */ static int NamespaceOriginCmd( | | | 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 |
* interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceOriginCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Command command, origCommand;
Tcl_Obj *resultPtr;
|
| ︙ | ︙ | |||
3962 3963 3964 3965 3966 3967 3968 | * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceParentCmd( | | | 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 |
* wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceParentCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Namespace *nsPtr;
if (objc == 1) {
|
| ︙ | ︙ | |||
4020 4021 4022 4023 4024 4025 4026 | * names that depend on the namespace for resolution). * *---------------------------------------------------------------------- */ static int NamespacePathCmd( | | < | | 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 |
* names that depend on the namespace for resolution).
*
*----------------------------------------------------------------------
*/
static int
NamespacePathCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
int i, nsObjc, result = TCL_ERROR;
Tcl_Obj **nsObjv;
Tcl_Namespace **namespaceList = NULL;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?pathList?");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
4061 4062 4063 4064 4065 4066 4067 |
* There is a path given, so parse it into an array of namespace pointers.
*/
if (TclListObjGetElements(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) {
goto badNamespace;
}
if (nsObjc != 0) {
| | | | 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 |
* There is a path given, so parse it into an array of namespace pointers.
*/
if (TclListObjGetElements(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) {
goto badNamespace;
}
if (nsObjc != 0) {
namespaceList = (Tcl_Namespace **)TclStackAlloc(interp,
sizeof(Tcl_Namespace *) * nsObjc);
for (i=0 ; i<nsObjc ; i++) {
if (TclGetNamespaceFromObj(interp, nsObjv[i],
&namespaceList[i]) != TCL_OK) {
goto badNamespace;
}
}
}
|
| ︙ | ︙ | |||
4109 4110 4111 4112 4113 4114 4115 |
*
*----------------------------------------------------------------------
*/
void
TclSetNsPath(
Namespace *nsPtr, /* Namespace whose path is to be set. */
| | | | | 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 |
*
*----------------------------------------------------------------------
*/
void
TclSetNsPath(
Namespace *nsPtr, /* Namespace whose path is to be set. */
int pathLength, /* Length of pathAry. */
Tcl_Namespace *pathAry[]) /* Array of namespaces that are the path. */
{
if (pathLength != 0) {
NamespacePathEntry *tmpPathArray =
(NamespacePathEntry *)ckalloc(sizeof(NamespacePathEntry) * pathLength);
int i;
for (i=0 ; i<pathLength ; i++) {
tmpPathArray[i].nsPtr = (Namespace *) pathAry[i];
tmpPathArray[i].creatorNsPtr = nsPtr;
tmpPathArray[i].prevPtr = NULL;
tmpPathArray[i].nextPtr =
tmpPathArray[i].nsPtr->commandPathSourceList;
|
| ︙ | ︙ | |||
4166 4167 4168 4169 4170 4171 4172 |
*----------------------------------------------------------------------
*/
static void
UnlinkNsPath(
Namespace *nsPtr)
{
| | | | 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 |
*----------------------------------------------------------------------
*/
static void
UnlinkNsPath(
Namespace *nsPtr)
{
int i;
for (i=0 ; i<nsPtr->commandPathLength ; i++) {
NamespacePathEntry *nsPathPtr = &nsPtr->commandPathArray[i];
if (nsPathPtr->prevPtr != NULL) {
nsPathPtr->prevPtr->nextPtr = nsPathPtr->nextPtr;
}
if (nsPathPtr->nextPtr != NULL) {
nsPathPtr->nextPtr->prevPtr = nsPathPtr->prevPtr;
}
if (nsPathPtr->nsPtr != NULL) {
if (nsPathPtr->nsPtr->commandPathSourceList == nsPathPtr) {
nsPathPtr->nsPtr->commandPathSourceList = nsPathPtr->nextPtr;
}
}
}
ckfree(nsPtr->commandPathArray);
}
/*
*----------------------------------------------------------------------
*
* TclInvalidateNsPath --
*
|
| ︙ | ︙ | |||
4246 4247 4248 4249 4250 4251 4252 | * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceQualifiersCmd( | | | | | 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 |
* wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceQualifiersCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *name, *p;
int length;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "string");
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
4314 4315 4316 4317 4318 4319 4320 | * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceUnknownCmd( | | | 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 |
* wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceUnknownCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Namespace *currNsPtr;
Tcl_Obj *resultPtr;
int rc;
|
| ︙ | ︙ | |||
4501 4502 4503 4504 4505 4506 4507 | * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceTailCmd( | | | | 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 4490 4491 4492 4493 4494 4495 4496 4497 |
* wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceTailCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *name, *p;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "string");
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
4559 4560 4561 4562 4563 4564 4565 | * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceUpvarCmd( | | | 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 |
* wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceUpvarCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Namespace *nsPtr, *savedNsPtr;
Var *otherPtr, *arrayPtr;
|
| ︙ | ︙ | |||
4633 4634 4635 4636 4637 4638 4639 | * wrong, the result is an error message. * *---------------------------------------------------------------------- */ static int NamespaceWhichCmd( | | | 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 |
* wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceWhichCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const opts[] = {
"-command", "-variable", NULL
};
|
| ︙ | ︙ | |||
4709 4710 4711 4712 4713 4714 4715 | * the namespace, it's structure will be freed. * *---------------------------------------------------------------------- */ static void FreeNsNameInternalRep( | | | | 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 |
* the namespace, it's structure will be freed.
*
*----------------------------------------------------------------------
*/
static void
FreeNsNameInternalRep(
Tcl_Obj *objPtr) /* nsName object with internal representation
* to free. */
{
ResolvedNsName *resNamePtr;
NsNameGetIntRep(objPtr, resNamePtr);
assert(resNamePtr != NULL);
/*
* Decrement the reference count of the namespace. If there are no more
* references, free it up.
*/
if (resNamePtr->refCount-- <= 1) {
/*
* Decrement the reference count for the cached namespace. If the
* namespace is dead, and there are no more references to it, free
* it.
*/
TclNsDecrRefCount(resNamePtr->nsPtr);
ckfree(resNamePtr);
}
}
/*
*----------------------------------------------------------------------
*
* DupNsNameInternalRep --
|
| ︙ | ︙ | |||
4756 4757 4758 4759 4760 4761 4762 |
*
*----------------------------------------------------------------------
*/
static void
DupNsNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
| | | 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 |
*
*----------------------------------------------------------------------
*/
static void
DupNsNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
ResolvedNsName *resNamePtr;
NsNameGetIntRep(srcPtr, resNamePtr);
assert(resNamePtr != NULL);
NsNameSetIntRep(copyPtr, resNamePtr);
}
|
| ︙ | ︙ | |||
4792 4793 4794 4795 4796 4797 4798 |
*/
static int
SetNsNameFromAny(
Tcl_Interp *interp, /* Points to the namespace in which to resolve
* name. Also used for error reporting if not
* NULL. */
| | | | | 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 |
*/
static int
SetNsNameFromAny(
Tcl_Interp *interp, /* Points to the namespace in which to resolve
* name. Also used for error reporting if not
* NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
const char *dummy;
Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
ResolvedNsName *resNamePtr;
const char *name;
if (interp == NULL) {
return TCL_ERROR;
}
name = TclGetString(objPtr);
TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS,
&nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) {
return TCL_ERROR;
}
/*
* If we found a namespace, then create a new ResolvedNsName structure
* that holds a reference to it.
*/
nsPtr->refCount++;
resNamePtr = (ResolvedNsName *)ckalloc(sizeof(ResolvedNsName));
resNamePtr->nsPtr = nsPtr;
if ((name[0] == ':') && (name[1] == ':')) {
resNamePtr->refNsPtr = NULL;
} else {
resNamePtr->refNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
}
resNamePtr->refCount = 0;
|
| ︙ | ︙ | |||
4877 4878 4879 4880 4881 4882 4883 |
Tcl_Namespace *nsPtr)
{
Namespace *nPtr = (Namespace *) nsPtr;
#ifndef BREAK_NAMESPACE_COMPAT
return &nPtr->childTable;
#else
if (nPtr->childTablePtr == NULL) {
| | | 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 |
Tcl_Namespace *nsPtr)
{
Namespace *nPtr = (Namespace *) nsPtr;
#ifndef BREAK_NAMESPACE_COMPAT
return &nPtr->childTable;
#else
if (nPtr->childTablePtr == NULL) {
nPtr->childTablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(nPtr->childTablePtr, TCL_STRING_KEYS);
}
return nPtr->childTablePtr;
#endif
}
/*
|
| ︙ | ︙ | |||
4913 4914 4915 4916 4917 4918 4919 |
void
TclLogCommandInfo(
Tcl_Interp *interp, /* Interpreter in which to log information. */
const char *script, /* First character in script containing
* command (must be <= command). */
const char *command, /* First character in command that generated
* the error. */
| | | | | 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 |
void
TclLogCommandInfo(
Tcl_Interp *interp, /* Interpreter in which to log information. */
const char *script, /* First character in script containing
* command (must be <= command). */
const char *command, /* First character in command that generated
* the error. */
int length, /* Number of bytes in command (-1 means use
* all bytes up to first null byte). */
const unsigned char *pc, /* Current pc of bytecode execution context */
Tcl_Obj **tosPtr) /* Current stack of bytecode execution
* context */
{
const char *p;
Interp *iPtr = (Interp *) interp;
int overflow, limit = 150;
Var *varPtr, *arrayPtr;
if (iPtr->flags & ERR_ALREADY_LOGGED) {
/*
* Someone else has already logged error information for this command;
|
| ︙ | ︙ | |||
4945 4946 4947 4948 4949 4950 4951 |
iPtr->errorLine = 1;
for (p = script; p != command; p++) {
if (*p == '\n') {
iPtr->errorLine++;
}
}
| | | | | | 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 |
iPtr->errorLine = 1;
for (p = script; p != command; p++) {
if (*p == '\n') {
iPtr->errorLine++;
}
}
if (length < 0) {
length = strlen(command);
}
overflow = (length > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL)
? "while executing" : "invoked from within"),
(overflow ? limit : length), command,
(overflow ? "..." : "")));
varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY,
NULL, 0, 0, &arrayPtr);
if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) {
/*
* Should not happen.
*/
return;
} else {
Tcl_HashEntry *hPtr
= Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
VarTrace *tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr);
if (tracePtr->traceProc != EstablishErrorInfoTraces) {
/*
* The most recent trace set on ::errorInfo is not the one the
* core itself puts on last. This means some other code is
* tracing the variable, and the additional trace(s) might be
* write traces that expect the timing of writes to
|
| ︙ | ︙ | |||
5070 5071 5072 5073 5074 5075 5076 |
*----------------------------------------------------------------------
*/
void
TclErrorStackResetIf(
Tcl_Interp *interp,
const char *msg,
| | | 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 |
*----------------------------------------------------------------------
*/
void
TclErrorStackResetIf(
Tcl_Interp *interp,
const char *msg,
int length)
{
Interp *iPtr = (Interp *) interp;
if (Tcl_IsShared(iPtr->errorStack)) {
Tcl_Obj *newObj;
newObj = Tcl_DuplicateObj(iPtr->errorStack);
|
| ︙ | ︙ | |||
5125 5126 5127 5128 5129 5130 5131 |
void
Tcl_LogCommandInfo(
Tcl_Interp *interp, /* Interpreter in which to log information. */
const char *script, /* First character in script containing
* command (must be <= command). */
const char *command, /* First character in command that generated
* the error. */
| | | 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 |
void
Tcl_LogCommandInfo(
Tcl_Interp *interp, /* Interpreter in which to log information. */
const char *script, /* First character in script containing
* command (must be <= command). */
const char *command, /* First character in command that generated
* the error. */
int length) /* Number of bytes in command (-1 means use
* all bytes up to first null byte). */
{
TclLogCommandInfo(interp, script, command, length, NULL, NULL);
}
/*
|
| ︙ | ︙ |
Changes to generic/tclNotify.c.
| ︙ | ︙ | |||
177 178 179 180 181 182 183 |
return; /* Notifier not initialized for the current thread */
}
Tcl_MutexLock(&(tsdPtr->queueMutex));
for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL; ) {
hold = evPtr;
evPtr = evPtr->nextPtr;
| | | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 |
return; /* Notifier not initialized for the current thread */
}
Tcl_MutexLock(&(tsdPtr->queueMutex));
for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL; ) {
hold = evPtr;
evPtr = evPtr->nextPtr;
ckfree(hold);
}
tsdPtr->firstEventPtr = NULL;
tsdPtr->lastEventPtr = NULL;
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
Tcl_MutexLock(&listLock);
|
| ︙ | ︙ | |||
272 273 274 275 276 277 278 |
Tcl_EventCheckProc *checkProc,
/* Function to call after waiting to see what
* happened. */
ClientData clientData) /* One-word argument to pass to setupProc and
* checkProc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| | | 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 |
Tcl_EventCheckProc *checkProc,
/* Function to call after waiting to see what
* happened. */
ClientData clientData) /* One-word argument to pass to setupProc and
* checkProc. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
EventSource *sourcePtr = (EventSource *)ckalloc(sizeof(EventSource));
sourcePtr->setupProc = setupProc;
sourcePtr->checkProc = checkProc;
sourcePtr->clientData = clientData;
sourcePtr->nextPtr = tsdPtr->firstEventSourcePtr;
tsdPtr->firstEventSourcePtr = sourcePtr;
}
|
| ︙ | ︙ | |||
326 327 328 329 330 331 332 |
continue;
}
if (prevPtr == NULL) {
tsdPtr->firstEventSourcePtr = sourcePtr->nextPtr;
} else {
prevPtr->nextPtr = sourcePtr->nextPtr;
}
| | | 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 |
continue;
}
if (prevPtr == NULL) {
tsdPtr->firstEventSourcePtr = sourcePtr->nextPtr;
} else {
prevPtr->nextPtr = sourcePtr->nextPtr;
}
ckfree(sourcePtr);
return;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
351 352 353 354 355 356 357 |
*----------------------------------------------------------------------
*/
void
Tcl_QueueEvent(
Tcl_Event *evPtr, /* Event to add to queue. The storage space
* must have been allocated the caller with
| | | 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 |
*----------------------------------------------------------------------
*/
void
Tcl_QueueEvent(
Tcl_Event *evPtr, /* Event to add to queue. The storage space
* must have been allocated the caller with
* malloc (ckalloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
* TCL_QUEUE_MARK. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
383 384 385 386 387 388 389 |
*/
void
Tcl_ThreadQueueEvent(
Tcl_ThreadId threadId, /* Identifier for thread to use. */
Tcl_Event *evPtr, /* Event to add to queue. The storage space
* must have been allocated the caller with
| | | 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 |
*/
void
Tcl_ThreadQueueEvent(
Tcl_ThreadId threadId, /* Identifier for thread to use. */
Tcl_Event *evPtr, /* Event to add to queue. The storage space
* must have been allocated the caller with
* malloc (ckalloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
* TCL_QUEUE_MARK. */
{
ThreadSpecificData *tsdPtr;
|
| ︙ | ︙ | |||
408 409 410 411 412 413 414 |
/*
* Queue the event if there was a notifier associated with the thread.
*/
if (tsdPtr) {
QueueEvent(tsdPtr, evPtr, position);
} else {
| | | 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 |
/*
* Queue the event if there was a notifier associated with the thread.
*/
if (tsdPtr) {
QueueEvent(tsdPtr, evPtr, position);
} else {
ckfree(evPtr);
}
Tcl_MutexUnlock(&listLock);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
440 441 442 443 444 445 446 |
static void
QueueEvent(
ThreadSpecificData *tsdPtr, /* Handle to thread local data that indicates
* which event queue to use. */
Tcl_Event *evPtr, /* Event to add to queue. The storage space
* must have been allocated the caller with
| | | 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 |
static void
QueueEvent(
ThreadSpecificData *tsdPtr, /* Handle to thread local data that indicates
* which event queue to use. */
Tcl_Event *evPtr, /* Event to add to queue. The storage space
* must have been allocated the caller with
* malloc (ckalloc), and it becomes the
* property of the event queue. It will be
* freed after the event has been handled. */
Tcl_QueuePosition position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD,
* TCL_QUEUE_MARK. */
{
Tcl_MutexLock(&(tsdPtr->queueMutex));
if (position == TCL_QUEUE_TAIL) {
|
| ︙ | ︙ | |||
559 560 561 562 563 564 565 | /* * Delete the event data structure. */ hold = evPtr; evPtr = evPtr->nextPtr; | | | 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 |
/*
* Delete the event data structure.
*/
hold = evPtr;
evPtr = evPtr->nextPtr;
ckfree(hold);
} else {
/*
* Event is to be retained.
*/
prevPtr = evPtr;
evPtr = evPtr->nextPtr;
|
| ︙ | ︙ | |||
698 699 700 701 702 703 704 |
tsdPtr->markerEventPtr = prevPtr;
}
} else {
evPtr = NULL;
}
}
if (evPtr) {
| | | 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 |
tsdPtr->markerEventPtr = prevPtr;
}
} else {
evPtr = NULL;
}
}
if (evPtr) {
ckfree(evPtr);
}
Tcl_MutexUnlock(&(tsdPtr->queueMutex));
return 1;
} else {
/*
* The event wasn't actually handled, so we have to restore the
* proc field to allow the event to be attempted again.
|
| ︙ | ︙ |
Changes to generic/tclOO.c.
| ︙ | ︙ | |||
73 74 75 76 77 78 79 | static Tcl_NRPostProc FinalizeAlloc; static Tcl_NRPostProc FinalizeNext; static Tcl_NRPostProc FinalizeObjectCall; static inline void InitClassPath(Tcl_Interp * interp, Class *clsPtr); static void InitClassSystemRoots(Tcl_Interp *interp, Foundation *fPtr); static int InitFoundation(Tcl_Interp *interp); | | < | < < | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 | static Tcl_NRPostProc FinalizeAlloc; static Tcl_NRPostProc FinalizeNext; static Tcl_NRPostProc FinalizeObjectCall; static inline void InitClassPath(Tcl_Interp * interp, Class *clsPtr); static void InitClassSystemRoots(Tcl_Interp *interp, Foundation *fPtr); static int InitFoundation(Tcl_Interp *interp); static Tcl_InterpDeleteProc KillFoundation; static void MyDeleted(ClientData clientData); static void ObjectNamespaceDeleted(ClientData clientData); static Tcl_CommandTraceProc ObjectRenamedTrace; static inline void RemoveClass(Class **list, int num, int idx); static inline void RemoveObject(Object **list, int num, int idx); static inline void SquelchCachedName(Object *oPtr); static int PublicNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); |
| ︙ | ︙ | |||
171 172 173 174 175 176 177 | * * The ocPtr parameter (only in these macros) is assumed to work fine with * either an oPtr or a classPtr. Note that the roots oo::object and oo::class * have _both_ their object and class flags tagged with ROOT_OBJECT and * ROOT_CLASS respectively. */ | | | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 |
*
* The ocPtr parameter (only in these macros) is assumed to work fine with
* either an oPtr or a classPtr. Note that the roots oo::object and oo::class
* have _both_ their object and class flags tagged with ROOT_OBJECT and
* ROOT_CLASS respectively.
*/
#define Destructing(oPtr) ((oPtr)->flags & OBJECT_DESTRUCTING)
#define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT)
#define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS)
#define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS))
#define RemoveItem(type, lst, i) \
do { \
Remove ## type ((lst).list, (lst).num, i); \
|
| ︙ | ︙ | |||
295 296 297 298 299 300 301 |
static int
InitFoundation(
Tcl_Interp *interp)
{
static Tcl_ThreadDataKey tsdKey;
ThreadLocalData *tsdPtr =
| | | | 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 |
static int
InitFoundation(
Tcl_Interp *interp)
{
static Tcl_ThreadDataKey tsdKey;
ThreadLocalData *tsdPtr =
(ThreadLocalData *)Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
Foundation *fPtr = (Foundation *)ckalloc(sizeof(Foundation));
Tcl_Obj *namePtr;
Tcl_DString buffer;
Command *cmdPtr;
int i;
/*
* Initialize the structure that holds the OO system core. This is
|
| ︙ | ︙ | |||
319 320 321 322 323 324 325 |
Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1);
fPtr->defineNs = Tcl_CreateNamespace(interp, "::oo::define", fPtr,
DeletedDefineNamespace);
fPtr->objdefNs = Tcl_CreateNamespace(interp, "::oo::objdefine", fPtr,
DeletedObjdefNamespace);
fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
DeletedHelpersNamespace);
| | | 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 |
Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1);
fPtr->defineNs = Tcl_CreateNamespace(interp, "::oo::define", fPtr,
DeletedDefineNamespace);
fPtr->objdefNs = Tcl_CreateNamespace(interp, "::oo::objdefine", fPtr,
DeletedObjdefNamespace);
fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
DeletedHelpersNamespace);
fPtr->epoch = 0;
fPtr->tsdPtr = tsdPtr;
TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown");
TclNewLiteralStringObj(fPtr->constructorName, "<constructor>");
TclNewLiteralStringObj(fPtr->destructorName, "<destructor>");
TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
TclNewLiteralStringObj(fPtr->defineName, "::oo::define");
Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
|
| ︙ | ︙ | |||
461 462 463 464 465 466 467 |
/*
* This is why it is unnecessary in this routine to replace the
* incremented reference count of fPtr->objectCls that was swallowed by
* fakeObject.
*/
fPtr->objectCls->superclasses.num = 0;
| | | 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 |
/*
* This is why it is unnecessary in this routine to replace the
* incremented reference count of fPtr->objectCls that was swallowed by
* fakeObject.
*/
fPtr->objectCls->superclasses.num = 0;
ckfree(fPtr->objectCls->superclasses.list);
fPtr->objectCls->superclasses.list = NULL;
/*
* Special initialization for the primordial objects.
*/
fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
|
| ︙ | ︙ | |||
529 530 531 532 533 534 535 |
* ----------------------------------------------------------------------
*/
static void
DeletedDefineNamespace(
ClientData clientData)
{
| | | | | < | | | | 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 |
* ----------------------------------------------------------------------
*/
static void
DeletedDefineNamespace(
ClientData clientData)
{
Foundation *fPtr = (Foundation *)clientData;
fPtr->defineNs = NULL;
}
static void
DeletedObjdefNamespace(
ClientData clientData)
{
Foundation *fPtr = (Foundation *)clientData;
fPtr->objdefNs = NULL;
}
static void
DeletedHelpersNamespace(
ClientData clientData)
{
Foundation *fPtr = (Foundation *)clientData;
fPtr->helpersNs = NULL;
}
/*
* ----------------------------------------------------------------------
*
* KillFoundation --
*
* Delete those parts of the OO core that are not deleted automatically
* when the objects and classes themselves are destroyed.
*
* ----------------------------------------------------------------------
*/
static void
KillFoundation(
TCL_UNUSED(ClientData),
Tcl_Interp *interp) /* The interpreter containing the OO system
* foundation. */
{
Foundation *fPtr = GetFoundation(interp);
TclDecrRefCount(fPtr->unknownMethodNameObj);
TclDecrRefCount(fPtr->constructorName);
TclDecrRefCount(fPtr->destructorName);
TclDecrRefCount(fPtr->clonedName);
TclDecrRefCount(fPtr->defineName);
TclOODecrRefCount(fPtr->objectCls->thisPtr);
TclOODecrRefCount(fPtr->classCls->thisPtr);
ckfree(fPtr);
}
/*
* ----------------------------------------------------------------------
*
* AllocObject --
*
|
| ︙ | ︙ | |||
618 619 620 621 622 623 624 |
* a namespace that already exists, the effect
* will be the same as if this was NULL. */
{
Foundation *fPtr = GetFoundation(interp);
Object *oPtr;
Command *cmdPtr;
CommandTrace *tracePtr;
| | | | 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 |
* a namespace that already exists, the effect
* will be the same as if this was NULL. */
{
Foundation *fPtr = GetFoundation(interp);
Object *oPtr;
Command *cmdPtr;
CommandTrace *tracePtr;
int creationEpoch;
oPtr = (Object *)ckalloc(sizeof(Object));
memset(oPtr, 0, sizeof(Object));
/*
* Every object has a namespace; make one. Note that this also normally
* computes the creation epoch value for the object, a sequence number
* that is unique to the object (and which allows us to manage method
* caching without comparing pointers).
|
| ︙ | ︙ | |||
647 648 649 650 651 652 653 |
}
Tcl_ResetResult(interp);
}
while (1) {
char objName[10 + TCL_INTEGER_SPACE];
| | | 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 |
}
Tcl_ResetResult(interp);
}
while (1) {
char objName[10 + TCL_INTEGER_SPACE];
sprintf(objName, "::oo::Obj%d", ++fPtr->tsdPtr->nsCount);
oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, NULL);
if (oPtr->namespacePtr != NULL) {
creationEpoch = fPtr->tsdPtr->nsCount;
break;
}
/*
|
| ︙ | ︙ | |||
731 732 733 734 735 736 737 |
/*
* Add the NRE command and trace directly. While this breaks a number of
* abstractions, it is faster and we're inside Tcl here so we're allowed.
*/
cmdPtr = (Command *) oPtr->command;
cmdPtr->nreProc = PublicNRObjectCmd;
| | | 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 |
/*
* Add the NRE command and trace directly. While this breaks a number of
* abstractions, it is faster and we're inside Tcl here so we're allowed.
*/
cmdPtr = (Command *) oPtr->command;
cmdPtr->nreProc = PublicNRObjectCmd;
cmdPtr->tracePtr = tracePtr = (CommandTrace *)ckalloc(sizeof(CommandTrace));
tracePtr->traceProc = ObjectRenamedTrace;
tracePtr->clientData = oPtr;
tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE;
tracePtr->nextPtr = NULL;
tracePtr->refCount = 1;
oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr,
|
| ︙ | ︙ | |||
785 786 787 788 789 790 791 |
*/
static void
MyDeleted(
ClientData clientData) /* Reference to the object whose [my] has been
* squelched. */
{
| | | | | | | | | 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 |
*/
static void
MyDeleted(
ClientData clientData) /* Reference to the object whose [my] has been
* squelched. */
{
Object *oPtr = (Object *)clientData;
oPtr->myCommand = NULL;
}
static void
MyClassDeleted(
ClientData clientData)
{
Object *oPtr = (Object *)clientData;
oPtr->myclassCommand = NULL;
}
/*
* ----------------------------------------------------------------------
*
* ObjectRenamedTrace --
*
* This callback is triggered when the object is deleted by any
* mechanism. It runs the destructors and arranges for the actual cleanup
* of the object's namespace, which in turn triggers cleansing of the
* object data structures.
*
* ----------------------------------------------------------------------
*/
static void
ObjectRenamedTrace(
ClientData clientData, /* The object being deleted. */
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(const char *) /*oldName*/,
TCL_UNUSED(const char *) /*newName*/,
int flags) /* Why was the object deleted? */
{
Object *oPtr = (Object *)clientData;
/*
* If this is a rename and not a delete of the object, we just flush the
* cache of the object name.
*/
if (flags & TCL_TRACE_RENAME) {
SquelchCachedName(oPtr);
return;
}
/*
* The namespace is only deleted if it hasn't already been deleted. [Bug
* 2950259].
*/
if (!Destructing(oPtr)) {
Tcl_DeleteNamespace(oPtr->namespacePtr);
}
oPtr->command = NULL;
TclOODecrRefCount(oPtr);
return;
}
|
| ︙ | ︙ | |||
876 877 878 879 880 881 882 | clsPtr->mixinSubs.list[clsPtr->mixinSubs.num - 1]; /* * This condition also covers the case where mixinSubclassPtr == * clsPtr */ | | | | | | | | 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 |
clsPtr->mixinSubs.list[clsPtr->mixinSubs.num - 1];
/*
* This condition also covers the case where mixinSubclassPtr ==
* clsPtr
*/
if (!Destructing(mixinSubclassPtr->thisPtr)
&& !(mixinSubclassPtr->thisPtr->flags & DONT_DELETE)) {
Tcl_DeleteCommandFromToken(interp,
mixinSubclassPtr->thisPtr->command);
}
TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr);
}
}
if (clsPtr->mixinSubs.size > 0) {
ckfree(clsPtr->mixinSubs.list);
clsPtr->mixinSubs.size = 0;
}
/*
* Squelch subclasses of this class.
*/
if (clsPtr->subclasses.num > 0) {
while (clsPtr->subclasses.num > 0) {
subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num - 1];
if (!Destructing(subclassPtr->thisPtr) && !IsRoot(subclassPtr)
&& !(subclassPtr->thisPtr->flags & DONT_DELETE)) {
Tcl_DeleteCommandFromToken(interp,
subclassPtr->thisPtr->command);
}
TclOORemoveFromSubclasses(subclassPtr, clsPtr);
}
}
if (clsPtr->subclasses.size > 0) {
ckfree(clsPtr->subclasses.list);
clsPtr->subclasses.list = NULL;
clsPtr->subclasses.size = 0;
}
/*
* Squelch instances of this class (includes objects we're mixed into).
*/
if (clsPtr->instances.num > 0) {
while (clsPtr->instances.num > 0) {
instancePtr = clsPtr->instances.list[clsPtr->instances.num - 1];
/*
* This condition also covers the case where instancePtr == oPtr
*/
if (!Destructing(instancePtr) && !IsRoot(instancePtr) &&
!(instancePtr->flags & DONT_DELETE)) {
Tcl_DeleteCommandFromToken(interp, instancePtr->command);
}
TclOORemoveFromInstances(instancePtr, clsPtr);
}
}
if (clsPtr->instances.size > 0) {
ckfree(clsPtr->instances.list);
clsPtr->instances.list = NULL;
clsPtr->instances.size = 0;
}
}
/*
* ----------------------------------------------------------------------
|
| ︙ | ︙ | |||
964 965 966 967 968 969 970 |
Tcl_Obj *variableObj;
PrivateVariableMapping *privateVariable;
/*
* Sanity check!
*/
| | | 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 |
Tcl_Obj *variableObj;
PrivateVariableMapping *privateVariable;
/*
* Sanity check!
*/
if (!Destructing(oPtr)) {
if (IsRootClass(oPtr)) {
Tcl_Panic("deleting class structure for non-deleted %s",
"::oo::class");
} else if (IsRootObject(oPtr)) {
Tcl_Panic("deleting class structure for non-deleted %s",
"::oo::object");
}
|
| ︙ | ︙ | |||
1006 1007 1008 1009 1010 1011 1012 |
if (clsPtr->classChainCache) {
CallChain *callPtr;
FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) {
TclOODeleteChain(callPtr);
}
Tcl_DeleteHashTable(clsPtr->classChainCache);
| | | | | | | | | | 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 |
if (clsPtr->classChainCache) {
CallChain *callPtr;
FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) {
TclOODeleteChain(callPtr);
}
Tcl_DeleteHashTable(clsPtr->classChainCache);
ckfree(clsPtr->classChainCache);
clsPtr->classChainCache = NULL;
}
/*
* Squelch our filter list.
*/
if (clsPtr->filters.num) {
Tcl_Obj *filterObj;
FOREACH(filterObj, clsPtr->filters) {
TclDecrRefCount(filterObj);
}
ckfree(clsPtr->filters.list);
clsPtr->filters.list = NULL;
clsPtr->filters.num = 0;
}
/*
* Squelch our metadata.
*/
if (clsPtr->metadataPtr != NULL) {
Tcl_ObjectMetadataType *metadataTypePtr;
ClientData value;
FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
metadataTypePtr->deleteProc(value);
}
Tcl_DeleteHashTable(clsPtr->metadataPtr);
ckfree(clsPtr->metadataPtr);
clsPtr->metadataPtr = NULL;
}
if (clsPtr->mixins.num) {
FOREACH(tmpClsPtr, clsPtr->mixins) {
TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr);
TclOODecrRefCount(tmpClsPtr->thisPtr);
}
ckfree(clsPtr->mixins.list);
clsPtr->mixins.list = NULL;
clsPtr->mixins.num = 0;
}
if (clsPtr->superclasses.num > 0) {
FOREACH(tmpClsPtr, clsPtr->superclasses) {
TclOORemoveFromSubclasses(clsPtr, tmpClsPtr);
TclOODecrRefCount(tmpClsPtr->thisPtr);
}
ckfree(clsPtr->superclasses.list);
clsPtr->superclasses.num = 0;
clsPtr->superclasses.list = NULL;
}
FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) {
TclOODelMethodRef(mPtr);
}
Tcl_DeleteHashTable(&clsPtr->classMethods);
TclOODelMethodRef(clsPtr->constructorPtr);
TclOODelMethodRef(clsPtr->destructorPtr);
FOREACH(variableObj, clsPtr->variables) {
TclDecrRefCount(variableObj);
}
if (i) {
ckfree(clsPtr->variables.list);
}
FOREACH_STRUCT(privateVariable, clsPtr->privateVariables) {
TclDecrRefCount(privateVariable->variableObj);
TclDecrRefCount(privateVariable->fullNameObj);
}
if (i) {
ckfree(clsPtr->privateVariables.list);
}
if (IsRootClass(oPtr) && !Destructing(fPtr->objectCls->thisPtr)) {
Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
}
}
/*
* ----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1106 1107 1108 1109 1110 1111 1112 |
*/
static void
ObjectNamespaceDeleted(
ClientData clientData) /* Pointer to the class whose namespace is
* being deleted. */
{
| | | | | 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 |
*/
static void
ObjectNamespaceDeleted(
ClientData clientData) /* Pointer to the class whose namespace is
* being deleted. */
{
Object *oPtr = (Object *)clientData;
Foundation *fPtr = oPtr->fPtr;
FOREACH_HASH_DECLS;
Class *mixinPtr;
Method *mPtr;
Tcl_Obj *filterObj, *variableObj;
PrivateVariableMapping *privateVariable;
Tcl_Interp *interp = oPtr->fPtr->interp;
int i;
if (Destructing(oPtr)) {
/*
* TODO: Can ObjectNamespaceDeleted ever be called twice? If not,
* this guard could be removed.
*/
return;
}
/*
* One rule for the teardown routines is that if an object is in the
* process of being deleted, nothing else may modify its bookeeping
* records. This is the flag that
*/
oPtr->flags |= OBJECT_DESTRUCTING;
/*
* Let the dominoes fall!
*/
if (oPtr->classPtr) {
TclOODeleteDescendants(interp, oPtr);
|
| ︙ | ︙ | |||
1212 1213 1214 1215 1216 1217 1218 |
if (oPtr->mixins.num > 0) {
FOREACH(mixinPtr, oPtr->mixins) {
TclOORemoveFromInstances(oPtr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
if (oPtr->mixins.list != NULL) {
| | | | | | | | | 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 |
if (oPtr->mixins.num > 0) {
FOREACH(mixinPtr, oPtr->mixins) {
TclOORemoveFromInstances(oPtr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
if (oPtr->mixins.list != NULL) {
ckfree(oPtr->mixins.list);
}
}
FOREACH(filterObj, oPtr->filters) {
TclDecrRefCount(filterObj);
}
if (i) {
ckfree(oPtr->filters.list);
}
if (oPtr->methodsPtr) {
FOREACH_HASH_VALUE(mPtr, oPtr->methodsPtr) {
TclOODelMethodRef(mPtr);
}
Tcl_DeleteHashTable(oPtr->methodsPtr);
ckfree(oPtr->methodsPtr);
}
FOREACH(variableObj, oPtr->variables) {
TclDecrRefCount(variableObj);
}
if (i) {
ckfree(oPtr->variables.list);
}
FOREACH_STRUCT(privateVariable, oPtr->privateVariables) {
TclDecrRefCount(privateVariable->variableObj);
TclDecrRefCount(privateVariable->fullNameObj);
}
if (i) {
ckfree(oPtr->privateVariables.list);
}
if (oPtr->chainCache) {
TclOODeleteChainCache(oPtr->chainCache);
}
SquelchCachedName(oPtr);
if (oPtr->metadataPtr != NULL) {
Tcl_ObjectMetadataType *metadataTypePtr;
ClientData value;
FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
metadataTypePtr->deleteProc(value);
}
Tcl_DeleteHashTable(oPtr->metadataPtr);
ckfree(oPtr->metadataPtr);
oPtr->metadataPtr = NULL;
}
/*
* Because an object can be a class that is an instance of itself, the
* class object's class structure should only be cleaned after most of
* the cleanup on the object is done.
*
* The class of objects needs some special care; if it is deleted (and
* we're not killing the whole interpreter) we force the delete of the
* class of classes now as well. Due to the incestuous nature of those two
* classes, if one goes the other must too and yet the tangle can
* sometimes not go away automatically; we force it here. [Bug 2962664]
*/
if (IsRootObject(oPtr) && !Destructing(fPtr->classCls->thisPtr)
&& !Tcl_InterpDeleted(interp)) {
Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);
}
if (oPtr->classPtr != NULL) {
TclOOReleaseClassContents(interp, oPtr);
}
|
| ︙ | ︙ | |||
1316 1317 1318 1319 1320 1321 1322 |
int
TclOODecrRefCount(
Object *oPtr)
{
if (oPtr->refCount-- <= 1) {
if (oPtr->classPtr != NULL) {
| | | > > > > > > > > > > > > > > | 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 |
int
TclOODecrRefCount(
Object *oPtr)
{
if (oPtr->refCount-- <= 1) {
if (oPtr->classPtr != NULL) {
ckfree(oPtr->classPtr);
}
ckfree(oPtr);
return 1;
}
return 0;
}
/*
* ----------------------------------------------------------------------
*
* TclOOObjectDestroyed --
*
* Returns TCL_OK if an object is entirely deleted, i.e. the destruction
* sequence has completed.
*
* ----------------------------------------------------------------------
*/
int TclOOObjectDestroyed(Object *oPtr) {
return (oPtr->namespacePtr == NULL);
}
/*
* ----------------------------------------------------------------------
*
* TclOORemoveFromInstances --
*
* Utility function to remove an object from the list of instances within
|
| ︙ | ︙ | |||
1376 1377 1378 1379 1380 1381 1382 |
Class *clsPtr) /* The class to add the instance to. It is
* assumed that the class is not already
* present as an instance in the class. */
{
if (clsPtr->instances.num >= clsPtr->instances.size) {
clsPtr->instances.size += ALLOC_CHUNK;
if (clsPtr->instances.size == ALLOC_CHUNK) {
| | | | 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 |
Class *clsPtr) /* The class to add the instance to. It is
* assumed that the class is not already
* present as an instance in the class. */
{
if (clsPtr->instances.num >= clsPtr->instances.size) {
clsPtr->instances.size += ALLOC_CHUNK;
if (clsPtr->instances.size == ALLOC_CHUNK) {
clsPtr->instances.list = (Object **)ckalloc(sizeof(Object *) * ALLOC_CHUNK);
} else {
clsPtr->instances.list = (Object **)ckrealloc(clsPtr->instances.list,
sizeof(Object *) * clsPtr->instances.size);
}
}
clsPtr->instances.list[clsPtr->instances.num++] = oPtr;
AddRef(oPtr);
}
|
| ︙ | ︙ | |||
1415 1416 1417 1418 1419 1420 1421 |
RemoveItem(Class, oPtr->mixins, i);
TclOODecrRefCount(mixPtr->thisPtr);
res++;
break;
}
}
if (oPtr->mixins.num == 0) {
| | | 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 |
RemoveItem(Class, oPtr->mixins, i);
TclOODecrRefCount(mixPtr->thisPtr);
res++;
break;
}
}
if (oPtr->mixins.num == 0) {
ckfree(oPtr->mixins.list);
oPtr->mixins.list = NULL;
}
return res;
}
/*
* ----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1469 1470 1471 1472 1473 1474 1475 |
void
TclOOAddToSubclasses(
Class *subPtr, /* The subclass to add. */
Class *superPtr) /* The superclass to add the subclass to. It
* is assumed that the class is not already
* present as a subclass in the superclass. */
{
| | | | | 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 |
void
TclOOAddToSubclasses(
Class *subPtr, /* The subclass to add. */
Class *superPtr) /* The superclass to add the subclass to. It
* is assumed that the class is not already
* present as a subclass in the superclass. */
{
if (Destructing(superPtr->thisPtr)) {
return;
}
if (superPtr->subclasses.num >= superPtr->subclasses.size) {
superPtr->subclasses.size += ALLOC_CHUNK;
if (superPtr->subclasses.size == ALLOC_CHUNK) {
superPtr->subclasses.list = (Class **)ckalloc(sizeof(Class *) * ALLOC_CHUNK);
} else {
superPtr->subclasses.list = (Class **)ckrealloc(superPtr->subclasses.list,
sizeof(Class *) * superPtr->subclasses.size);
}
}
superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr;
AddRef(subPtr->thisPtr);
}
|
| ︙ | ︙ | |||
1534 1535 1536 1537 1538 1539 1540 |
void
TclOOAddToMixinSubs(
Class *subPtr, /* The subclass to add. */
Class *superPtr) /* The superclass to add the subclass to. It
* is assumed that the class is not already
* present as a subclass in the superclass. */
{
| | | | | 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 |
void
TclOOAddToMixinSubs(
Class *subPtr, /* The subclass to add. */
Class *superPtr) /* The superclass to add the subclass to. It
* is assumed that the class is not already
* present as a subclass in the superclass. */
{
if (Destructing(superPtr->thisPtr)) {
return;
}
if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
superPtr->mixinSubs.size += ALLOC_CHUNK;
if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
superPtr->mixinSubs.list = (Class **)ckalloc(sizeof(Class *) * ALLOC_CHUNK);
} else {
superPtr->mixinSubs.list = (Class **)ckrealloc(superPtr->mixinSubs.list,
sizeof(Class *) * superPtr->mixinSubs.size);
}
}
superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr;
AddRef(subPtr->thisPtr);
}
|
| ︙ | ︙ | |||
1588 1589 1590 1591 1592 1593 1594 |
TclOOAllocClass(
Tcl_Interp *interp, /* Interpreter within which to allocate the
* class. */
Object *useThisObj) /* Object that is to act as the class
* representation. */
{
Foundation *fPtr = GetFoundation(interp);
| | | | 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 |
TclOOAllocClass(
Tcl_Interp *interp, /* Interpreter within which to allocate the
* class. */
Object *useThisObj) /* Object that is to act as the class
* representation. */
{
Foundation *fPtr = GetFoundation(interp);
Class *clsPtr = (Class *)ckalloc(sizeof(Class));
memset(clsPtr, 0, sizeof(Class));
clsPtr->thisPtr = useThisObj;
/*
* Configure the namespace path for the class's object.
*/
InitClassPath(interp, clsPtr);
/*
* Classes are subclasses of oo::object, i.e. the objects they create are
* objects.
*/
clsPtr->superclasses.num = 1;
clsPtr->superclasses.list = (Class **)ckalloc(sizeof(Class *));
clsPtr->superclasses.list[0] = fPtr->objectCls;
AddRef(fPtr->objectCls->thisPtr);
/*
* Finish connecting the class structure to the object structure.
*/
|
| ︙ | ︙ | |||
1648 1649 1650 1651 1652 1653 1654 |
* unique name. */
int objc, /* Number of arguments. Negative value means
* do not call constructor. */
Tcl_Obj *const *objv, /* Argument list. */
int skip) /* Number of arguments to _not_ pass to the
* constructor. */
{
| | | 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 |
* unique name. */
int objc, /* Number of arguments. Negative value means
* do not call constructor. */
Tcl_Obj *const *objv, /* Argument list. */
int skip) /* Number of arguments to _not_ pass to the
* constructor. */
{
Class *classPtr = (Class *) cls;
Object *oPtr;
ClientData clientData[4];
oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
if (oPtr == NULL) {
return NULL;
}
|
| ︙ | ︙ | |||
1718 1719 1720 1721 1722 1723 1724 |
* do not call constructor. */
Tcl_Obj *const *objv, /* Argument list. */
int skip, /* Number of arguments to _not_ pass to the
* constructor. */
Tcl_Object *objectPtr) /* Place to write the object reference upon
* successful allocation. */
{
| | | 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 |
* do not call constructor. */
Tcl_Obj *const *objv, /* Argument list. */
int skip, /* Number of arguments to _not_ pass to the
* constructor. */
Tcl_Object *objectPtr) /* Place to write the object reference upon
* successful allocation. */
{
Class *classPtr = (Class *) cls;
CallContext *contextPtr;
Tcl_InterpState state;
Object *oPtr;
oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
if (oPtr == NULL) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
1833 1834 1835 1836 1837 1838 1839 |
static int
FinalizeAlloc(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | | | | | 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 |
static int
FinalizeAlloc(
ClientData data[],
Tcl_Interp *interp,
int result)
{
CallContext *contextPtr = (CallContext *)data[0];
Object *oPtr = (Object *)data[1];
Tcl_InterpState state = (Tcl_InterpState)data[2];
Tcl_Object *objectPtr = (Tcl_Object *)data[3];
/*
* Ensure an error if the object was deleted in the constructor. Don't
* want to lose errors by accident. [Bug 2903011]
*/
if (result != TCL_ERROR && Destructing(oPtr)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"object deleted in constructor", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
result = TCL_ERROR;
}
if (result != TCL_OK) {
Tcl_DiscardInterpState(state);
/*
* Take care to not delete a deleted object; that would be bad. [Bug
* 2903011] Also take care to make sure that we have the name of the
* command before we delete it. [Bug 9dd1bd7a74]
*/
if (!Destructing(oPtr)) {
(void) TclOOObjectName(interp, oPtr);
Tcl_DeleteCommandFromToken(interp, oPtr->command);
}
/*
* This decrements the refcount of oPtr.
*/
|
| ︙ | ︙ | |||
1955 1956 1957 1958 1959 1960 1961 |
if (o2Ptr->mixins.num != 0) {
FOREACH(mixinPtr, o2Ptr->mixins) {
if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
TclOORemoveFromInstances(o2Ptr, mixinPtr);
}
TclOODecrRefCount(mixinPtr->thisPtr);
}
| | | 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 |
if (o2Ptr->mixins.num != 0) {
FOREACH(mixinPtr, o2Ptr->mixins) {
if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
TclOORemoveFromInstances(o2Ptr, mixinPtr);
}
TclOODecrRefCount(mixinPtr->thisPtr);
}
ckfree(o2Ptr->mixins.list);
}
DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
FOREACH(mixinPtr, o2Ptr->mixins) {
if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
TclOOAddToInstances(o2Ptr, mixinPtr);
}
|
| ︙ | ︙ | |||
2003 2004 2005 2006 2007 2008 2009 |
* Copy the object's flags to the new object, clearing those that must be
* kept object-local. The duplicate is never deleted at this point, nor is
* it the root of the object system or in the midst of processing a filter
* call.
*/
o2Ptr->flags = oPtr->flags & ~(
| | | 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 |
* Copy the object's flags to the new object, clearing those that must be
* kept object-local. The duplicate is never deleted at this point, nor is
* it the root of the object system or in the midst of processing a filter
* call.
*/
o2Ptr->flags = oPtr->flags & ~(
OBJECT_DESTRUCTING | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);
/*
* Copy the object's metadata.
*/
if (oPtr->metadataPtr != NULL) {
Tcl_ObjectMetadataType *metadataTypePtr;
|
| ︙ | ︙ | |||
2056 2057 2058 2059 2060 2061 2062 |
*/
FOREACH(superPtr, cls2Ptr->superclasses) {
TclOORemoveFromSubclasses(cls2Ptr, superPtr);
TclOODecrRefCount(superPtr->thisPtr);
}
if (cls2Ptr->superclasses.num) {
| | | | 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 |
*/
FOREACH(superPtr, cls2Ptr->superclasses) {
TclOORemoveFromSubclasses(cls2Ptr, superPtr);
TclOODecrRefCount(superPtr->thisPtr);
}
if (cls2Ptr->superclasses.num) {
cls2Ptr->superclasses.list = (Class **) ckrealloc(cls2Ptr->superclasses.list,
sizeof(Class *) * clsPtr->superclasses.num);
} else {
cls2Ptr->superclasses.list =
(Class **)ckalloc(sizeof(Class *) * clsPtr->superclasses.num);
}
memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list,
sizeof(Class *) * clsPtr->superclasses.num);
cls2Ptr->superclasses.num = clsPtr->superclasses.num;
FOREACH(superPtr, cls2Ptr->superclasses) {
TclOOAddToSubclasses(cls2Ptr, superPtr);
|
| ︙ | ︙ | |||
2111 2112 2113 2114 2115 2116 2117 |
*/
if (cls2Ptr->mixins.num != 0) {
FOREACH(mixinPtr, cls2Ptr->mixins) {
TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
| | | 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 |
*/
if (cls2Ptr->mixins.num != 0) {
FOREACH(mixinPtr, cls2Ptr->mixins) {
TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
ckfree(clsPtr->mixins.list);
}
DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
FOREACH(mixinPtr, cls2Ptr->mixins) {
TclOOAddToMixinSubs(cls2Ptr, mixinPtr);
/*
* For the copy just created in DUPLICATE.
|
| ︙ | ︙ | |||
2354 2355 2356 2357 2358 2359 2360 |
* Attach the metadata store if not done already.
*/
if (clsPtr->metadataPtr == NULL) {
if (metadata == NULL) {
return;
}
| | | 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 |
* Attach the metadata store if not done already.
*/
if (clsPtr->metadataPtr == NULL) {
if (metadata == NULL) {
return;
}
clsPtr->metadataPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS);
}
/*
* If the metadata is NULL, we're deleting the metadata for the type.
*/
|
| ︙ | ︙ | |||
2434 2435 2436 2437 2438 2439 2440 |
* Attach the metadata store if not done already.
*/
if (oPtr->metadataPtr == NULL) {
if (metadata == NULL) {
return;
}
| | | 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 |
* Attach the metadata store if not done already.
*/
if (oPtr->metadataPtr == NULL) {
if (metadata == NULL) {
return;
}
oPtr->metadataPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS);
}
/*
* If the metadata is NULL, we're deleting the metadata for the type.
*/
|
| ︙ | ︙ | |||
2493 2494 2495 2496 2497 2498 2499 |
static int
PublicNRObjectCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
| | | | 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 |
static int
PublicNRObjectCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
return TclOOObjectCmdCore((Object *)clientData, interp, objc, objv, PUBLIC_METHOD,
NULL);
}
int
TclOOPrivateObjectCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
return Tcl_NRCallObjProc(interp, PrivateNRObjectCmd,clientData,objc,objv);
}
static int
PrivateNRObjectCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
return TclOOObjectCmdCore((Object *)clientData, interp, objc, objv, 0, NULL);
}
int
TclOOInvokeObject(
Tcl_Interp *interp, /* Interpreter for commands, variables,
* results, error reporting, etc. */
Tcl_Object object, /* The object to invoke. */
|
| ︙ | ︙ | |||
2575 2576 2577 2578 2579 2580 2581 |
static int
MyClassNRObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
| | | 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 |
static int
MyClassNRObjCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *)clientData;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "methodName ?arg ...?");
return TCL_ERROR;
}
return TclOOObjectCmdCore(oPtr->selfCls->thisPtr, interp, objc, objv, 0,
NULL);
|
| ︙ | ︙ | |||
2634 2635 2636 2637 2638 2639 2640 |
/*
* Determine if we're in a context that can see the extra, private methods
* in this class.
*/
if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
| | | | 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 |
/*
* Determine if we're in a context that can see the extra, private methods
* in this class.
*/
if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
CallContext *callerContextPtr = (CallContext *)framePtr->clientData;
Method *callerMethodPtr =
callerContextPtr->callPtr->chain[callerContextPtr->index].mPtr;
if (callerMethodPtr->declaringObjectPtr) {
callerObjPtr = callerMethodPtr->declaringObjectPtr;
}
if (callerMethodPtr->declaringClassPtr) {
callerClsPtr = callerMethodPtr->declaringClassPtr;
}
}
/*
* Give plugged in code a chance to remap the method name.
*/
methodNamePtr = objv[1];
if (oPtr->mapMethodNameProc != NULL) {
Class **startClsPtr = &startCls;
Tcl_Obj *mappedMethodName = Tcl_DuplicateObj(methodNamePtr);
result = oPtr->mapMethodNameProc(interp, (Tcl_Object) oPtr,
(Tcl_Class *) startClsPtr, mappedMethodName);
if (result != TCL_OK) {
TclDecrRefCount(mappedMethodName);
if (result == TCL_BREAK) {
|
| ︙ | ︙ | |||
2711 2712 2713 2714 2715 2716 2717 |
* Check to see if we need to apply magical tricks to start part way
* through the call chain.
*/
if (startCls != NULL) {
for (; contextPtr->index < contextPtr->callPtr->numChain;
contextPtr->index++) {
| | | 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 |
* Check to see if we need to apply magical tricks to start part way
* through the call chain.
*/
if (startCls != NULL) {
for (; contextPtr->index < contextPtr->callPtr->numChain;
contextPtr->index++) {
struct MInvoke *miPtr =
&contextPtr->callPtr->chain[contextPtr->index];
if (miPtr->isFilter) {
continue;
}
if (miPtr->mPtr->declaringClassPtr == startCls) {
break;
|
| ︙ | ︙ | |||
2743 2744 2745 2746 2747 2748 2749 |
TclNRAddCallback(interp, FinalizeObjectCall, contextPtr, NULL,NULL,NULL);
return TclOOInvokeContext(contextPtr, interp, objc, objv);
}
static int
FinalizeObjectCall(
ClientData data[],
| | | | 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 |
TclNRAddCallback(interp, FinalizeObjectCall, contextPtr, NULL,NULL,NULL);
return TclOOInvokeContext(contextPtr, interp, objc, objv);
}
static int
FinalizeObjectCall(
ClientData data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
/*
* Dispose of the call chain, which drops the lock on the object's
* structure.
*/
TclOODeleteContext((CallContext *)data[0]);
return result;
}
/*
* ----------------------------------------------------------------------
*
* Tcl_ObjectContextInvokeNext, TclNRObjectContextInvokeNext, FinalizeNext --
|
| ︙ | ︙ | |||
2849 2850 2851 2852 2853 2854 2855 |
TclNRObjectContextInvokeNext(
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv,
int skip)
{
| | | 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 |
TclNRObjectContextInvokeNext(
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv,
int skip)
{
CallContext *contextPtr = (CallContext *) context;
if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) {
/*
* We're at the end of the chain; generate an error message unless the
* interpreter is being torn down, in which case we might be getting
* here because of methods/destructors doing a [next] (or equivalent)
* unexpectedly.
|
| ︙ | ︙ | |||
2904 2905 2906 2907 2908 2909 2910 |
return TclOOInvokeContext(contextPtr, interp, objc, objv);
}
static int
FinalizeNext(
ClientData data[],
| | | | 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 |
return TclOOInvokeContext(contextPtr, interp, objc, objv);
}
static int
FinalizeNext(
ClientData data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *)data[0];
/*
* Restore the call chain context index as we've finished the inner invoke
* and want to operate in the outer context again.
*/
contextPtr->index = PTR2INT(data[1]);
|
| ︙ | ︙ | |||
2948 2949 2950 2951 2952 2953 2954 |
}
if (cmdPtr->objProc != TclOOPublicObjectCmd) {
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (cmdPtr == NULL || cmdPtr->objProc != TclOOPublicObjectCmd) {
goto notAnObject;
}
}
| | | 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 |
}
if (cmdPtr->objProc != TclOOPublicObjectCmd) {
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (cmdPtr == NULL || cmdPtr->objProc != TclOOPublicObjectCmd) {
goto notAnObject;
}
}
return (Tcl_Object)cmdPtr->objClientData;
notAnObject:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s does not refer to an object", TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "OBJECT", TclGetString(objPtr),
NULL);
return NULL;
|
| ︙ | ︙ |
Changes to generic/tclOO.decls.
| ︙ | ︙ | |||
47 48 49 50 51 52 53 |
Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method)
}
declare 8 {
int Tcl_MethodIsPublic(Tcl_Method method)
}
declare 9 {
int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr,
| | | | | 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 |
Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method)
}
declare 8 {
int Tcl_MethodIsPublic(Tcl_Method method)
}
declare 9 {
int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr,
ClientData *clientDataPtr)
}
declare 10 {
Tcl_Obj *Tcl_MethodName(Tcl_Method method)
}
declare 11 {
Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object,
Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr,
ClientData clientData)
}
declare 12 {
Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr,
ClientData clientData)
}
declare 13 {
Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls,
const char *nameStr, const char *nsNameStr, int objc,
Tcl_Obj *const *objv, int skip)
}
declare 14 {
|
| ︙ | ︙ | |||
83 84 85 86 87 88 89 |
declare 17 {
Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context)
}
declare 18 {
int Tcl_ObjectContextSkippedArgs(Tcl_ObjectContext context)
}
declare 19 {
| | | | | | 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 |
declare 17 {
Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context)
}
declare 18 {
int Tcl_ObjectContextSkippedArgs(Tcl_ObjectContext context)
}
declare 19 {
ClientData Tcl_ClassGetMetadata(Tcl_Class clazz,
const Tcl_ObjectMetadataType *typePtr)
}
declare 20 {
void Tcl_ClassSetMetadata(Tcl_Class clazz,
const Tcl_ObjectMetadataType *typePtr, ClientData metadata)
}
declare 21 {
ClientData Tcl_ObjectGetMetadata(Tcl_Object object,
const Tcl_ObjectMetadataType *typePtr)
}
declare 22 {
void Tcl_ObjectSetMetadata(Tcl_Object object,
const Tcl_ObjectMetadataType *typePtr, ClientData metadata)
}
declare 23 {
int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp,
Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv,
int skip)
}
declare 24 {
|
| ︙ | ︙ | |||
140 141 142 143 144 145 146 |
declare 0 {
Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp)
}
declare 1 {
Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr,
int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
| | | | 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 |
declare 0 {
Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp)
}
declare 1 {
Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr,
int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
const Tcl_MethodType *typePtr, ClientData clientData,
Proc **procPtrPtr)
}
declare 2 {
Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, Class *clsPtr,
int flags, Tcl_Obj *nameObj, const char *namePtr,
Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr,
ClientData clientData, Proc **procPtrPtr)
}
declare 3 {
Method *TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr,
int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
ProcedureMethod **pmPtrPtr)
}
declare 4 {
|
| ︙ | ︙ | |||
178 179 180 181 182 183 184 |
Method *TclOONewForwardInstanceMethod(Tcl_Interp *interp, Object *oPtr,
int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj)
}
declare 9 {
Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp,
Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr,
TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc,
| | | | 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 |
Method *TclOONewForwardInstanceMethod(Tcl_Interp *interp, Object *oPtr,
int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj)
}
declare 9 {
Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp,
Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr,
TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc,
ClientData clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj,
Tcl_Obj *bodyObj, int flags, void **internalTokenPtr)
}
declare 10 {
Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr,
TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr,
ProcErrorProc *errProc, ClientData clientData, Tcl_Obj *nameObj,
Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags,
void **internalTokenPtr)
}
declare 11 {
int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object,
Tcl_Class startCls, int publicPrivate, int objc,
Tcl_Obj *const *objv)
|
| ︙ | ︙ |
Changes to generic/tclOO.h.
| ︙ | ︙ | |||
56 57 58 59 60 61 62 | /* * Public datatypes for callbacks and structures used in the TIP#257 (OO) * implementation. These are used to implement custom types of method calls * and to allow the attachment of arbitrary data to objects and classes. */ | | | | | | | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 | /* * Public datatypes for callbacks and structures used in the TIP#257 (OO) * implementation. These are used to implement custom types of method calls * and to allow the attachment of arbitrary data to objects and classes. */ typedef int (Tcl_MethodCallProc)(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv); typedef void (Tcl_MethodDeleteProc)(ClientData clientData); typedef int (Tcl_CloneProc)(Tcl_Interp *interp, ClientData oldClientData, ClientData *newClientData); typedef void (Tcl_ObjectMetadataDeleteProc)(ClientData clientData); typedef int (Tcl_ObjectMapMethodNameProc)(Tcl_Interp *interp, Tcl_Object object, Tcl_Class *startClsPtr, Tcl_Obj *methodNameObj); /* * The type of a method implementation. This describes how to call the method * implementation, how to delete it (when the object or class is deleted) and * how to create a clone of it (when the object or class is copied). |
| ︙ | ︙ | |||
91 92 93 94 95 96 97 | * data, or NULL if the type-specific data can * be copied directly. */ } Tcl_MethodType; /* * The correct value for the version field of the Tcl_MethodType structure. * This allows new versions of the structure to be introduced without breaking | | | 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | * data, or NULL if the type-specific data can * be copied directly. */ } Tcl_MethodType; /* * The correct value for the version field of the Tcl_MethodType structure. * This allows new versions of the structure to be introduced without breaking * binary compatability. */ #define TCL_OO_METHOD_VERSION_CURRENT 1 /* * Visibility constants for the flags parameter to Tcl_NewMethod and * Tcl_NewInstanceMethod. |
| ︙ | ︙ | |||
127 128 129 130 131 132 133 | * type-specific data can be copied * directly. */ } Tcl_ObjectMetadataType; /* * The correct value for the version field of the Tcl_ObjectMetadataType * structure. This allows new versions of the structure to be introduced | | | 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 | * type-specific data can be copied * directly. */ } Tcl_ObjectMetadataType; /* * The correct value for the version field of the Tcl_ObjectMetadataType * structure. This allows new versions of the structure to be introduced * without breaking binary compatability. */ #define TCL_OO_METADATA_VERSION_CURRENT 1 /* * Include all the public API, generated from tclOO.decls. */ |
| ︙ | ︙ |
Changes to generic/tclOOBasic.c.
| ︙ | ︙ | |||
51 52 53 54 55 56 57 |
static int
FinalizeConstruction(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 |
static int
FinalizeConstruction(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Object *oPtr = (Object *)data[0];
if (result != TCL_OK) {
return result;
}
Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* TclOO_Class_Constructor --
*
* Implementation for oo::class constructor.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Class_Constructor(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
Tcl_Obj **invoke, *nameObj;
|
| ︙ | ︙ | |||
104 105 106 107 108 109 110 |
TclGetString(nameObj), NULL, -1, NULL, -1);
Tcl_DecrRefCount(nameObj);
/*
* Delegate to [oo::define] to do the work.
*/
| | | 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 |
TclGetString(nameObj), NULL, -1, NULL, -1);
Tcl_DecrRefCount(nameObj);
/*
* Delegate to [oo::define] to do the work.
*/
invoke = (Tcl_Obj **)ckalloc(3 * sizeof(Tcl_Obj *));
invoke[0] = oPtr->fPtr->defineName;
invoke[1] = TclOOObjectName(interp, oPtr);
invoke[2] = objv[objc-1];
/*
* Must add references or errors in configuration script will cause
* trouble.
|
| ︙ | ︙ | |||
134 135 136 137 138 139 140 |
static int
DecrRefsPostClassConstructor(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | | | | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 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 |
static int
DecrRefsPostClassConstructor(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj **invoke = (Tcl_Obj **)data[0];
Object *oPtr = (Object *)data[1];
Tcl_InterpState saved;
int code;
TclDecrRefCount(invoke[0]);
TclDecrRefCount(invoke[1]);
TclDecrRefCount(invoke[2]);
invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1);
invoke[1] = TclOOObjectName(interp, oPtr);
Tcl_IncrRefCount(invoke[0]);
Tcl_IncrRefCount(invoke[1]);
saved = Tcl_SaveInterpState(interp, result);
code = Tcl_EvalObjv(interp, 2, invoke, 0);
TclDecrRefCount(invoke[0]);
TclDecrRefCount(invoke[1]);
ckfree(invoke);
if (code != TCL_OK) {
Tcl_DiscardInterpState(saved);
return code;
}
return Tcl_RestoreInterpState(interp, saved);
}
/*
* ----------------------------------------------------------------------
*
* TclOO_Class_Create --
*
* Implementation for oo::class->create method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Class_Create(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
const char *objName;
int len;
/*
* Sanity check; should not be possible to invoke this method on a
* non-class.
*/
if (oPtr->classPtr == NULL) {
|
| ︙ | ︙ | |||
204 205 206 207 208 209 210 |
*/
if (objc - Tcl_ObjectContextSkippedArgs(context) < 1) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"objectName ?arg ...?");
return TCL_ERROR;
}
| | | 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 |
*/
if (objc - Tcl_ObjectContextSkippedArgs(context) < 1) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"objectName ?arg ...?");
return TCL_ERROR;
}
objName = Tcl_GetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)], &len);
if (len == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"object name must not be empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
235 236 237 238 239 240 241 | * Implementation for oo::class->createWithNamespace method. * * ---------------------------------------------------------------------- */ int TclOO_Class_CreateNs( | | | | 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 |
* Implementation for oo::class->createWithNamespace method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Class_CreateNs(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
const char *objName, *nsName;
int len;
/*
* Sanity check; should not be possible to invoke this method on a
* non-class.
*/
if (oPtr->classPtr == NULL) {
|
| ︙ | ︙ | |||
269 270 271 272 273 274 275 |
*/
if (objc - Tcl_ObjectContextSkippedArgs(context) < 2) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"objectName namespaceName ?arg ...?");
return TCL_ERROR;
}
| | | | 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 |
*/
if (objc - Tcl_ObjectContextSkippedArgs(context) < 2) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"objectName namespaceName ?arg ...?");
return TCL_ERROR;
}
objName = Tcl_GetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)], &len);
if (len == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"object name must not be empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
return TCL_ERROR;
}
nsName = Tcl_GetStringFromObj(
objv[Tcl_ObjectContextSkippedArgs(context)+1], &len);
if (len == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"namespace name must not be empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
308 309 310 311 312 313 314 | * Implementation for oo::class->new method. * * ---------------------------------------------------------------------- */ int TclOO_Class_New( | | | 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 |
* Implementation for oo::class->new method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Class_New(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
|
| ︙ | ︙ | |||
352 353 354 355 356 357 358 | * Implementation for oo::object->destroy method. * * ---------------------------------------------------------------------- */ int TclOO_Object_Destroy( | | | 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 |
* Implementation for oo::object->destroy method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Object_Destroy(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
|
| ︙ | ︙ | |||
392 393 394 395 396 397 398 |
static int
AfterNRDestructor(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | | 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 |
static int
AfterNRDestructor(
ClientData data[],
Tcl_Interp *interp,
int result)
{
CallContext *contextPtr = (CallContext *)data[0];
if (contextPtr->oPtr->command) {
Tcl_DeleteCommandFromToken(interp, contextPtr->oPtr->command);
}
TclOODeleteContext(contextPtr);
return result;
}
/*
* ----------------------------------------------------------------------
*
* TclOO_Object_Eval --
*
* Implementation for oo::object->eval method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Object_Eval(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
CallContext *contextPtr = (CallContext *) context;
Tcl_Object object = Tcl_ObjectContextObject(context);
const int skip = Tcl_ObjectContextSkippedArgs(context);
CallFrame *framePtr, **framePtrPtr = &framePtr;
Tcl_Obj *scriptPtr;
CmdFrame *invoker;
if (objc-1 < skip) {
Tcl_WrongNumArgs(interp, skip, objv, "arg ?arg ...?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
479 480 481 482 483 484 485 |
static int
FinalizeEval(
ClientData data[],
Tcl_Interp *interp,
int result)
{
if (result == TCL_ERROR) {
| | | 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 |
static int
FinalizeEval(
ClientData data[],
Tcl_Interp *interp,
int result)
{
if (result == TCL_ERROR) {
Object *oPtr = (Object *)data[0];
const char *namePtr;
if (oPtr) {
namePtr = TclGetString(TclOOObjectName(interp, oPtr));
} else {
namePtr = "my";
}
|
| ︙ | ︙ | |||
514 515 516 517 518 519 520 | * just creates a suitable error message. * * ---------------------------------------------------------------------- */ int TclOO_Object_Unknown( | | | 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 |
* just creates a suitable error message.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Object_Unknown(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
CallContext *contextPtr = (CallContext *) context;
|
| ︙ | ︙ | |||
547 548 549 550 551 552 553 |
/*
* Determine if the calling context should know about extra private
* methods, and if so, which.
*/
if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
| | | 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 |
/*
* Determine if the calling context should know about extra private
* methods, and if so, which.
*/
if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
CallContext *callerContext = (CallContext *)framePtr->clientData;
Method *mPtr = callerContext->callPtr->chain[
callerContext->index].mPtr;
if (mPtr->declaringObjectPtr) {
if (oPtr == mPtr->declaringObjectPtr) {
callerObj = mPtr->declaringObjectPtr;
}
|
| ︙ | ︙ | |||
601 602 603 604 605 606 607 |
}
Tcl_AppendToObj(errorMsg, methodNames[i], -1);
}
if (i) {
Tcl_AppendToObj(errorMsg, " or ", -1);
}
Tcl_AppendToObj(errorMsg, methodNames[i], -1);
| | | | 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 |
}
Tcl_AppendToObj(errorMsg, methodNames[i], -1);
}
if (i) {
Tcl_AppendToObj(errorMsg, " or ", -1);
}
Tcl_AppendToObj(errorMsg, methodNames[i], -1);
ckfree(methodNames);
Tcl_SetObjResult(interp, errorMsg);
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[skip]), NULL);
return TCL_ERROR;
}
/*
* ----------------------------------------------------------------------
*
* TclOO_Object_LinkVar --
*
* Implementation of oo::object->variable method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Object_LinkVar(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Interp *iPtr = (Interp *) interp;
|
| ︙ | ︙ | |||
722 723 724 725 726 727 728 | * Implementation of the oo::object->varname method. * * ---------------------------------------------------------------------- */ int TclOO_Object_VarName( | | | | 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 |
* Implementation of the oo::object->varname method.
*
* ----------------------------------------------------------------------
*/
int
TclOO_Object_VarName(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Var *varPtr, *aryVar;
Tcl_Obj *varNamePtr, *argPtr;
CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
const char *arg;
if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"varName");
return TCL_ERROR;
}
argPtr = objv[objc-1];
arg = Tcl_GetString(argPtr);
/*
* Convert the variable name to fully-qualified form if it wasn't already.
* This has to be done prior to lookup because we can run into problems
* with resolvers otherwise. [Bug 3603695]
*
* We still need to do the lookup; the variable could be linked to another
|
| ︙ | ︙ | |||
769 770 771 772 773 774 775 |
* This is a little tricky as we need to check through the inheritance
* hierarchy when the method was declared by a class to see if the
* current object is an instance of that class.
*/
if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
| | | | | | | 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 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 |
* This is a little tricky as we need to check through the inheritance
* hierarchy when the method was declared by a class to see if the
* current object is an instance of that class.
*/
if (framePtr->isProcCallFrame & FRAME_IS_METHOD) {
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
CallContext *callerContext = (CallContext *)framePtr->clientData;
Method *mPtr = callerContext->callPtr->chain[
callerContext->index].mPtr;
PrivateVariableMapping *pvPtr;
int i;
if (mPtr->declaringObjectPtr == oPtr) {
FOREACH_STRUCT(pvPtr, oPtr->privateVariables) {
if (!strcmp(Tcl_GetString(pvPtr->variableObj),
Tcl_GetString(argPtr))) {
argPtr = pvPtr->fullNameObj;
break;
}
}
} else if (mPtr->declaringClassPtr &&
mPtr->declaringClassPtr->privateVariables.num) {
Class *clsPtr = mPtr->declaringClassPtr;
int isInstance = TclOOIsReachable(clsPtr, oPtr->selfCls);
Class *mixinCls;
if (!isInstance) {
FOREACH(mixinCls, oPtr->mixins) {
if (TclOOIsReachable(clsPtr, mixinCls)) {
isInstance = 1;
break;
}
}
}
if (isInstance) {
FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) {
if (!strcmp(Tcl_GetString(pvPtr->variableObj),
Tcl_GetString(argPtr))) {
argPtr = pvPtr->fullNameObj;
break;
}
}
}
}
}
|
| ︙ | ︙ | |||
860 861 862 863 864 865 866 | * method. * * ---------------------------------------------------------------------- */ int TclOONextObjCmd( | | | 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 |
* method.
*
* ----------------------------------------------------------------------
*/
int
TclOONextObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
CallFrame *framePtr = iPtr->varFramePtr;
Tcl_ObjectContext context;
|
| ︙ | ︙ | |||
882 883 884 885 886 887 888 |
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
| | | | 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 |
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
context = (Tcl_ObjectContext)framePtr->clientData;
/*
* Invoke the (advanced) method call context in the caller context. Note
* that this is like [uplevel 1] and not [eval].
*/
TclNRAddCallback(interp, NextRestoreFrame, framePtr, NULL,NULL,NULL);
iPtr->varFramePtr = framePtr->callerVarPtr;
return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1);
}
int
TclOONextToObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Interp *iPtr = (Interp *) interp;
CallFrame *framePtr = iPtr->varFramePtr;
Class *classPtr;
|
| ︙ | ︙ | |||
922 923 924 925 926 927 928 |
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
| | | 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 |
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
contextPtr = (CallContext *)framePtr->clientData;
/*
* Sanity check the arguments; we need the first one to refer to a class.
*/
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "class ?arg...?");
|
| ︙ | ︙ | |||
1007 1008 1009 1010 1011 1012 1013 |
static int
NextRestoreFrame(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | | | 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 |
static int
NextRestoreFrame(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
CallContext *contextPtr = (CallContext *)data[1];
iPtr->varFramePtr = (CallFrame *)data[0];
if (contextPtr != NULL) {
contextPtr->index = PTR2INT(data[2]);
}
return result;
}
/*
* ----------------------------------------------------------------------
*
* TclOOSelfObjCmd --
*
* Implementation of the [self] command, which provides introspection of
* the call context.
*
* ----------------------------------------------------------------------
*/
int
TclOOSelfObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
static const char *const subcmds[] = {
"call", "caller", "class", "filter", "method", "namespace", "next",
"object", "target", NULL
|
| ︙ | ︙ | |||
1063 1064 1065 1066 1067 1068 1069 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
| | | 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s may only be called from inside a method",
TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
}
contextPtr = (CallContext*)framePtr->clientData;
/*
* Now we do "conventional" argument parsing for a while. Note that no
* subcommand takes arguments.
*/
if (objc > 2) {
|
| ︙ | ︙ | |||
1118 1119 1120 1121 1122 1123 1124 |
case SELF_FILTER:
if (!CurrentlyInvoked(contextPtr).isFilter) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"not inside a filtering context", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
return TCL_ERROR;
} else {
| | | 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 |
case SELF_FILTER:
if (!CurrentlyInvoked(contextPtr).isFilter) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"not inside a filtering context", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "UNMATCHED_CONTEXT", NULL);
return TCL_ERROR;
} else {
struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
Object *oPtr;
const char *type;
if (miPtr->filterDeclarer != NULL) {
oPtr = miPtr->filterDeclarer->thisPtr;
type = "class";
} else {
|
| ︙ | ︙ | |||
1144 1145 1146 1147 1148 1149 1150 |
if ((framePtr->callerVarPtr == NULL) ||
!(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"caller is not an object", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
} else {
| | | 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 |
if ((framePtr->callerVarPtr == NULL) ||
!(framePtr->callerVarPtr->isProcCallFrame & FRAME_IS_METHOD)){
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"caller is not an object", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
return TCL_ERROR;
} else {
CallContext *callerPtr = (CallContext *)framePtr->callerVarPtr->clientData;
Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
Object *declarerPtr;
if (mPtr->declaringClassPtr != NULL) {
declarerPtr = mPtr->declaringClassPtr->thisPtr;
} else if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
|
| ︙ | ︙ | |||
1266 1267 1268 1269 1270 1271 1272 | * process. * * ---------------------------------------------------------------------- */ int TclOOCopyObjectCmd( | | | 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 |
* process.
*
* ----------------------------------------------------------------------
*/
int
TclOOCopyObjectCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Object oPtr, o2Ptr;
if (objc < 2 || objc > 4) {
|
| ︙ | ︙ |
Changes to generic/tclOOCall.c.
| ︙ | ︙ | |||
164 165 166 167 168 169 170 |
* ----------------------------------------------------------------------
*/
void
TclOODeleteContext(
CallContext *contextPtr)
{
| | | 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 |
* ----------------------------------------------------------------------
*/
void
TclOODeleteContext(
CallContext *contextPtr)
{
Object *oPtr = contextPtr->oPtr;
TclOODeleteChain(contextPtr->callPtr);
if (oPtr != NULL) {
TclStackFree(oPtr->fPtr->interp, contextPtr);
/*
* Corresponding AddRef() in TclOO.c/TclOOObjectCmdCore
|
| ︙ | ︙ | |||
201 202 203 204 205 206 207 |
FOREACH_HASH_VALUE(callPtr, tablePtr) {
if (callPtr) {
TclOODeleteChain(callPtr);
}
}
Tcl_DeleteHashTable(tablePtr);
| | | | | 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 |
FOREACH_HASH_VALUE(callPtr, tablePtr) {
if (callPtr) {
TclOODeleteChain(callPtr);
}
}
Tcl_DeleteHashTable(tablePtr);
ckfree(tablePtr);
}
/*
* ----------------------------------------------------------------------
*
* TclOODeleteChain --
*
* Destroys a method call-chain.
*
* ----------------------------------------------------------------------
*/
void
TclOODeleteChain(
CallChain *callPtr)
{
if (callPtr == NULL || callPtr->refCount-- > 1) {
return;
}
if (callPtr->chain != callPtr->staticChain) {
ckfree(callPtr->chain);
}
ckfree(callPtr);
}
/*
* ----------------------------------------------------------------------
*
* TclOOStashContext --
*
|
| ︙ | ︙ | |||
276 277 278 279 280 281 282 |
static void
DupMethodNameRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dstPtr)
{
StashCallChain(dstPtr,
| | | | 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 |
static void
DupMethodNameRep(
Tcl_Obj *srcPtr,
Tcl_Obj *dstPtr)
{
StashCallChain(dstPtr,
(CallChain *)TclFetchIntRep(srcPtr, &methodNameType)->twoPtrValue.ptr1);
}
static void
FreeMethodNameRep(
Tcl_Obj *objPtr)
{
TclOODeleteChain(
(CallChain *)TclFetchIntRep(objPtr, &methodNameType)->twoPtrValue.ptr1);
}
/*
* ----------------------------------------------------------------------
*
* TclOOInvokeContext --
*
|
| ︙ | ︙ | |||
310 311 312 313 314 315 316 |
Tcl_Interp *interp, /* Interpreter for error reporting, and many
* other sorts of context handling (e.g.,
* commands, variables) depending on method
* implementation. */
int objc, /* The number of arguments. */
Tcl_Obj *const objv[]) /* The arguments as actually seen. */
{
| | | 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 |
Tcl_Interp *interp, /* Interpreter for error reporting, and many
* other sorts of context handling (e.g.,
* commands, variables) depending on method
* implementation. */
int objc, /* The number of arguments. */
Tcl_Obj *const objv[]) /* The arguments as actually seen. */
{
CallContext *const contextPtr = (CallContext *)clientData;
Method *const mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
const int isFilter =
contextPtr->callPtr->chain[contextPtr->index].isFilter;
/*
* If this is the first step along the chain, we preserve the method
* entries in the chain so that they do not get deleted out from under our
|
| ︙ | ︙ | |||
372 373 374 375 376 377 378 |
return mPtr->typePtr->callProc(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, objc, objv);
}
static int
SetFilterFlags(
ClientData data[],
| | | | | | | | 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 |
return mPtr->typePtr->callProc(mPtr->clientData, interp,
(Tcl_ObjectContext) contextPtr, objc, objv);
}
static int
SetFilterFlags(
ClientData data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *)data[0];
contextPtr->oPtr->flags |= FILTER_HANDLING;
return result;
}
static int
ResetFilterFlags(
ClientData data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *)data[0];
contextPtr->oPtr->flags &= ~FILTER_HANDLING;
return result;
}
static int
FinalizeMethodRefs(
ClientData data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
CallContext *contextPtr = (CallContext *)data[0];
int i;
for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) {
TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr);
}
return result;
}
|
| ︙ | ︙ | |||
585 586 587 588 589 590 591 |
Tcl_HashTable *namesPtr, /* The table of names; unsorted, but contains
* whether the names are wanted and under what
* circumstances. */
int flags, /* Whether we are looking for unexported
* methods. Full private methods are handled
* on insertion to the table. */
const char ***stringsPtr) /* Where to store the sorted list of strings
| | | | | 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 |
Tcl_HashTable *namesPtr, /* The table of names; unsorted, but contains
* whether the names are wanted and under what
* circumstances. */
int flags, /* Whether we are looking for unexported
* methods. Full private methods are handled
* on insertion to the table. */
const char ***stringsPtr) /* Where to store the sorted list of strings
* that we produce. ckalloced() */
{
const char **strings;
FOREACH_HASH_DECLS;
Tcl_Obj *namePtr;
void *isWanted;
int i = 0;
/*
* See how many (visible) method names there are. If none, we do not (and
* should not) try to sort the list of them.
*/
if (namesPtr->numEntries == 0) {
*stringsPtr = NULL;
return 0;
}
/*
* We need to build the list of methods to sort. We will be using qsort()
* for this, because it is very unlikely that the list will be heavily
* sorted when it is long enough to matter.
*/
strings = (const char **)ckalloc(sizeof(char *) * namesPtr->numEntries);
FOREACH_HASH(namePtr, isWanted, namesPtr) {
if (!WANT_PUBLIC(flags) || (PTR2INT(isWanted) & IN_LIST)) {
if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
continue;
}
strings[i++] = TclGetString(namePtr);
}
|
| ︙ | ︙ | |||
631 632 633 634 635 636 637 |
if (i > 0) {
if (i > 1) {
qsort((void *) strings, i, sizeof(char *), CmpStr);
}
*stringsPtr = strings;
} else {
| | | 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 |
if (i > 0) {
if (i > 1) {
qsort((void *) strings, i, sizeof(char *), CmpStr);
}
*stringsPtr = strings;
} else {
ckfree(strings);
*stringsPtr = NULL;
}
return i;
}
/*
* Comparator for SortMethodNames
|
| ︙ | ︙ | |||
831 832 833 834 835 836 837 |
Tcl_HashEntry *hPtr;
Method *mPtr;
int donePrivate = 0;
if (oPtr->methodsPtr) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodName);
if (hPtr != NULL) {
| | | 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 |
Tcl_HashEntry *hPtr;
Method *mPtr;
int donePrivate = 0;
if (oPtr->methodsPtr) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodName);
if (hPtr != NULL) {
mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (IS_PRIVATE(mPtr)) {
AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags);
donePrivate = 1;
}
}
}
return donePrivate;
|
| ︙ | ︙ | |||
881 882 883 884 885 886 887 |
Tcl_HashEntry *hPtr;
Method *mPtr;
if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj);
if (hPtr != NULL) {
| | | 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 |
Tcl_HashEntry *hPtr;
Method *mPtr;
if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj);
if (hPtr != NULL) {
mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (!IS_PRIVATE(mPtr)) {
if (WANT_PUBLIC(flags)) {
if (!IS_PUBLIC(mPtr)) {
blockedUnexported = 1;
} else {
flags |= DEFINITE_PUBLIC;
}
|
| ︙ | ︙ | |||
911 912 913 914 915 916 917 |
foundPrivate |= AddSimpleClassChainToCallContext(mixinPtr,
methodNameObj, cbPtr, doneFilters,
flags | TRAVERSED_MIXIN, filterDecl);
}
if (oPtr->methodsPtr && !blockedUnexported) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj);
if (hPtr != NULL) {
| | | 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 |
foundPrivate |= AddSimpleClassChainToCallContext(mixinPtr,
methodNameObj, cbPtr, doneFilters,
flags | TRAVERSED_MIXIN, filterDecl);
}
if (oPtr->methodsPtr && !blockedUnexported) {
hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj);
if (hPtr != NULL) {
mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (!IS_PRIVATE(mPtr)) {
AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
flags);
}
}
}
}
|
| ︙ | ︙ | |||
964 965 966 967 968 969 970 |
int flags) /* Used to check if we're mixin-consistent
* only. Mixin-consistent means that either
* we're looking to add things from a mixin
* and we have passed a mixin, or we're not
* looking to add things from a mixin and have
* not passed a mixin. */
{
| | | 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 |
int flags) /* Used to check if we're mixin-consistent
* only. Mixin-consistent means that either
* we're looking to add things from a mixin
* and we have passed a mixin, or we're not
* looking to add things from a mixin and have
* not passed a mixin. */
{
CallChain *callPtr = cbPtr->callChainPtr;
int i;
/*
* Return if this is just an entry used to record whether this is a public
* method. If so, there's nothing real to call and so nothing to add to
* the call chain.
*
|
| ︙ | ︙ | |||
1033 1034 1035 1036 1037 1038 1039 |
* Need to really add the method. This is made a bit more complex by the
* fact that we are using some "static" space initially, and only start
* realloc-ing if the chain gets long.
*/
if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) {
callPtr->chain =
| | | | 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 |
* Need to really add the method. This is made a bit more complex by the
* fact that we are using some "static" space initially, and only start
* realloc-ing if the chain gets long.
*/
if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) {
callPtr->chain =
(struct MInvoke *)ckalloc(sizeof(struct MInvoke) * (callPtr->numChain + 1));
memcpy(callPtr->chain, callPtr->staticChain,
sizeof(struct MInvoke) * callPtr->numChain);
} else if (callPtr->numChain > CALL_CHAIN_STATIC_SIZE) {
callPtr->chain = (struct MInvoke *)ckrealloc(callPtr->chain,
sizeof(struct MInvoke) * (callPtr->numChain + 1));
}
callPtr->chain[i].mPtr = mPtr;
callPtr->chain[i].isFilter = (doneFilters != NULL);
callPtr->chain[i].filterDeclarer = filterDecl;
callPtr->numChain++;
}
|
| ︙ | ︙ | |||
1189 1190 1191 1192 1193 1194 1195 |
* the object, and in the class).
*/
const Tcl_ObjIntRep *irPtr;
const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
if ((irPtr = TclFetchIntRep(cacheInThisObj, &methodNameType))) {
| | | 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 |
* the object, and in the class).
*/
const Tcl_ObjIntRep *irPtr;
const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
if ((irPtr = TclFetchIntRep(cacheInThisObj, &methodNameType))) {
callPtr = (CallChain *)irPtr->twoPtrValue.ptr1;
if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
callPtr->refCount++;
goto returnContext;
}
Tcl_StoreIntRep(cacheInThisObj, &methodNameType, NULL);
}
|
| ︙ | ︙ | |||
1214 1215 1216 1217 1218 1219 1220 |
(char *) methodNameObj);
} else {
hPtr = NULL;
}
}
if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
| | | | | 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 |
(char *) methodNameObj);
} else {
hPtr = NULL;
}
}
if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
callPtr = (CallChain *)Tcl_GetHashValue(hPtr);
if (IsStillValid(callPtr, oPtr, flags, reuseMask)) {
callPtr->refCount++;
goto returnContext;
}
Tcl_SetHashValue(hPtr, NULL);
TclOODeleteChain(callPtr);
}
doFilters = 1;
}
callPtr = (CallChain *)ckalloc(sizeof(CallChain));
InitCallChain(callPtr, oPtr, flags);
cb.callChainPtr = callPtr;
cb.filterLength = 0;
cb.oPtr = oPtr;
/*
* If we're working with a forced use of unknown, do that now.
*/
if (flags & FORCE_UNKNOWN) {
AddSimpleChainToCallContext(oPtr, NULL,
oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS,
NULL);
AddSimpleChainToCallContext(oPtr, NULL,
oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL);
callPtr->flags |= OO_UNKNOWN_METHOD;
callPtr->epoch = -1;
if (callPtr->numChain == 0) {
TclOODeleteChain(callPtr);
return NULL;
}
goto returnContext;
}
|
| ︙ | ︙ | |||
1321 1322 1323 1324 1325 1326 1327 | } AddSimpleChainToCallContext(oPtr, NULL, oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, NULL); AddSimpleChainToCallContext(oPtr, NULL, oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; | | | | | 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 |
}
AddSimpleChainToCallContext(oPtr, NULL,
oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS,
NULL);
AddSimpleChainToCallContext(oPtr, NULL,
oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL);
callPtr->flags |= OO_UNKNOWN_METHOD;
callPtr->epoch = -1;
if (count == callPtr->numChain) {
TclOODeleteChain(callPtr);
return NULL;
}
} else if (doFilters && !donePrivate) {
if (hPtr == NULL) {
if (oPtr->flags & USE_CLASS_CACHE) {
if (oPtr->selfCls->classChainCache == NULL) {
oPtr->selfCls->classChainCache =
(Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->selfCls->classChainCache);
}
hPtr = Tcl_CreateHashEntry(oPtr->selfCls->classChainCache,
(char *) methodNameObj, &i);
} else {
if (oPtr->chainCache == NULL) {
oPtr->chainCache = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->chainCache);
}
hPtr = Tcl_CreateHashEntry(oPtr->chainCache,
(char *) methodNameObj, &i);
}
}
|
| ︙ | ︙ | |||
1365 1366 1367 1368 1369 1370 1371 |
TclOODeleteChain(oPtr->selfCls->destructorChainPtr);
}
oPtr->selfCls->destructorChainPtr = callPtr;
callPtr->refCount++;
}
returnContext:
| | | 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 |
TclOODeleteChain(oPtr->selfCls->destructorChainPtr);
}
oPtr->selfCls->destructorChainPtr = callPtr;
callPtr->refCount++;
}
returnContext:
contextPtr = (CallContext *)TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext));
contextPtr->oPtr = oPtr;
/*
* Corresponding TclOODecrRefCount() in TclOODeleteContext
*/
AddRef(oPtr);
|
| ︙ | ︙ | |||
1434 1435 1436 1437 1438 1439 1440 |
if (clsPtr->classChainCache != NULL) {
hPtr = Tcl_FindHashEntry(clsPtr->classChainCache,
(char *) methodNameObj);
if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
| | | | 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 |
if (clsPtr->classChainCache != NULL) {
hPtr = Tcl_FindHashEntry(clsPtr->classChainCache,
(char *) methodNameObj);
if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD);
callPtr = (CallChain *)Tcl_GetHashValue(hPtr);
if (IsStillValid(callPtr, &obj, flags, reuseMask)) {
callPtr->refCount++;
return callPtr;
}
Tcl_SetHashValue(hPtr, NULL);
TclOODeleteChain(callPtr);
}
} else {
hPtr = NULL;
}
callPtr = (CallChain *)ckalloc(sizeof(CallChain));
memset(callPtr, 0, sizeof(CallChain));
callPtr->flags = flags & (PUBLIC_METHOD|PRIVATE_METHOD|FILTER_HANDLING);
callPtr->epoch = fPtr->epoch;
callPtr->objectCreationEpoch = fPtr->tsdPtr->nsCount;
callPtr->objectEpoch = clsPtr->thisPtr->epoch;
callPtr->refCount = 1;
callPtr->chain = callPtr->staticChain;
|
| ︙ | ︙ | |||
1493 1494 1495 1496 1497 1498 1499 |
if (count == callPtr->numChain) {
AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj,
&cb, NULL, BUILDING_MIXINS, NULL);
AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj,
&cb, NULL, 0, NULL);
callPtr->flags |= OO_UNKNOWN_METHOD;
| | | | 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 |
if (count == callPtr->numChain) {
AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj,
&cb, NULL, BUILDING_MIXINS, NULL);
AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj,
&cb, NULL, 0, NULL);
callPtr->flags |= OO_UNKNOWN_METHOD;
callPtr->epoch = -1;
if (count == callPtr->numChain) {
TclOODeleteChain(callPtr);
return NULL;
}
} else {
if (hPtr == NULL) {
if (clsPtr->classChainCache == NULL) {
clsPtr->classChainCache = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(clsPtr->classChainCache);
}
hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache,
(char *) methodNameObj, &i);
}
callPtr->refCount++;
Tcl_SetHashValue(hPtr, callPtr);
|
| ︙ | ︙ | |||
1649 1650 1651 1652 1653 1654 1655 |
filterDecl)) {
return 1;
}
}
if (classPtr == contextCls) {
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
| | | > | 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 |
filterDecl)) {
return 1;
}
}
if (classPtr == contextCls) {
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
methodName);
if (hPtr != NULL) {
Method *mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (IS_PRIVATE(mPtr)) {
AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl,
flags);
return 1;
}
}
}
switch (classPtr->superclasses.num) {
case 1:
classPtr = classPtr->superclasses.list[0];
goto tailRecurse;
default:
FOREACH(superPtr, classPtr->superclasses) {
if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls,
methodName, cbPtr, doneFilters, flags, filterDecl)) {
return 1;
}
}
/* FALLTHRU */
case 0:
return 0;
}
}
/*
* ----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1736 1737 1738 1739 1740 1741 1742 |
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
(char *) methodNameObj);
if (classPtr->flags & HAS_PRIVATE_METHODS) {
privateDanger |= 1;
}
if (hPtr != NULL) {
| | | 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 |
Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods,
(char *) methodNameObj);
if (classPtr->flags & HAS_PRIVATE_METHODS) {
privateDanger |= 1;
}
if (hPtr != NULL) {
Method *mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (!IS_PRIVATE(mPtr)) {
if (!(flags & KNOWN_STATE)) {
if (flags & PUBLIC_METHOD) {
if (!IS_PUBLIC(mPtr)) {
return privateDanger;
}
|
| ︙ | ︙ | |||
1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 |
classPtr = classPtr->superclasses.list[0];
goto tailRecurse;
default:
FOREACH(superPtr, classPtr->superclasses) {
privateDanger |= AddSimpleClassChainToCallContext(superPtr,
methodNameObj, cbPtr, doneFilters, flags, filterDecl);
}
case 0:
return privateDanger;
}
}
/*
* ----------------------------------------------------------------------
| > | 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 |
classPtr = classPtr->superclasses.list[0];
goto tailRecurse;
default:
FOREACH(superPtr, classPtr->superclasses) {
privateDanger |= AddSimpleClassChainToCallContext(superPtr,
methodNameObj, cbPtr, doneFilters, flags, filterDecl);
}
/* FALLTHRU */
case 0:
return privateDanger;
}
}
/*
* ----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1815 1816 1817 1818 1819 1820 1821 |
* extra argument when handled by some method types, and "filter" is
* special because it's a filter method). The second word is the name of
* the method in question (which differs for "unknown" and "filter" types)
* and the third word is the full name of the class that declares the
* method (or "object" if it is declared on the instance).
*/
| | | 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 |
* extra argument when handled by some method types, and "filter" is
* special because it's a filter method). The second word is the name of
* the method in question (which differs for "unknown" and "filter" types)
* and the third word is the full name of the class that declares the
* method (or "object" if it is declared on the instance).
*/
objv = (Tcl_Obj **)TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
for (i = 0 ; i < callPtr->numChain ; i++) {
struct MInvoke *miPtr = &callPtr->chain[i];
descObjs[0] =
miPtr->isFilter ? filterLiteral :
callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj :
IS_PRIVATE(miPtr->mPtr) ? privateLiteral :
|
| ︙ | ︙ | |||
1918 1919 1920 1921 1922 1923 1924 |
if (TclGetNamespaceFromObj(interp, entryPtr->namespaceName,
&nsPtr) == TCL_OK) {
break;
}
Tcl_ResetResult(interp);
}
if (define.list != staticSpace) {
| | | 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 |
if (TclGetNamespaceFromObj(interp, entryPtr->namespaceName,
&nsPtr) == TCL_OK) {
break;
}
Tcl_ResetResult(interp);
}
if (define.list != staticSpace) {
ckfree(define.list);
}
return nsPtr;
}
/*
* ----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2083 2084 2085 2086 2087 2088 2089 |
if (definePtr->num == definePtr->size) {
definePtr->size *= 2;
if (definePtr->num == DEFINE_CHAIN_STATIC_SIZE) {
DefineEntry *staticList = definePtr->list;
definePtr->list =
| | | | 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 |
if (definePtr->num == definePtr->size) {
definePtr->size *= 2;
if (definePtr->num == DEFINE_CHAIN_STATIC_SIZE) {
DefineEntry *staticList = definePtr->list;
definePtr->list =
(DefineEntry *)ckalloc(sizeof(DefineEntry) * definePtr->size);
memcpy(definePtr->list, staticList,
sizeof(DefineEntry) * definePtr->num);
} else {
definePtr->list = (DefineEntry *)ckrealloc(definePtr->list,
sizeof(DefineEntry) * definePtr->size);
}
}
definePtr->list[i].definerCls = definerCls;
definePtr->list[i].namespaceName = namespaceName;
definePtr->num++;
}
|
| ︙ | ︙ |
Changes to generic/tclOODecls.h.
| ︙ | ︙ | |||
49 50 51 52 53 54 55 | /* 7 */ TCLAPI Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); /* 8 */ TCLAPI int Tcl_MethodIsPublic(Tcl_Method method); /* 9 */ TCLAPI int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, | | | | | | | | | 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 | /* 7 */ TCLAPI Tcl_Object Tcl_MethodDeclarerObject(Tcl_Method method); /* 8 */ TCLAPI int Tcl_MethodIsPublic(Tcl_Method method); /* 9 */ TCLAPI int Tcl_MethodIsType(Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 10 */ TCLAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ TCLAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ TCLAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 13 */ TCLAPI Tcl_Object Tcl_NewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 14 */ TCLAPI int Tcl_ObjectDeleted(Tcl_Object object); /* 15 */ TCLAPI int Tcl_ObjectContextIsFiltering( Tcl_ObjectContext context); /* 16 */ TCLAPI Tcl_Method Tcl_ObjectContextMethod(Tcl_ObjectContext context); /* 17 */ TCLAPI Tcl_Object Tcl_ObjectContextObject(Tcl_ObjectContext context); /* 18 */ TCLAPI int Tcl_ObjectContextSkippedArgs( Tcl_ObjectContext context); /* 19 */ TCLAPI ClientData Tcl_ClassGetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 20 */ TCLAPI void Tcl_ClassSetMetadata(Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 21 */ TCLAPI ClientData Tcl_ObjectGetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 22 */ TCLAPI void Tcl_ObjectSetMetadata(Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 23 */ TCLAPI int Tcl_ObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 24 */ TCLAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper( Tcl_Object object); |
| ︙ | ︙ | |||
132 133 134 135 136 137 138 |
Tcl_Class (*tcl_GetObjectAsClass) (Tcl_Object object); /* 2 */
Tcl_Command (*tcl_GetObjectCommand) (Tcl_Object object); /* 3 */
Tcl_Object (*tcl_GetObjectFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 4 */
Tcl_Namespace * (*tcl_GetObjectNamespace) (Tcl_Object object); /* 5 */
Tcl_Class (*tcl_MethodDeclarerClass) (Tcl_Method method); /* 6 */
Tcl_Object (*tcl_MethodDeclarerObject) (Tcl_Method method); /* 7 */
int (*tcl_MethodIsPublic) (Tcl_Method method); /* 8 */
| | | | | | | | | 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 |
Tcl_Class (*tcl_GetObjectAsClass) (Tcl_Object object); /* 2 */
Tcl_Command (*tcl_GetObjectCommand) (Tcl_Object object); /* 3 */
Tcl_Object (*tcl_GetObjectFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 4 */
Tcl_Namespace * (*tcl_GetObjectNamespace) (Tcl_Object object); /* 5 */
Tcl_Class (*tcl_MethodDeclarerClass) (Tcl_Method method); /* 6 */
Tcl_Object (*tcl_MethodDeclarerObject) (Tcl_Method method); /* 7 */
int (*tcl_MethodIsPublic) (Tcl_Method method); /* 8 */
int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 9 */
Tcl_Obj * (*tcl_MethodName) (Tcl_Method method); /* 10 */
Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */
Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */
Tcl_Object (*tcl_NewObjectInstance) (Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 13 */
int (*tcl_ObjectDeleted) (Tcl_Object object); /* 14 */
int (*tcl_ObjectContextIsFiltering) (Tcl_ObjectContext context); /* 15 */
Tcl_Method (*tcl_ObjectContextMethod) (Tcl_ObjectContext context); /* 16 */
Tcl_Object (*tcl_ObjectContextObject) (Tcl_ObjectContext context); /* 17 */
int (*tcl_ObjectContextSkippedArgs) (Tcl_ObjectContext context); /* 18 */
ClientData (*tcl_ClassGetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr); /* 19 */
void (*tcl_ClassSetMetadata) (Tcl_Class clazz, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 20 */
ClientData (*tcl_ObjectGetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr); /* 21 */
void (*tcl_ObjectSetMetadata) (Tcl_Object object, const Tcl_ObjectMetadataType *typePtr, ClientData metadata); /* 22 */
int (*tcl_ObjectContextInvokeNext) (Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); /* 23 */
Tcl_ObjectMapMethodNameProc * (*tcl_ObjectGetMethodNameMapper) (Tcl_Object object); /* 24 */
void (*tcl_ObjectSetMethodNameMapper) (Tcl_Object object, Tcl_ObjectMapMethodNameProc *mapMethodNameProc); /* 25 */
void (*tcl_ClassSetConstructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 26 */
void (*tcl_ClassSetDestructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */
Tcl_Obj * (*tcl_GetObjectName) (Tcl_Interp *interp, Tcl_Object object); /* 28 */
int (*tcl_MethodIsPrivate) (Tcl_Method method); /* 29 */
|
| ︙ | ︙ |
Changes to generic/tclOODefineCmds.c.
| ︙ | ︙ | |||
263 264 265 266 267 268 269 |
}
if (numFilters == 0) {
/*
* No list of filters was supplied, so we're deleting filters.
*/
| | | | | 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 |
}
if (numFilters == 0) {
/*
* No list of filters was supplied, so we're deleting filters.
*/
ckfree(oPtr->filters.list);
oPtr->filters.list = NULL;
oPtr->filters.num = 0;
RecomputeClassCacheFlag(oPtr);
} else {
/*
* We've got a list of filters, so we're creating filters.
*/
Tcl_Obj **filtersList;
int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */
if (oPtr->filters.num == 0) {
filtersList = (Tcl_Obj **)ckalloc(size);
} else {
filtersList = (Tcl_Obj **)ckrealloc(oPtr->filters.list, size);
}
for (i = 0 ; i < numFilters ; i++) {
filtersList[i] = filters[i];
Tcl_IncrRefCount(filters[i]);
}
oPtr->filters.list = filtersList;
oPtr->filters.num = numFilters;
|
| ︙ | ︙ | |||
323 324 325 326 327 328 329 |
}
if (numFilters == 0) {
/*
* No list of filters was supplied, so we're deleting filters.
*/
| | | | | 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 |
}
if (numFilters == 0) {
/*
* No list of filters was supplied, so we're deleting filters.
*/
ckfree(classPtr->filters.list);
classPtr->filters.list = NULL;
classPtr->filters.num = 0;
} else {
/*
* We've got a list of filters, so we're creating filters.
*/
Tcl_Obj **filtersList;
int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */
if (classPtr->filters.num == 0) {
filtersList = (Tcl_Obj **)ckalloc(size);
} else {
filtersList = (Tcl_Obj **)ckrealloc(classPtr->filters.list, size);
}
for (i = 0 ; i < numFilters ; i++) {
filtersList[i] = filters[i];
Tcl_IncrRefCount(filters[i]);
}
classPtr->filters.list = filtersList;
classPtr->filters.num = numFilters;
|
| ︙ | ︙ | |||
379 380 381 382 383 384 385 |
if (numMixins == 0) {
if (oPtr->mixins.num != 0) {
FOREACH(mixinPtr, oPtr->mixins) {
TclOORemoveFromInstances(oPtr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
| | | | | 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 |
if (numMixins == 0) {
if (oPtr->mixins.num != 0) {
FOREACH(mixinPtr, oPtr->mixins) {
TclOORemoveFromInstances(oPtr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
ckfree(oPtr->mixins.list);
oPtr->mixins.num = 0;
}
RecomputeClassCacheFlag(oPtr);
} else {
if (oPtr->mixins.num != 0) {
FOREACH(mixinPtr, oPtr->mixins) {
if (mixinPtr && mixinPtr != oPtr->selfCls) {
TclOORemoveFromInstances(oPtr, mixinPtr);
}
TclOODecrRefCount(mixinPtr->thisPtr);
}
oPtr->mixins.list = (Class **)ckrealloc(oPtr->mixins.list,
sizeof(Class *) * numMixins);
} else {
oPtr->mixins.list = (Class **)ckalloc(sizeof(Class *) * numMixins);
oPtr->flags &= ~USE_CLASS_CACHE;
}
oPtr->mixins.num = numMixins;
memcpy(oPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
FOREACH(mixinPtr, oPtr->mixins) {
if (mixinPtr != oPtr->selfCls) {
TclOOAddToInstances(oPtr, mixinPtr);
|
| ︙ | ︙ | |||
440 441 442 443 444 445 446 |
if (numMixins == 0) {
if (classPtr->mixins.num != 0) {
FOREACH(mixinPtr, classPtr->mixins) {
TclOORemoveFromMixinSubs(classPtr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
| | | | | 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 |
if (numMixins == 0) {
if (classPtr->mixins.num != 0) {
FOREACH(mixinPtr, classPtr->mixins) {
TclOORemoveFromMixinSubs(classPtr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
ckfree(classPtr->mixins.list);
classPtr->mixins.num = 0;
}
} else {
if (classPtr->mixins.num != 0) {
FOREACH(mixinPtr, classPtr->mixins) {
TclOORemoveFromMixinSubs(classPtr, mixinPtr);
TclOODecrRefCount(mixinPtr->thisPtr);
}
classPtr->mixins.list = (Class **)ckrealloc(classPtr->mixins.list,
sizeof(Class *) * numMixins);
} else {
classPtr->mixins.list = (Class **)ckalloc(sizeof(Class *) * numMixins);
}
classPtr->mixins.num = numMixins;
memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
FOREACH(mixinPtr, classPtr->mixins) {
TclOOAddToMixinSubs(classPtr, mixinPtr);
/*
|
| ︙ | ︙ | |||
496 497 498 499 500 501 502 |
Tcl_IncrRefCount(varv[i]);
}
FOREACH(variableObj, *vnlPtr) {
Tcl_DecrRefCount(variableObj);
}
if (i != varc) {
if (varc == 0) {
| | | | | | 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 |
Tcl_IncrRefCount(varv[i]);
}
FOREACH(variableObj, *vnlPtr) {
Tcl_DecrRefCount(variableObj);
}
if (i != varc) {
if (varc == 0) {
ckfree(vnlPtr->list);
} else if (i) {
vnlPtr->list = (Tcl_Obj **)ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc);
} else {
vnlPtr->list = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * varc);
}
}
vnlPtr->num = 0;
if (varc > 0) {
Tcl_InitObjHashTable(&uniqueTable);
for (i=n=0 ; i<varc ; i++) {
Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
if (created) {
vnlPtr->list[n++] = varv[i];
} else {
Tcl_DecrRefCount(varv[i]);
}
}
vnlPtr->num = n;
/*
* Shouldn't be necessary, but maintain num/list invariant.
*/
if (n != varc) {
vnlPtr->list = (Tcl_Obj **)ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * n);
}
Tcl_DeleteHashTable(&uniqueTable);
}
}
static inline void
InstallPrivateVariableMapping(
|
| ︙ | ︙ | |||
547 548 549 550 551 552 553 |
}
FOREACH_STRUCT(privatePtr, *pvlPtr) {
Tcl_DecrRefCount(privatePtr->variableObj);
Tcl_DecrRefCount(privatePtr->fullNameObj);
}
if (i != varc) {
if (varc == 0) {
| | | | | | | 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 |
}
FOREACH_STRUCT(privatePtr, *pvlPtr) {
Tcl_DecrRefCount(privatePtr->variableObj);
Tcl_DecrRefCount(privatePtr->fullNameObj);
}
if (i != varc) {
if (varc == 0) {
ckfree(pvlPtr->list);
} else if (i) {
pvlPtr->list = (PrivateVariableMapping *)ckrealloc(pvlPtr->list,
sizeof(PrivateVariableMapping) * varc);
} else {
pvlPtr->list = (PrivateVariableMapping *)ckalloc(sizeof(PrivateVariableMapping) * varc);
}
}
pvlPtr->num = 0;
if (varc > 0) {
Tcl_InitObjHashTable(&uniqueTable);
for (i=n=0 ; i<varc ; i++) {
Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
if (created) {
privatePtr = &(pvlPtr->list[n++]);
privatePtr->variableObj = varv[i];
privatePtr->fullNameObj = Tcl_ObjPrintf(
PRIVATE_VARIABLE_PATTERN,
creationEpoch, Tcl_GetString(varv[i]));
Tcl_IncrRefCount(privatePtr->fullNameObj);
} else {
Tcl_DecrRefCount(varv[i]);
}
}
pvlPtr->num = n;
/*
* Shouldn't be necessary, but maintain num/list invariant.
*/
if (n != varc) {
pvlPtr->list = (PrivateVariableMapping *)ckrealloc(pvlPtr->list,
sizeof(PrivateVariableMapping) * n);
}
Tcl_DeleteHashTable(&uniqueTable);
}
}
/*
|
| ︙ | ︙ | |||
660 661 662 663 664 665 666 |
}
}
/*
* Complete the splicing by changing the method's name.
*/
| | | 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 |
}
}
/*
* Complete the splicing by changing the method's name.
*/
mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (toPtr) {
Tcl_IncrRefCount(toPtr);
Tcl_DecrRefCount(mPtr->namePtr);
mPtr->namePtr = toPtr;
Tcl_SetHashValue(newHPtr, mPtr);
} else {
if (!useClass) {
|
| ︙ | ︙ | |||
691 692 693 694 695 696 697 | * prefix of. * * ---------------------------------------------------------------------- */ int TclOOUnknownDefinition( | | | | | | 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 |
* prefix of.
*
* ----------------------------------------------------------------------
*/
int
TclOOUnknownDefinition(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
int soughtLen;
const char *soughtStr, *matchedStr = NULL;
if (objc < 2) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad call of unknown handler", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", NULL);
return TCL_ERROR;
}
if (TclOOGetDefineCmdContext(interp) == NULL) {
return TCL_ERROR;
}
soughtStr = TclGetStringFromObj(objv[1], &soughtLen);
if (soughtLen == 0) {
goto noMatch;
}
hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (hPtr != NULL) {
const char *nameStr = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
if (strncmp(soughtStr, nameStr, soughtLen) == 0) {
if (matchedStr != NULL) {
goto noMatch;
}
matchedStr = nameStr;
}
hPtr = Tcl_NextHashEntry(&search);
}
if (matchedStr != NULL) {
/*
* Got one match, and only one match!
*/
Tcl_Obj **newObjv = (Tcl_Obj **)
TclStackAlloc(interp, sizeof(Tcl_Obj*) * (objc - 1));
int result;
newObjv[0] = Tcl_NewStringObj(matchedStr, -1);
Tcl_IncrRefCount(newObjv[0]);
if (objc > 2) {
memcpy(newObjv + 1, objv + 2, sizeof(Tcl_Obj *) * (objc - 2));
|
| ︙ | ︙ | |||
773 774 775 776 777 778 779 |
static Tcl_Command
FindCommand(
Tcl_Interp *interp,
Tcl_Obj *stringObj,
Tcl_Namespace *const namespacePtr)
{
| | | | 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 |
static Tcl_Command
FindCommand(
Tcl_Interp *interp,
Tcl_Obj *stringObj,
Tcl_Namespace *const namespacePtr)
{
int length;
const char *nameStr, *string = TclGetStringFromObj(stringObj, &length);
Namespace *const nsPtr = (Namespace *) namespacePtr;
FOREACH_HASH_DECLS;
Tcl_Command cmd, cmd2;
/*
* If someone is playing games, we stop playing right now.
*/
|
| ︙ | ︙ | |||
886 887 888 889 890 891 892 |
&& iPtr->varFramePtr->isProcCallFrame != PRIVATE_FRAME)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"this command may only be called from within the context of"
" an ::oo::define or ::oo::objdefine command", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return NULL;
}
| | | 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 |
&& iPtr->varFramePtr->isProcCallFrame != PRIVATE_FRAME)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"this command may only be called from within the context of"
" an ::oo::define or ::oo::objdefine command", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return NULL;
}
object = (Tcl_Object)iPtr->varFramePtr->clientData;
if (Tcl_ObjectDeleted(object)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"this command cannot be called when the object has been"
" deleted", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return NULL;
}
|
| ︙ | ︙ | |||
992 993 994 995 996 997 998 |
* current name (post-execution) has to be
* used. This matters, because the object
* could have been renamed... */
const char *typeOfSubject) /* Part of the message, saying whether it was
* an object, class or class-as-object that
* was being configured. */
{
| | | | | 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 |
* current name (post-execution) has to be
* used. This matters, because the object
* could have been renamed... */
const char *typeOfSubject) /* Part of the message, saying whether it was
* an object, class or class-as-object that
* was being configured. */
{
int length;
Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr)
? savedNameObj : TclOOObjectName(interp, oPtr);
const char *objName = TclGetStringFromObj(realNameObj, &length);
int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT;
int overflow = (length > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (in definition script for %s \"%.*s%s\" line %d)",
typeOfSubject, (overflow ? limit : length), objName,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
/*
* ----------------------------------------------------------------------
*
* MagicDefinitionInvoke --
|
| ︙ | ︙ | |||
1088 1089 1090 1091 1092 1093 1094 | * messages are clearer. * * ---------------------------------------------------------------------- */ int TclOODefineObjCmd( | | | 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 |
* messages are clearer.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Namespace *nsPtr;
Object *oPtr;
int result;
|
| ︙ | ︙ | |||
1164 1165 1166 1167 1168 1169 1170 | * messages are clearer. * * ---------------------------------------------------------------------- */ int TclOOObjDefObjCmd( | | | 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 |
* messages are clearer.
*
* ----------------------------------------------------------------------
*/
int
TclOOObjDefObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Namespace *nsPtr;
Object *oPtr;
int result;
|
| ︙ | ︙ | |||
1233 1234 1235 1236 1237 1238 1239 | * dispatch so that error messages are clearer. * * ---------------------------------------------------------------------- */ int TclOODefineSelfObjCmd( | | | | | | 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 |
* dispatch so that error messages are clearer.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineSelfObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Namespace *nsPtr;
Object *oPtr;
int result, isPrivate;
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (objc < 2) {
Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr));
return TCL_OK;
}
isPrivate = IsPrivateDefine(interp);
/*
* Make the oo::objdefine namespace the current namespace and evaluate the
* command(s).
*/
nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 0);
if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) {
return TCL_ERROR;
}
if (isPrivate) {
((Interp *) interp)->varFramePtr->isProcCallFrame = PRIVATE_FRAME;
}
AddRef(oPtr);
if (objc == 2) {
Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr);
|
| ︙ | ︙ | |||
1304 1305 1306 1307 1308 1309 1310 | * command. * * ---------------------------------------------------------------------- */ int TclOODefineObjSelfObjCmd( | | | 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 |
* command.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineObjSelfObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr;
if (objc != 1) {
|
| ︙ | ︙ | |||
1411 1412 1413 1414 1415 1416 1417 | * command. * * ---------------------------------------------------------------------- */ int TclOODefineClassObjCmd( | | | 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 |
* command.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineClassObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr;
Class *clsPtr;
Foundation *fPtr = TclOOGetFoundation(interp);
|
| ︙ | ︙ | |||
1492 1493 1494 1495 1496 1497 1498 | TclOORemoveFromMixins(oPtr->classPtr, oPtr); oPtr->fPtr->epoch++; oPtr->flags |= DONT_DELETE; TclOODeleteDescendants(interp, oPtr); oPtr->flags &= ~DONT_DELETE; TclOOReleaseClassContents(interp, oPtr); | | | | 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 |
TclOORemoveFromMixins(oPtr->classPtr, oPtr);
oPtr->fPtr->epoch++;
oPtr->flags |= DONT_DELETE;
TclOODeleteDescendants(interp, oPtr);
oPtr->flags &= ~DONT_DELETE;
TclOOReleaseClassContents(interp, oPtr);
ckfree(oPtr->classPtr);
oPtr->classPtr = NULL;
} else if (!wasClass && willBeClass) {
TclOOAllocClass(interp, oPtr);
}
if (oPtr->classPtr != NULL) {
BumpGlobalEpoch(interp, oPtr->classPtr);
} else {
|
| ︙ | ︙ | |||
1520 1521 1522 1523 1524 1525 1526 | * command. * * ---------------------------------------------------------------------- */ int TclOODefineConstructorObjCmd( | | | | | 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 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 |
* command.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineConstructorObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr;
Class *clsPtr;
Tcl_Method method;
int bodyLength;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "arguments body");
return TCL_ERROR;
}
/*
* Extract and validate the context, which is the class that we wish to
* modify.
*/
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
clsPtr = oPtr->classPtr;
TclGetStringFromObj(objv[2], &bodyLength);
if (bodyLength > 0) {
/*
* Create the method structure.
*/
method = (Tcl_Method) TclOONewProcMethod(interp, clsPtr,
PUBLIC_METHOD, NULL, objv[1], objv[2], NULL);
|
| ︙ | ︙ | |||
1589 1590 1591 1592 1593 1594 1595 | * "oo::define" command. * * ---------------------------------------------------------------------- */ int TclOODefineDefnNsObjCmd( | | | 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 |
* "oo::define" command.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineDefnNsObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
static const char *kindList[] = {
"-class",
"-instance",
|
| ︙ | ︙ | |||
1634 1635 1636 1637 1638 1639 1640 |
Tcl_WrongNumArgs(interp, 1, objv, "?kind? namespace");
return TCL_ERROR;
}
if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[1], kindList, "kind", 0,
&kind) != TCL_OK) {
return TCL_ERROR;
}
| | | 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 |
Tcl_WrongNumArgs(interp, 1, objv, "?kind? namespace");
return TCL_ERROR;
}
if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[1], kindList, "kind", 0,
&kind) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_GetString(objv[objc - 1])[0]) {
nsNamePtr = NULL;
} else {
nsPtr = GetNamespaceInOuterContext(interp, objv[objc - 1]);
if (nsPtr == NULL) {
return TCL_ERROR;
}
nsNamePtr = Tcl_NewStringObj(nsPtr->fullName, -1);
|
| ︙ | ︙ | |||
1731 1732 1733 1734 1735 1736 1737 | * command. * * ---------------------------------------------------------------------- */ int TclOODefineDestructorObjCmd( | | | | | 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 |
* command.
*
* ----------------------------------------------------------------------
*/
int
TclOODefineDestructorObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr;
Class *clsPtr;
Tcl_Method method;
int bodyLength;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "body");
return TCL_ERROR;
}
oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
clsPtr = oPtr->classPtr;
TclGetStringFromObj(objv[1], &bodyLength);
if (bodyLength > 0) {
/*
* Create the method structure.
*/
method = (Tcl_Method) TclOONewProcMethod(interp, clsPtr,
PUBLIC_METHOD, NULL, NULL, objv[1], NULL);
|
| ︙ | ︙ | |||
1837 1838 1839 1840 1841 1842 1843 |
* instance of) then we put in a blank record with that flag; such
* records are skipped over by the call chain engine *except* for
* their flags member.
*/
if (isInstanceExport) {
if (!oPtr->methodsPtr) {
| | | | | 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 |
* instance of) then we put in a blank record with that flag; such
* records are skipped over by the call chain engine *except* for
* their flags member.
*/
if (isInstanceExport) {
if (!oPtr->methodsPtr) {
oPtr->methodsPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i],
&isNew);
} else {
hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i],
&isNew);
}
if (isNew) {
mPtr = (Method *)ckalloc(sizeof(Method));
memset(mPtr, 0, sizeof(Method));
mPtr->refCount = 1;
mPtr->namePtr = objv[i];
Tcl_IncrRefCount(objv[i]);
Tcl_SetHashValue(hPtr, mPtr);
} else {
mPtr = (Method *)Tcl_GetHashValue(hPtr);
}
if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) {
mPtr->flags |= PUBLIC_METHOD;
mPtr->flags &= ~TRUE_PRIVATE_METHOD;
changed = 1;
}
}
|
| ︙ | ︙ | |||
2150 2151 2152 2153 2154 2155 2156 |
* an instance of) then we put in a blank record without that flag;
* such records are skipped over by the call chain engine *except* for
* their flags member.
*/
if (isInstanceUnexport) {
if (!oPtr->methodsPtr) {
| | | | | 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 |
* an instance of) then we put in a blank record without that flag;
* such records are skipped over by the call chain engine *except* for
* their flags member.
*/
if (isInstanceUnexport) {
if (!oPtr->methodsPtr) {
oPtr->methodsPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i],
&isNew);
} else {
hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i],
&isNew);
}
if (isNew) {
mPtr = (Method *)ckalloc(sizeof(Method));
memset(mPtr, 0, sizeof(Method));
mPtr->refCount = 1;
mPtr->namePtr = objv[i];
Tcl_IncrRefCount(objv[i]);
Tcl_SetHashValue(hPtr, mPtr);
} else {
mPtr = (Method *)Tcl_GetHashValue(hPtr);
}
if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) {
mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD);
changed = 1;
}
}
|
| ︙ | ︙ | |||
2310 2311 2312 2313 2314 2315 2316 | * command. * * ---------------------------------------------------------------------- */ static int ClassFilterGet( | | | 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 |
* command.
*
* ----------------------------------------------------------------------
*/
static int
ClassFilterGet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj, *filterObj;
|
| ︙ | ︙ | |||
2344 2345 2346 2347 2348 2349 2350 |
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassFilterSet(
| | | 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 |
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassFilterSet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int filterc;
|
| ︙ | ︙ | |||
2390 2391 2392 2393 2394 2395 2396 | * command. * * ---------------------------------------------------------------------- */ static int ClassMixinGet( | | | 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 |
* command.
*
* ----------------------------------------------------------------------
*/
static int
ClassMixinGet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj;
|
| ︙ | ︙ | |||
2427 2428 2429 2430 2431 2432 2433 |
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassMixinSet(
| | | 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 |
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassMixinSet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int mixinc, i;
|
| ︙ | ︙ | |||
2457 2458 2459 2460 2461 2462 2463 |
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
&mixinv) != TCL_OK) {
return TCL_ERROR;
}
| | | 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 |
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
return TCL_ERROR;
} else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
&mixinv) != TCL_OK) {
return TCL_ERROR;
}
mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc);
for (i = 0; i < mixinc; i++) {
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
"may only mix in classes");
if (mixins[i] == NULL) {
i--;
goto freeAndError;
|
| ︙ | ︙ | |||
2496 2497 2498 2499 2500 2501 2502 | * command. * * ---------------------------------------------------------------------- */ static int ClassSuperGet( | | | 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 |
* command.
*
* ----------------------------------------------------------------------
*/
static int
ClassSuperGet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj;
|
| ︙ | ︙ | |||
2532 2533 2534 2535 2536 2537 2538 |
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassSuperSet(
| | | 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 |
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassSuperSet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int superc, i, j;
|
| ︙ | ︙ | |||
2571 2572 2573 2574 2575 2576 2577 |
return TCL_ERROR;
}
/*
* Allocate some working space.
*/
| | | < | | | 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 |
return TCL_ERROR;
}
/*
* Allocate some working space.
*/
superclasses = (Class **) ckalloc(sizeof(Class *) * superc);
/*
* Parse the arguments to get the class to use as superclasses.
*
* Note that zero classes is special, as it is equivalent to just the
* class of objects. [Bug 9d61624b3d]
*/
if (superc == 0) {
superclasses = (Class **)ckrealloc(superclasses, sizeof(Class *));
if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) {
superclasses[0] = oPtr->fPtr->classCls;
} else {
superclasses[0] = oPtr->fPtr->objectCls;
}
superc = 1;
AddRef(superclasses[0]->thisPtr);
} else {
for (i = 0; i < superc; i++) {
superclasses[i] = GetClassInOuterContext(interp, superv[i],
"only a class can be a superclass");
if (superclasses[i] == NULL) {
goto failedAfterAlloc;
}
for (j = 0; j < i; j++) {
if (superclasses[j] == superclasses[i]) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"class should only be a direct superclass once",
-1));
Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL);
goto failedAfterAlloc;
}
}
if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to form circular dependency graph", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
failedAfterAlloc:
for (; i-- > 0 ;) {
TclOODecrRefCount(superclasses[i]->thisPtr);
}
ckfree(superclasses);
return TCL_ERROR;
}
/*
* Corresponding TclOODecrRefCount() is near the end of this
* function.
*/
|
| ︙ | ︙ | |||
2639 2640 2641 2642 2643 2644 2645 |
*/
if (oPtr->classPtr->superclasses.num != 0) {
FOREACH(superPtr, oPtr->classPtr->superclasses) {
TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
TclOODecrRefCount(superPtr->thisPtr);
}
| | | 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 |
*/
if (oPtr->classPtr->superclasses.num != 0) {
FOREACH(superPtr, oPtr->classPtr->superclasses) {
TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
TclOODecrRefCount(superPtr->thisPtr);
}
ckfree(oPtr->classPtr->superclasses.list);
}
oPtr->classPtr->superclasses.list = superclasses;
oPtr->classPtr->superclasses.num = superc;
FOREACH(superPtr, oPtr->classPtr->superclasses) {
TclOOAddToSubclasses(oPtr->classPtr, superPtr);
}
BumpGlobalEpoch(interp, oPtr->classPtr);
|
| ︙ | ︙ | |||
2664 2665 2666 2667 2668 2669 2670 | * command. * * ---------------------------------------------------------------------- */ static int ClassVarsGet( | | | 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 |
* command.
*
* ----------------------------------------------------------------------
*/
static int
ClassVarsGet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj;
|
| ︙ | ︙ | |||
2708 2709 2710 2711 2712 2713 2714 |
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassVarsSet(
| | | 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 |
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ClassVarsSet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int varc;
|
| ︙ | ︙ | |||
2779 2780 2781 2782 2783 2784 2785 | * command. * * ---------------------------------------------------------------------- */ static int ObjFilterGet( | | | 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 |
* command.
*
* ----------------------------------------------------------------------
*/
static int
ObjFilterGet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj, *filterObj;
|
| ︙ | ︙ | |||
2807 2808 2809 2810 2811 2812 2813 |
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ObjFilterSet(
| | | 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 |
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ObjFilterSet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int filterc;
|
| ︙ | ︙ | |||
2847 2848 2849 2850 2851 2852 2853 | * command. * * ---------------------------------------------------------------------- */ static int ObjMixinGet( | | | 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 |
* command.
*
* ----------------------------------------------------------------------
*/
static int
ObjMixinGet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj;
|
| ︙ | ︙ | |||
2879 2880 2881 2882 2883 2884 2885 |
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ObjMixinSet(
| | | 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 |
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ObjMixinSet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int mixinc;
|
| ︙ | ︙ | |||
2904 2905 2906 2907 2908 2909 2910 |
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
&mixinv) != TCL_OK) {
return TCL_ERROR;
}
| | | 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 |
}
objv += Tcl_ObjectContextSkippedArgs(context);
if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
&mixinv) != TCL_OK) {
return TCL_ERROR;
}
mixins = (Class **)TclStackAlloc(interp, sizeof(Class *) * mixinc);
for (i = 0; i < mixinc; i++) {
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
"may only mix in classes");
if (mixins[i] == NULL) {
TclStackFree(interp, mixins);
return TCL_ERROR;
|
| ︙ | ︙ | |||
2933 2934 2935 2936 2937 2938 2939 | * command. * * ---------------------------------------------------------------------- */ static int ObjVarsGet( | | | 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 |
* command.
*
* ----------------------------------------------------------------------
*/
static int
ObjVarsGet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
Tcl_Obj *resultObj;
|
| ︙ | ︙ | |||
2971 2972 2973 2974 2975 2976 2977 |
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ObjVarsSet(
| | | 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 |
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
static int
ObjVarsSet(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
int varc, i;
|
| ︙ | ︙ | |||
3036 3037 3038 3039 3040 3041 3042 | * names to their fully-qualified names if possible. * * ---------------------------------------------------------------------- */ static int ResolveClass( | | | 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 |
* names to their fully-qualified names if possible.
*
* ----------------------------------------------------------------------
*/
static int
ResolveClass(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
Tcl_ObjectContext context,
int objc,
Tcl_Obj *const *objv)
{
int idx = Tcl_ObjectContextSkippedArgs(context);
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
|
| ︙ | ︙ |
Changes to generic/tclOOInfo.c.
| ︙ | ︙ | |||
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(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
if (objc != 2 && objc != 3) {
|
| ︙ | ︙ | |||
224 225 226 227 228 229 230 | * Implements [info object definition $objName $methodName] * * ---------------------------------------------------------------------- */ static int InfoObjectDefnCmd( | | | 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 |
* Implements [info object definition $objName $methodName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectDefnCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
Tcl_HashEntry *hPtr;
Proc *procPtr;
|
| ︙ | ︙ | |||
257 258 259 260 261 262 263 |
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
| | | 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 |
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"definition not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
281 282 283 284 285 286 287 |
Tcl_NewStringObj(localPtr->name, -1));
if (localPtr->defValuePtr != NULL) {
Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
}
Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
}
}
| | | | 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 |
Tcl_NewStringObj(localPtr->name, -1));
if (localPtr->defValuePtr != NULL) {
Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
}
Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
}
}
resultObjs[1] = TclOOGetMethodBody((Method *)Tcl_GetHashValue(hPtr));
Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* InfoObjectFiltersCmd --
*
* Implements [info object filters $objName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectFiltersCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int i;
Tcl_Obj *filterObj, *resultObj;
Object *oPtr;
|
| ︙ | ︙ | |||
337 338 339 340 341 342 343 | * Implements [info object forward $objName $methodName] * * ---------------------------------------------------------------------- */ static int InfoObjectForwardCmd( | | | 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 |
* Implements [info object forward $objName $methodName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectForwardCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
Tcl_HashEntry *hPtr;
Tcl_Obj *prefixObj;
|
| ︙ | ︙ | |||
368 369 370 371 372 373 374 |
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
| | | 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 |
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
prefixObj = TclOOGetFwdFromMethod((Method *)Tcl_GetHashValue(hPtr));
if (prefixObj == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"prefix argument list not available for this kind of method",
-1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
394 395 396 397 398 399 400 | * Implements [info object isa $category $objName ...] * * ---------------------------------------------------------------------- */ static int InfoObjectIsACmd( | | | 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 |
* Implements [info object isa $category $objName ...]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectIsACmd(
TCL_UNUSED(ClientData),
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(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
int flag = PUBLIC_METHOD, recurse = 0, scope = -1;
FOREACH_HASH_DECLS;
|
| ︙ | ︙ | |||
608 609 610 611 612 613 614 |
&names);
for (i=0 ; i<numNames ; i++) {
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(names[i], -1));
}
if (numNames > 0) {
| | | 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 |
&names);
for (i=0 ; i<numNames ; i++) {
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(names[i], -1));
}
if (numNames > 0) {
ckfree(names);
}
} else if (oPtr->methodsPtr) {
FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) {
Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
}
}
|
| ︙ | ︙ | |||
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(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
Tcl_HashEntry *hPtr;
Method *mPtr;
|
| ︙ | ︙ | |||
664 665 666 667 668 669 670 |
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
| | | 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 |
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (mPtr->typePtr == NULL) {
/*
* Special entry for visibility control: pretend the method doesnt
* exist.
*/
goto unknownMethod;
|
| ︙ | ︙ | |||
690 691 692 693 694 695 696 | * Implements [info object mixins $objName] * * ---------------------------------------------------------------------- */ static int InfoObjectMixinsCmd( | | | 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 |
* Implements [info object mixins $objName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectMixinsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *mixinPtr;
Object *oPtr;
Tcl_Obj *resultObj;
|
| ︙ | ︙ | |||
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 |
* Implements [info object creationid $objName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectIdCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
if (objc != 2) {
|
| ︙ | ︙ | |||
765 766 767 768 769 770 771 | * Implements [info object namespace $objName] * * ---------------------------------------------------------------------- */ static int InfoObjectNsCmd( | | | 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 |
* Implements [info object namespace $objName]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectNsCmd(
TCL_UNUSED(ClientData),
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 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 |
* Implements [info object variables $objName ?-private?]
*
* ----------------------------------------------------------------------
*/
static int
InfoObjectVariablesCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
Tcl_Obj *resultObj;
int i, isPrivate = 0;
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?");
return TCL_ERROR;
}
if (objc == 3) {
if (strcmp("-private", Tcl_GetString(objv[2])) != 0) {
return TCL_ERROR;
}
isPrivate = 1;
}
oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
if (oPtr == NULL) {
return TCL_ERROR;
}
resultObj = Tcl_NewObj();
if (isPrivate) {
PrivateVariableMapping *privatePtr;
FOREACH_STRUCT(privatePtr, oPtr->privateVariables) {
Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
}
} else {
Tcl_Obj *variableObj;
|
| ︙ | ︙ | |||
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(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
const char *pattern = NULL;
FOREACH_HASH_DECLS;
|
| ︙ | ︙ | |||
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(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Proc *procPtr;
CompiledLocal *localPtr;
Tcl_Obj *resultObjs[2];
|
| ︙ | ︙ | |||
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(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_HashEntry *hPtr;
Proc *procPtr;
CompiledLocal *localPtr;
|
| ︙ | ︙ | |||
1001 1002 1003 1004 1005 1006 1007 |
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
| | | 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 |
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
procPtr = TclOOGetProcFromMethod((Method *)Tcl_GetHashValue(hPtr));
if (procPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"definition not available for this kind of method", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1025 1026 1027 1028 1029 1030 1031 |
Tcl_NewStringObj(localPtr->name, -1));
if (localPtr->defValuePtr != NULL) {
Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
}
Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
}
}
| | | | 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 |
Tcl_NewStringObj(localPtr->name, -1));
if (localPtr->defValuePtr != NULL) {
Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr);
}
Tcl_ListObjAppendElement(NULL, resultObjs[0], argObj);
}
}
resultObjs[1] = TclOOGetMethodBody((Method *)Tcl_GetHashValue(hPtr));
Tcl_SetObjResult(interp, Tcl_NewListObj(2, resultObjs));
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* InfoClassDefnNsCmd --
*
* Implements [info class definitionnamespace $clsName ?$kind?]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassDefnNsCmd(
TCL_UNUSED(ClientData),
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(ClientData),
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 |
* Implements [info class filters $clsName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassFiltersCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int i;
Tcl_Obj *filterObj, *resultObj;
Class *clsPtr;
|
| ︙ | ︙ | |||
1174 1175 1176 1177 1178 1179 1180 | * Implements [info class forward $clsName $methodName] * * ---------------------------------------------------------------------- */ static int InfoClassForwardCmd( | | | 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 |
* Implements [info class forward $clsName $methodName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassForwardCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_HashEntry *hPtr;
Tcl_Obj *prefixObj;
Class *clsPtr;
|
| ︙ | ︙ | |||
1199 1200 1201 1202 1203 1204 1205 |
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
| | | 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 |
if (hPtr == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
prefixObj = TclOOGetFwdFromMethod((Method *)Tcl_GetHashValue(hPtr));
if (prefixObj == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"prefix argument list not available for this kind of method",
-1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
1225 1226 1227 1228 1229 1230 1231 | * Implements [info class instances $clsName ?$pattern?] * * ---------------------------------------------------------------------- */ static int InfoClassInstancesCmd( | | | 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 |
* Implements [info class instances $clsName ?$pattern?]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassInstancesCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
Class *clsPtr;
int i;
|
| ︙ | ︙ | |||
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(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int flag = PUBLIC_METHOD, recurse = 0, scope = -1;
Tcl_Obj *namePtr, *resultObj;
Method *mPtr;
|
| ︙ | ︙ | |||
1362 1363 1364 1365 1366 1367 1368 |
int i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names);
for (i=0 ; i<numNames ; i++) {
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(names[i], -1));
}
if (numNames > 0) {
| | | 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 |
int i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names);
for (i=0 ; i<numNames ; i++) {
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(names[i], -1));
}
if (numNames > 0) {
ckfree(names);
}
} else {
FOREACH_HASH_DECLS;
FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) {
if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) {
Tcl_ListObjAppendElement(NULL, resultObj, namePtr);
|
| ︙ | ︙ | |||
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(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_HashEntry *hPtr;
Method *mPtr;
Class *clsPtr;
|
| ︙ | ︙ | |||
1416 1417 1418 1419 1420 1421 1422 |
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
| | | 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 |
unknownMethod:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown method \"%s\"", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (mPtr->typePtr == NULL) {
/*
* Special entry for visibility control: pretend the method doesnt
* exist.
*/
goto unknownMethod;
|
| ︙ | ︙ | |||
1441 1442 1443 1444 1445 1446 1447 | * Implements [info class mixins $clsName] * * ---------------------------------------------------------------------- */ static int InfoClassMixinsCmd( | | | 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 |
* Implements [info class mixins $clsName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassMixinsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr, *mixinPtr;
Tcl_Obj *resultObj;
int i;
|
| ︙ | ︙ | |||
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(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr, *subclassPtr;
Tcl_Obj *resultObj;
int i;
|
| ︙ | ︙ | |||
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 |
* Implements [info class superclasses $clsName]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassSupersCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr, *superPtr;
Tcl_Obj *resultObj;
int i;
|
| ︙ | ︙ | |||
1577 1578 1579 1580 1581 1582 1583 | * Implements [info class variables $clsName ?-private?] * * ---------------------------------------------------------------------- */ static int InfoClassVariablesCmd( | | | | | | | 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 |
* Implements [info class variables $clsName ?-private?]
*
* ----------------------------------------------------------------------
*/
static int
InfoClassVariablesCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr;
Tcl_Obj *resultObj;
int i, isPrivate = 0;
if (objc != 2 && objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?");
return TCL_ERROR;
}
if (objc == 3) {
if (strcmp("-private", Tcl_GetString(objv[2])) != 0) {
return TCL_ERROR;
}
isPrivate = 1;
}
clsPtr = GetClassFromObj(interp, objv[1]);
if (clsPtr == NULL) {
return TCL_ERROR;
}
resultObj = Tcl_NewObj();
if (isPrivate) {
PrivateVariableMapping *privatePtr;
FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) {
Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj);
}
} else {
Tcl_Obj *variableObj;
|
| ︙ | ︙ | |||
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(ClientData),
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(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Class *clsPtr;
CallChain *callPtr;
|
| ︙ | ︙ |
Changes to generic/tclOOInt.h.
| ︙ | ︙ | |||
42 43 44 45 46 47 48 |
*/
typedef struct Method {
const Tcl_MethodType *typePtr;
/* The type of method. If NULL, this is a
* special flag record which is just used for
* the setting of the flags field. */
| | | | | | | | 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 |
*/
typedef struct Method {
const Tcl_MethodType *typePtr;
/* The type of method. If NULL, this is a
* special flag record which is just used for
* the setting of the flags field. */
int refCount;
void *clientData; /* Type-specific data. */
Tcl_Obj *namePtr; /* Name of the method. */
struct Object *declaringObjectPtr;
/* The object that declares this method, or
* NULL if it was declared by a class. */
struct Class *declaringClassPtr;
/* The class that declares this method, or
* NULL if it was declared directly on an
* object. */
int flags; /* Assorted flags. Includes whether this
* method is public/exported or not. */
} Method;
/*
* Pre- and post-call callbacks, to allow procedure-like methods to be fine
* tuned in their behaviour.
*/
typedef int (TclOO_PreCallProc)(ClientData clientData, Tcl_Interp *interp,
Tcl_ObjectContext context, Tcl_CallFrame *framePtr, int *isFinished);
typedef int (TclOO_PostCallProc)(ClientData clientData, Tcl_Interp *interp,
Tcl_ObjectContext context, Tcl_Namespace *namespacePtr, int result);
typedef void (TclOO_PmCDDeleteProc)(ClientData clientData);
typedef ClientData (TclOO_PmCDCloneProc)(ClientData clientData);
/*
* Procedure-like methods have the following extra information.
*/
typedef struct ProcedureMethod {
int version; /* Version of this structure. Currently must
* be 0. */
Proc *procPtr; /* Core of the implementation of the method;
* includes the argument definition and the
* body bytecodes. */
int flags; /* Flags to control features. */
int refCount;
void *clientData;
TclOO_PmCDDeleteProc *deleteClientdataProc;
TclOO_PmCDCloneProc *cloneClientdataProc;
ProcErrorProc *errProc; /* Replacement error handler. */
TclOO_PreCallProc *preCallProc;
/* Callback to allow for additional setup
* before the method executes. */
|
| ︙ | ︙ | |||
180 181 182 183 184 185 186 |
LIST_STATIC(struct Class *) mixins;
/* Classes mixed into this object. */
LIST_STATIC(Tcl_Obj *) filters;
/* List of filter names. */
struct Class *classPtr; /* This is non-NULL for all classes, and NULL
* for everything else. It points to the class
* structure. */
| | | | | | | | < < | < < > | 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 |
LIST_STATIC(struct Class *) mixins;
/* Classes mixed into this object. */
LIST_STATIC(Tcl_Obj *) filters;
/* List of filter names. */
struct Class *classPtr; /* This is non-NULL for all classes, and NULL
* for everything else. It points to the class
* structure. */
int refCount; /* Number of strong references to this object.
* Note that there may be many more weak
* references; this mechanism exists to
* avoid Tcl_Preserve. */
int flags;
int creationEpoch; /* Unique value to make comparisons of objects
* easier. */
int epoch; /* Per-object epoch, incremented when the way
* an object should resolve call chains is
* changed. */
Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to
* the ClientData values that are the values
* of each piece of attached metadata. This
* field starts out as NULL and is only
* allocated if metadata is attached. */
Tcl_Obj *cachedNameObj; /* Cache of the name of the object. */
Tcl_HashTable *chainCache; /* Place to keep unused contexts. This table
* is indexed by method name as Tcl_Obj. */
Tcl_ObjectMapMethodNameProc *mapMethodNameProc;
/* Function to allow remapping of method
* names. For itcl-ng. */
VariableNameList variables;
PrivateVariableList privateVariables;
/* Configurations for the variable resolver
* used inside methods. */
Tcl_Command myclassCommand; /* Reference to this object's class dispatcher
* command. */
} Object;
#define OBJECT_DESTRUCTING 1 /* Indicates that an object is being or has
* been destroyed */
#define DESTRUCTOR_CALLED 2 /* Indicates that evaluation of destructor script for the
object has began */
#define OO_UNUSED_4 4 /* No longer used. */
#define ROOT_OBJECT 0x1000 /* Flag to say that this object is the root of
* the class hierarchy and should be treated
* specially during teardown. */
#define FILTER_HANDLING 0x2000 /* Flag set when the object is processing a
* filter; when set, filters are *not*
* processed on the object, preventing nasty
* recursive filtering problems. */
|
| ︙ | ︙ | |||
282 283 284 285 286 287 288 |
* the (Tcl_Obj*) method name to the (Method*)
* method record. */
Method *constructorPtr; /* Method record of the class constructor (if
* any). */
Method *destructorPtr; /* Method record of the class destructor (if
* any). */
Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to
| | | 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 |
* the (Tcl_Obj*) method name to the (Method*)
* method record. */
Method *constructorPtr; /* Method record of the class constructor (if
* any). */
Method *destructorPtr; /* Method record of the class destructor (if
* any). */
Tcl_HashTable *metadataPtr; /* Mapping from pointers to metadata type to
* the ClientData values that are the values
* of each piece of attached metadata. This
* field starts out as NULL and is only
* allocated if metadata is attached. */
struct CallChain *constructorChainPtr;
struct CallChain *destructorChainPtr;
Tcl_HashTable *classChainCache;
/* Places where call chains are stored. For
|
| ︙ | ︙ | |||
328 329 330 331 332 333 334 |
* 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 |
* 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; /* Master 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;
|
| ︙ | ︙ | |||
352 353 354 355 356 357 358 |
Tcl_Namespace *objdefNs; /* Namespace containing special commands for
* manipulating objects and classes. The
* "oo::objdefine" command acts as a special
* kind of ensemble for this namespace. */
Tcl_Namespace *helpersNs; /* Namespace containing the commands that are
* only valid when executing inside a
* procedural method. */
| | | 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 |
Tcl_Namespace *objdefNs; /* Namespace containing special commands for
* manipulating objects and classes. The
* "oo::objdefine" command acts as a special
* kind of ensemble for this namespace. */
Tcl_Namespace *helpersNs; /* Namespace containing the commands that are
* only valid when executing inside a
* procedural method. */
int epoch; /* Used to invalidate method chains when the
* class structure changes. */
ThreadLocalData *tsdPtr; /* Counter so we can allocate a unique
* namespace to each object. */
Tcl_Obj *unknownMethodNameObj;
/* Shared object containing the name of the
* unknown method handler method. */
Tcl_Obj *constructorName; /* Shared object containing the "name" of a
|
| ︙ | ︙ | |||
386 387 388 389 390 391 392 |
* record. */
int isFilter; /* Whether this is a filter invocation. */
Class *filterDeclarer; /* What class decided to add the filter; if
* NULL, it was added by the object. */
};
typedef struct CallChain {
| | | | | | 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 |
* record. */
int isFilter; /* Whether this is a filter invocation. */
Class *filterDeclarer; /* What class decided to add the filter; if
* NULL, it was added by the object. */
};
typedef struct CallChain {
int objectCreationEpoch; /* The object's creation epoch. Note that the
* object reference is not stored in the call
* chain; it is in the call context. */
int objectEpoch; /* Local (object structure) epoch counter
* snapshot. */
int epoch; /* Global (class structure) epoch counter
* snapshot. */
int flags; /* Assorted flags, see below. */
int refCount; /* Reference count. */
int numChain; /* Size of the call chain. */
struct MInvoke *chain; /* Array of call chain entries. May point to
* staticChain if the number of entries is
* small. */
struct MInvoke staticChain[CALL_CHAIN_STATIC_SIZE];
} CallChain;
|
| ︙ | ︙ | |||
446 447 448 449 450 451 452 | /* *---------------------------------------------------------------- * Commands relating to OO support. *---------------------------------------------------------------- */ MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | 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 | /* *---------------------------------------------------------------- * Commands relating to OO support. *---------------------------------------------------------------- */ MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); MODULE_SCOPE int TclOODefineObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOOObjDefObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineConstructorObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineDefnNsObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineDeleteMethodObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineDestructorObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineExportObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineForwardObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineMethodObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineRenameMethodObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineUnexportObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineClassObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineSelfObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineObjSelfObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefinePrivateObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOOUnknownDefinition(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOOCopyObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOONextObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOONextToObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOOSelfObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); /* * Method implementations (in tclOOBasic.c). */ MODULE_SCOPE int TclOO_Class_Constructor(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOO_Class_Create(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOO_Class_CreateNs(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOO_Class_New(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOO_Object_Destroy(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOO_Object_Eval(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOO_Object_LinkVar(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOO_Object_Unknown(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); MODULE_SCOPE int TclOO_Object_VarName(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); /* * Private definitions, some of which perhaps ought to be exposed properly or * maybe just put in the internal stubs table. */ |
| ︙ | ︙ | |||
583 584 585 586 587 588 589 590 591 592 593 594 595 596 | Tcl_Obj *const *objv, int skip, Tcl_Object *objectPtr); MODULE_SCOPE Object * TclNewObjectInstanceCommon(Tcl_Interp *interp, Class *classPtr, const char *nameStr, const char *nsNameStr); MODULE_SCOPE int TclOODecrRefCount(Object *oPtr); MODULE_SCOPE int TclOODefineSlots(Foundation *fPtr); MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr); MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr); MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr); MODULE_SCOPE void TclOODeleteDescendants(Tcl_Interp *interp, Object *oPtr); MODULE_SCOPE void TclOODelMethodRef(Method *method); | > | 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 | Tcl_Obj *const *objv, int skip, Tcl_Object *objectPtr); MODULE_SCOPE Object * TclNewObjectInstanceCommon(Tcl_Interp *interp, Class *classPtr, const char *nameStr, const char *nsNameStr); MODULE_SCOPE int TclOODecrRefCount(Object *oPtr); MODULE_SCOPE int TclOOObjectDestroyed(Object *oPtr); MODULE_SCOPE int TclOODefineSlots(Foundation *fPtr); MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr); MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr); MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr); MODULE_SCOPE void TclOODeleteDescendants(Tcl_Interp *interp, Object *oPtr); MODULE_SCOPE void TclOODelMethodRef(Method *method); |
| ︙ | ︙ | |||
609 610 611 612 613 614 615 | MODULE_SCOPE int TclOOGetSortedClassMethodList(Class *clsPtr, int flags, const char ***stringsPtr); MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, Object *contextObj, Class *contextCls, int flags, const char ***stringsPtr); MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); MODULE_SCOPE void TclOOInitInfo(Tcl_Interp *interp); | | | 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 | MODULE_SCOPE int TclOOGetSortedClassMethodList(Class *clsPtr, int flags, const char ***stringsPtr); MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, Object *contextObj, Class *contextCls, int flags, const char ***stringsPtr); MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); MODULE_SCOPE void TclOOInitInfo(Tcl_Interp *interp); MODULE_SCOPE int TclOOInvokeContext(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv, int skip); MODULE_SCOPE void TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr, const DeclaredClassMethod *dcm); |
| ︙ | ︙ | |||
677 678 679 680 681 682 683 |
* REQUIRES DECLARATION: FOREACH_HASH_DECLS;
*/
#define FOREACH_HASH_DECLS \
Tcl_HashEntry *hPtr;Tcl_HashSearch search
#define FOREACH_HASH(key,val,tablePtr) \
for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
| | | | | | | 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 |
* REQUIRES DECLARATION: FOREACH_HASH_DECLS;
*/
#define FOREACH_HASH_DECLS \
Tcl_HashEntry *hPtr;Tcl_HashSearch search
#define FOREACH_HASH(key,val,tablePtr) \
for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
(*(void **)&(key)=Tcl_GetHashKey((tablePtr),hPtr),\
*(void **)&(val)=Tcl_GetHashValue(hPtr),1):0; hPtr=Tcl_NextHashEntry(&search))
#define FOREACH_HASH_VALUE(val,tablePtr) \
for(hPtr=Tcl_FirstHashEntry((tablePtr),&search); hPtr!=NULL ? \
(*(void **)&(val)=Tcl_GetHashValue(hPtr),1):0;hPtr=Tcl_NextHashEntry(&search))
/*
* Convenience macro for duplicating a list. Needs no external declaration,
* but all arguments are used multiple times and so must have no side effects.
*/
#undef DUPLICATE /* prevent possible conflict with definition in WINAPI nb30.h */
#define DUPLICATE(target,source,type) \
do { \
size_t len = sizeof(type) * ((target).num=(source).num);\
if (len != 0) { \
memcpy(((target).list=(type*)ckalloc(len)), (source).list, len); \
} else { \
(target).list = NULL; \
} \
} while(0)
#endif /* TCL_OO_INTERNAL_H */
|
| ︙ | ︙ |
Changes to generic/tclOOIntDecls.h.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 | /* 0 */ TCLAPI Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); /* 1 */ TCLAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, | | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | /* 0 */ TCLAPI Tcl_Object TclOOGetDefineCmdContext(Tcl_Interp *interp); /* 1 */ TCLAPI Tcl_Method TclOOMakeProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 2 */ TCLAPI Tcl_Method TclOOMakeProcMethod(Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 3 */ TCLAPI Method * TclOONewProcInstanceMethod(Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 4 */ TCLAPI Method * TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr, |
| ︙ | ︙ | |||
55 56 57 58 59 60 61 | Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 9 */ TCLAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, | | | | | | | | | | 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 | Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 9 */ TCLAPI Tcl_Method TclOONewProcInstanceMethodEx(Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, ClientData clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */ TCLAPI Tcl_Method TclOONewProcMethodEx(Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, ClientData clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 11 */ TCLAPI int TclOOInvokeObject(Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const *objv); /* 12 */ TCLAPI void TclOOObjectSetFilters(Object *oPtr, int numFilters, |
| ︙ | ︙ | |||
93 94 95 96 97 98 99 |
Class *const *mixins);
typedef struct TclOOIntStubs {
int magic;
void *hooks;
Tcl_Object (*tclOOGetDefineCmdContext) (Tcl_Interp *interp); /* 0 */
| | | | | | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 |
Class *const *mixins);
typedef struct TclOOIntStubs {
int magic;
void *hooks;
Tcl_Object (*tclOOGetDefineCmdContext) (Tcl_Interp *interp); /* 0 */
Tcl_Method (*tclOOMakeProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 1 */
Tcl_Method (*tclOOMakeProcMethod) (Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, const char *namePtr, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, const Tcl_MethodType *typePtr, ClientData clientData, Proc **procPtrPtr); /* 2 */
Method * (*tclOONewProcInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 3 */
Method * (*tclOONewProcMethod) (Tcl_Interp *interp, Class *clsPtr, int flags, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, ProcedureMethod **pmPtrPtr); /* 4 */
int (*tclOOObjectCmdCore) (Object *oPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int publicOnly, Class *startCls); /* 5 */
int (*tclOOIsReachable) (Class *targetPtr, Class *startPtr); /* 6 */
Method * (*tclOONewForwardMethod) (Tcl_Interp *interp, Class *clsPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 7 */
Method * (*tclOONewForwardInstanceMethod) (Tcl_Interp *interp, Object *oPtr, int isPublic, Tcl_Obj *nameObj, Tcl_Obj *prefixObj); /* 8 */
Tcl_Method (*tclOONewProcInstanceMethodEx) (Tcl_Interp *interp, Tcl_Object oPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, ClientData clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 9 */
Tcl_Method (*tclOONewProcMethodEx) (Tcl_Interp *interp, Tcl_Class clsPtr, TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, ClientData clientData, Tcl_Obj *nameObj, Tcl_Obj *argsObj, Tcl_Obj *bodyObj, int flags, void **internalTokenPtr); /* 10 */
int (*tclOOInvokeObject) (Tcl_Interp *interp, Tcl_Object object, Tcl_Class startCls, int publicPrivate, int objc, Tcl_Obj *const *objv); /* 11 */
void (*tclOOObjectSetFilters) (Object *oPtr, int numFilters, Tcl_Obj *const *filters); /* 12 */
void (*tclOOClassSetFilters) (Tcl_Interp *interp, Class *classPtr, int numFilters, Tcl_Obj *const *filters); /* 13 */
void (*tclOOObjectSetMixins) (Object *oPtr, int numMixins, Class *const *mixins); /* 14 */
void (*tclOOClassSetMixins) (Tcl_Interp *interp, Class *classPtr, int numMixins, Class *const *mixins); /* 15 */
} TclOOIntStubs;
|
| ︙ | ︙ |
Changes to generic/tclOOMethod.c.
| ︙ | ︙ | |||
76 77 78 79 80 81 82 | CallContext *contextPtr, ProcedureMethod *pmPtr, int objc, Tcl_Obj *const *objv, PMFrameData *fdPtr); static void DeleteProcedureMethodRecord(ProcedureMethod *pmPtr); static void DeleteProcedureMethod(void *clientData); static int CloneProcedureMethod(Tcl_Interp *interp, void *clientData, void **newClientData); | | < | < | < | < < | < < < | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 |
CallContext *contextPtr, ProcedureMethod *pmPtr,
int objc, Tcl_Obj *const *objv,
PMFrameData *fdPtr);
static void DeleteProcedureMethodRecord(ProcedureMethod *pmPtr);
static void DeleteProcedureMethod(void *clientData);
static int CloneProcedureMethod(Tcl_Interp *interp,
void *clientData, void **newClientData);
static ProcErrorProc MethodErrorHandler;
static ProcErrorProc ConstructorErrorHandler;
static ProcErrorProc DestructorErrorHandler;
static Tcl_Obj * RenderDeclarerName(void *clientData);
static int InvokeForwardMethod(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static void DeleteForwardMethod(void *clientData);
static int CloneForwardMethod(Tcl_Interp *interp,
void *clientData, void **newClientData);
static Tcl_ResolveVarProc ProcedureMethodVarResolver;
static Tcl_ResolveCompiledVarProc ProcedureMethodCompiledVarResolver;
/*
* The types of methods defined by the core OO system.
*/
static const Tcl_MethodType procMethodType = {
TCL_OO_METHOD_VERSION_CURRENT, "method",
|
| ︙ | ︙ | |||
131 132 133 134 135 136 137 | * Attach a method to an object instance. * * ---------------------------------------------------------------------- */ Tcl_Method Tcl_NewInstanceMethod( | | | | | | | | | | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 |
* Attach a method to an object instance.
*
* ----------------------------------------------------------------------
*/
Tcl_Method
Tcl_NewInstanceMethod(
TCL_UNUSED(Tcl_Interp *),
Tcl_Object object, /* The object that has the method attached to
* it. */
Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so,
* up to caller to manage storage (e.g., when
* it is a constructor or destructor). */
int flags, /* Whether this is a public method. */
const Tcl_MethodType *typePtr,
/* The type of method this is, which defines
* how to invoke, delete and clone the
* method. */
void *clientData) /* Some data associated with the particular
* method to be created. */
{
Object *oPtr = (Object *) object;
Method *mPtr;
Tcl_HashEntry *hPtr;
int isNew;
if (nameObj == NULL) {
mPtr = (Method *)ckalloc(sizeof(Method));
mPtr->namePtr = NULL;
mPtr->refCount = 1;
goto populate;
}
if (!oPtr->methodsPtr) {
oPtr->methodsPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitObjHashTable(oPtr->methodsPtr);
oPtr->flags &= ~USE_CLASS_CACHE;
}
hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) nameObj, &isNew);
if (isNew) {
mPtr = (Method *)ckalloc(sizeof(Method));
mPtr->namePtr = nameObj;
mPtr->refCount = 1;
Tcl_IncrRefCount(nameObj);
Tcl_SetHashValue(hPtr, mPtr);
} else {
mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
mPtr->typePtr->deleteProc(mPtr->clientData);
}
}
populate:
mPtr->typePtr = typePtr;
|
| ︙ | ︙ | |||
204 205 206 207 208 209 210 | * Attach a method to a class. * * ---------------------------------------------------------------------- */ Tcl_Method Tcl_NewMethod( | | | | | | | | | 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 |
* Attach a method to a class.
*
* ----------------------------------------------------------------------
*/
Tcl_Method
Tcl_NewMethod(
TCL_UNUSED(Tcl_Interp *),
Tcl_Class cls, /* The class to attach the method to. */
Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g.,
* for constructors or destructors); if so, up
* to caller to manage storage. */
int flags, /* Whether this is a public method. */
const Tcl_MethodType *typePtr,
/* The type of method this is, which defines
* how to invoke, delete and clone the
* method. */
void *clientData) /* Some data associated with the particular
* method to be created. */
{
Class *clsPtr = (Class *) cls;
Method *mPtr;
Tcl_HashEntry *hPtr;
int isNew;
if (nameObj == NULL) {
mPtr = (Method *)ckalloc(sizeof(Method));
mPtr->namePtr = NULL;
mPtr->refCount = 1;
goto populate;
}
hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)nameObj,&isNew);
if (isNew) {
mPtr = (Method *)ckalloc(sizeof(Method));
mPtr->refCount = 1;
mPtr->namePtr = nameObj;
Tcl_IncrRefCount(nameObj);
Tcl_SetHashValue(hPtr, mPtr);
} else {
mPtr = (Method *)Tcl_GetHashValue(hPtr);
if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
mPtr->typePtr->deleteProc(mPtr->clientData);
}
}
populate:
clsPtr->thisPtr->fPtr->epoch++;
|
| ︙ | ︙ | |||
282 283 284 285 286 287 288 |
if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
mPtr->typePtr->deleteProc(mPtr->clientData);
}
if (mPtr->namePtr != NULL) {
Tcl_DecrRefCount(mPtr->namePtr);
}
| | | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 |
if (mPtr->typePtr != NULL && mPtr->typePtr->deleteProc != NULL) {
mPtr->typePtr->deleteProc(mPtr->clientData);
}
if (mPtr->namePtr != NULL) {
Tcl_DecrRefCount(mPtr->namePtr);
}
ckfree(mPtr);
}
}
/*
* ----------------------------------------------------------------------
*
* TclOONewBasicMethod --
|
| ︙ | ︙ | |||
340 341 342 343 344 345 346 |
* NULL. */
ProcedureMethod **pmPtrPtr) /* Place to write pointer to procedure method
* structure to allow for deeper tuning of the
* structure's contents. NULL if caller is not
* interested. */
{
int argsLen;
| | | | | 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 |
* NULL. */
ProcedureMethod **pmPtrPtr) /* Place to write pointer to procedure method
* structure to allow for deeper tuning of the
* structure's contents. NULL if caller is not
* interested. */
{
int argsLen;
ProcedureMethod *pmPtr;
Tcl_Method method;
if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
return NULL;
}
pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod));
memset(pmPtr, 0, sizeof(ProcedureMethod));
pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
pmPtr->flags = flags & USE_DECLARER_NS;
pmPtr->refCount = 1;
method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj,
argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);
if (method == NULL) {
ckfree(pmPtr);
} else if (pmPtrPtr != NULL) {
*pmPtrPtr = pmPtr;
}
return (Method *) method;
}
/*
|
| ︙ | ︙ | |||
392 393 394 395 396 397 398 |
* NULL. */
ProcedureMethod **pmPtrPtr) /* Place to write pointer to procedure method
* structure to allow for deeper tuning of the
* structure's contents. NULL if caller is not
* interested. */
{
int argsLen; /* -1 => delete argsObj before exit */
| | | | | 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 |
* NULL. */
ProcedureMethod **pmPtrPtr) /* Place to write pointer to procedure method
* structure to allow for deeper tuning of the
* structure's contents. NULL if caller is not
* interested. */
{
int argsLen; /* -1 => delete argsObj before exit */
ProcedureMethod *pmPtr;
const char *procName;
Tcl_Method method;
if (argsObj == NULL) {
argsLen = -1;
argsObj = Tcl_NewObj();
Tcl_IncrRefCount(argsObj);
procName = "<destructor>";
} else if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
return NULL;
} else {
procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
}
pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod));
memset(pmPtr, 0, sizeof(ProcedureMethod));
pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
pmPtr->flags = flags & USE_DECLARER_NS;
pmPtr->refCount = 1;
method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, procName,
argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);
if (argsLen == -1) {
Tcl_DecrRefCount(argsObj);
}
if (method == NULL) {
ckfree(pmPtr);
} else if (pmPtrPtr != NULL) {
*pmPtrPtr = pmPtr;
}
return (Method *) method;
}
|
| ︙ | ︙ | |||
501 502 503 504 505 506 507 |
* proc body was not created by substitution.
* (FIXME: check that this is sane and correct!)
*/
if (context.line
&& (context.nline >= 4) && (context.line[3] >= 0)) {
int isNew;
| | | | 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 |
* proc body was not created by substitution.
* (FIXME: check that this is sane and correct!)
*/
if (context.line
&& (context.nline >= 4) && (context.line[3] >= 0)) {
int isNew;
CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame));
Tcl_HashEntry *hPtr;
cfPtr->level = -1;
cfPtr->type = context.type;
cfPtr->line = (int *)ckalloc(sizeof(int));
cfPtr->line[0] = context.line[3];
cfPtr->nline = 1;
cfPtr->framePtr = NULL;
cfPtr->nextPtr = NULL;
cfPtr->data.eval.path = context.data.eval.path;
Tcl_IncrRefCount(cfPtr->data.eval.path);
|
| ︙ | ︙ | |||
614 615 616 617 618 619 620 |
* proc body was not created by substitution.
* (FIXME: check that this is sane and correct!)
*/
if (context.line
&& (context.nline >= 4) && (context.line[3] >= 0)) {
int isNew;
| | | | 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 |
* proc body was not created by substitution.
* (FIXME: check that this is sane and correct!)
*/
if (context.line
&& (context.nline >= 4) && (context.line[3] >= 0)) {
int isNew;
CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame));
Tcl_HashEntry *hPtr;
cfPtr->level = -1;
cfPtr->type = context.type;
cfPtr->line = (int *)ckalloc(sizeof(int));
cfPtr->line[0] = context.line[3];
cfPtr->nline = 1;
cfPtr->framePtr = NULL;
cfPtr->nextPtr = NULL;
cfPtr->data.eval.path = context.data.eval.path;
Tcl_IncrRefCount(cfPtr->data.eval.path);
|
| ︙ | ︙ | |||
668 669 670 671 672 673 674 |
InvokeProcedureMethod(
void *clientData, /* Pointer to some per-method context. */
Tcl_Interp *interp,
Tcl_ObjectContext context, /* The method calling context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments as actually seen. */
{
| | | | > | > | | 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 |
InvokeProcedureMethod(
void *clientData, /* Pointer to some per-method context. */
Tcl_Interp *interp,
Tcl_ObjectContext context, /* The method calling context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments as actually seen. */
{
ProcedureMethod *pmPtr = (ProcedureMethod *)clientData;
int result;
PMFrameData *fdPtr; /* Important data that has to have a lifetime
* matched by this function (or rather, by the
* call frame's lifetime). */
/*
* If the object namespace (or interpreter) were deleted, we just skip to
* the next thing in the chain.
*/
if (TclOOObjectDestroyed(((CallContext *)context)->oPtr) ||
Tcl_InterpDeleted(interp)
) {
return TclNRObjectContextInvokeNext(interp, context, objc, objv,
Tcl_ObjectContextSkippedArgs(context));
}
/*
* Allocate the special frame data.
*/
fdPtr = (PMFrameData *)TclStackAlloc(interp, sizeof(PMFrameData));
/*
* Create a call frame for this method.
*/
result = PushMethodCallFrame(interp, (CallContext *) context, pmPtr,
objc, objv, fdPtr);
|
| ︙ | ︙ | |||
745 746 747 748 749 750 751 |
static int
FinalizePMCall(
void *data[],
Tcl_Interp *interp,
int result)
{
| | | | | 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 |
static int
FinalizePMCall(
void *data[],
Tcl_Interp *interp,
int result)
{
ProcedureMethod *pmPtr = (ProcedureMethod *)data[0];
Tcl_ObjectContext context = (Tcl_ObjectContext)data[1];
PMFrameData *fdPtr = (PMFrameData *)data[2];
/*
* Give the post-call callback a chance to do some cleanup. Note that at
* this point the call frame itself is invalid; it's already been popped.
*/
if (pmPtr->postCallProc) {
|
| ︙ | ︙ | |||
792 793 794 795 796 797 798 |
* method. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv, /* Array of arguments. */
PMFrameData *fdPtr) /* Place to store information about the call
* frame. */
{
Namespace *nsPtr = (Namespace *) contextPtr->oPtr->namespacePtr;
| | | 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 |
* method. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv, /* Array of arguments. */
PMFrameData *fdPtr) /* Place to store information about the call
* frame. */
{
Namespace *nsPtr = (Namespace *) contextPtr->oPtr->namespacePtr;
int result;
const char *namePtr;
CallFrame **framePtrPtr = &fdPtr->framePtr;
ByteCode *codePtr;
/*
* Compute basic information on the basis of the type of method it is.
*/
|
| ︙ | ︙ | |||
825 826 827 828 829 830 831 |
/*
* Magic to enable things like [incr Tcl], which wants methods to run in
* their class's namespace.
*/
if (pmPtr->flags & USE_DECLARER_NS) {
| | | 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 |
/*
* Magic to enable things like [incr Tcl], which wants methods to run in
* their class's namespace.
*/
if (pmPtr->flags & USE_DECLARER_NS) {
Method *mPtr =
contextPtr->callPtr->chain[contextPtr->index].mPtr;
if (mPtr->declaringClassPtr != NULL) {
nsPtr = (Namespace *)
mPtr->declaringClassPtr->thisPtr->namespacePtr;
} else {
nsPtr = (Namespace *) mPtr->declaringObjectPtr->namespacePtr;
|
| ︙ | ︙ | |||
896 897 898 899 900 901 902 |
fdPtr->efi.fields[0].proc = NULL;
fdPtr->efi.fields[0].clientData = fdPtr->nameObj;
if (pmPtr->gfivProc != NULL) {
fdPtr->efi.fields[1].name = "";
fdPtr->efi.fields[1].proc = pmPtr->gfivProc;
fdPtr->efi.fields[1].clientData = pmPtr;
} else {
| | | 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 |
fdPtr->efi.fields[0].proc = NULL;
fdPtr->efi.fields[0].clientData = fdPtr->nameObj;
if (pmPtr->gfivProc != NULL) {
fdPtr->efi.fields[1].name = "";
fdPtr->efi.fields[1].proc = pmPtr->gfivProc;
fdPtr->efi.fields[1].clientData = pmPtr;
} else {
Tcl_Method method =
Tcl_ObjectContextMethod((Tcl_ObjectContext) contextPtr);
if (Tcl_MethodDeclarerObject(method) != NULL) {
fdPtr->efi.fields[1].name = "object";
} else {
fdPtr->efi.fields[1].name = "class";
}
|
| ︙ | ︙ | |||
954 955 956 957 958 959 960 |
}
static int
ProcedureMethodVarResolver(
Tcl_Interp *interp,
const char *varName,
Tcl_Namespace *contextNs,
| | | 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 |
}
static int
ProcedureMethodVarResolver(
Tcl_Interp *interp,
const char *varName,
Tcl_Namespace *contextNs,
TCL_UNUSED(int) /*flags*/, /* Ignoring variable access flags (???) */
Tcl_Var *varPtr)
{
int result;
Tcl_ResolvedVarInfo *rPtr = NULL;
result = ProcedureMethodCompiledVarResolver(interp, varName,
strlen(varName), contextNs, &rPtr);
|
| ︙ | ︙ | |||
989 990 991 992 993 994 995 |
OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr;
Interp *iPtr = (Interp *) interp;
CallFrame *framePtr = iPtr->varFramePtr;
CallContext *contextPtr;
Tcl_Obj *variableObj;
PrivateVariableMapping *privateVar;
Tcl_HashEntry *hPtr;
| | < | | 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 |
OOResVarInfo *infoPtr = (OOResVarInfo *) rPtr;
Interp *iPtr = (Interp *) interp;
CallFrame *framePtr = iPtr->varFramePtr;
CallContext *contextPtr;
Tcl_Obj *variableObj;
PrivateVariableMapping *privateVar;
Tcl_HashEntry *hPtr;
int i, isNew, cacheIt, varLen, len;
const char *match, *varName;
/*
* Check that the variable is being requested in a context that is also a
* method call; if not (i.e. we're evaluating in the object's namespace or
* in a procedure of that namespace) then we do nothing.
*/
if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
return NULL;
}
contextPtr = (CallContext *)framePtr->clientData;
/*
* If we've done the work before (in a comparable context) then reuse that
* rather than performing resolution ourselves.
*/
if (infoPtr->cachedObjectVar) {
|
| ︙ | ︙ | |||
1097 1098 1099 1100 1101 1102 1103 |
*/
if (infoPtr->cachedObjectVar) {
VarHashRefCount(infoPtr->cachedObjectVar)--;
TclCleanupVar((Var *) infoPtr->cachedObjectVar, NULL);
}
Tcl_DecrRefCount(infoPtr->variableObj);
| | | | | | | | 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 |
*/
if (infoPtr->cachedObjectVar) {
VarHashRefCount(infoPtr->cachedObjectVar)--;
TclCleanupVar((Var *) infoPtr->cachedObjectVar, NULL);
}
Tcl_DecrRefCount(infoPtr->variableObj);
ckfree(infoPtr);
}
static int
ProcedureMethodCompiledVarResolver(
TCL_UNUSED(Tcl_Interp *),
const char *varName,
int length,
TCL_UNUSED(Tcl_Namespace *),
Tcl_ResolvedVarInfo **rPtrPtr)
{
OOResVarInfo *infoPtr;
Tcl_Obj *variableObj = Tcl_NewStringObj(varName, length);
/*
* Do not create resolvers for cases that contain namespace separators or
* which look like array accesses. Both will lead us astray.
*/
if (strstr(Tcl_GetString(variableObj), "::") != NULL ||
Tcl_StringMatch(Tcl_GetString(variableObj), "*(*)")) {
Tcl_DecrRefCount(variableObj);
return TCL_CONTINUE;
}
infoPtr = (OOResVarInfo *)ckalloc(sizeof(OOResVarInfo));
infoPtr->info.fetchProc = ProcedureMethodCompiledVarConnect;
infoPtr->info.deleteProc = ProcedureMethodCompiledVarDelete;
infoPtr->cachedObjectVar = NULL;
infoPtr->variableObj = variableObj;
Tcl_IncrRefCount(variableObj);
*rPtrPtr = &infoPtr->info;
return TCL_OK;
|
| ︙ | ︙ | |||
1149 1150 1151 1152 1153 1154 1155 |
* ----------------------------------------------------------------------
*/
static Tcl_Obj *
RenderDeclarerName(
void *clientData)
{
| | | 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 |
* ----------------------------------------------------------------------
*/
static Tcl_Obj *
RenderDeclarerName(
void *clientData)
{
struct PNI *pni = (struct PNI *)clientData;
Tcl_Object object = Tcl_MethodDeclarerObject(pni->method);
if (object == NULL) {
object = Tcl_GetClassAsObject(Tcl_MethodDeclarerClass(pni->method));
}
return TclOOObjectName(pni->interp, (Object *) object);
}
|
| ︙ | ︙ | |||
1173 1174 1175 1176 1177 1178 1179 1180 1181 | * and ELLIPSIFY is a macro to do the conversion (with the help of a * %.*s%s format field). Note that ELLIPSIFY is only safe for use in * suitable formatting contexts. * * ---------------------------------------------------------------------- */ #define LIMIT 60 #define ELLIPSIFY(str,len) \ | > > | | > | | | | > | | | | > | | | | 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 |
* and ELLIPSIFY is a macro to do the conversion (with the help of a
* %.*s%s format field). Note that ELLIPSIFY is only safe for use in
* suitable formatting contexts.
*
* ----------------------------------------------------------------------
*/
/* TODO: Check whether Tcl_AppendLimitedToObj() can work here. */
#define LIMIT 60
#define ELLIPSIFY(str,len) \
((len) > LIMIT ? LIMIT : (len)), (str), ((len) > LIMIT ? "..." : "")
static void
MethodErrorHandler(
Tcl_Interp *interp,
TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
/* We pull the method name out of context instead of from argument */
{
int nameLen, objectNameLen;
CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
const char *objectName, *kindName, *methodName =
TclGetStringFromObj(mPtr->namePtr, &nameLen);
Object *declarerPtr;
if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
kindName = "object";
} else {
if (mPtr->declaringClassPtr == NULL) {
Tcl_Panic("method not declared in class or object");
}
declarerPtr = mPtr->declaringClassPtr->thisPtr;
kindName = "class";
}
objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
&objectNameLen);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (%s \"%.*s%s\" method \"%.*s%s\" line %d)",
kindName, ELLIPSIFY(objectName, objectNameLen),
ELLIPSIFY(methodName, nameLen), Tcl_GetErrorLine(interp)));
}
static void
ConstructorErrorHandler(
Tcl_Interp *interp,
TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
/* Ignore. We know it is the constructor. */
{
CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
Object *declarerPtr;
const char *objectName, *kindName;
int objectNameLen;
if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
kindName = "object";
} else {
if (mPtr->declaringClassPtr == NULL) {
Tcl_Panic("method not declared in class or object");
}
declarerPtr = mPtr->declaringClassPtr->thisPtr;
kindName = "class";
}
objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
&objectNameLen);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (%s \"%.*s%s\" constructor line %d)", kindName,
ELLIPSIFY(objectName, objectNameLen), Tcl_GetErrorLine(interp)));
}
static void
DestructorErrorHandler(
Tcl_Interp *interp,
TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/)
/* Ignore. We know it is the destructor. */
{
CallContext *contextPtr = (CallContext *)((Interp *) interp)->varFramePtr->clientData;
Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
Object *declarerPtr;
const char *objectName, *kindName;
int objectNameLen;
if (mPtr->declaringObjectPtr != NULL) {
declarerPtr = mPtr->declaringObjectPtr;
kindName = "object";
} else {
if (mPtr->declaringClassPtr == NULL) {
Tcl_Panic("method not declared in class or object");
}
declarerPtr = mPtr->declaringClassPtr->thisPtr;
kindName = "class";
}
objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr),
&objectNameLen);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (%s \"%.*s%s\" destructor line %d)", kindName,
ELLIPSIFY(objectName, objectNameLen), Tcl_GetErrorLine(interp)));
}
/*
|
| ︙ | ︙ | |||
1284 1285 1286 1287 1288 1289 1290 |
DeleteProcedureMethodRecord(
ProcedureMethod *pmPtr)
{
TclProcDeleteProc(pmPtr->procPtr);
if (pmPtr->deleteClientdataProc) {
pmPtr->deleteClientdataProc(pmPtr->clientData);
}
| | | | | 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 |
DeleteProcedureMethodRecord(
ProcedureMethod *pmPtr)
{
TclProcDeleteProc(pmPtr->procPtr);
if (pmPtr->deleteClientdataProc) {
pmPtr->deleteClientdataProc(pmPtr->clientData);
}
ckfree(pmPtr);
}
static void
DeleteProcedureMethod(
void *clientData)
{
ProcedureMethod *pmPtr = (ProcedureMethod *)clientData;
if (pmPtr->refCount-- <= 1) {
DeleteProcedureMethodRecord(pmPtr);
}
}
static int
CloneProcedureMethod(
Tcl_Interp *interp,
void *clientData,
void **newClientData)
{
ProcedureMethod *pmPtr = (ProcedureMethod *)clientData;
ProcedureMethod *pm2Ptr;
Tcl_Obj *bodyObj, *argsObj;
CompiledLocal *localPtr;
/*
* Copy the argument list.
*/
|
| ︙ | ︙ | |||
1334 1335 1336 1337 1338 1339 1340 |
/*
* Must strip the internal representation in order to ensure that any
* bound references to instance variables are removed. [Bug 3609693]
*/
bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr);
| | | | | 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 |
/*
* Must strip the internal representation in order to ensure that any
* bound references to instance variables are removed. [Bug 3609693]
*/
bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr);
Tcl_GetString(bodyObj);
Tcl_StoreIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL);
/*
* Create the actual copy of the method record, manufacturing a new proc
* record.
*/
pm2Ptr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod));
memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod));
pm2Ptr->refCount = 1;
Tcl_IncrRefCount(argsObj);
Tcl_IncrRefCount(bodyObj);
if (TclCreateProc(interp, NULL, "", argsObj, bodyObj,
&pm2Ptr->procPtr) != TCL_OK) {
Tcl_DecrRefCount(argsObj);
Tcl_DecrRefCount(bodyObj);
ckfree(pm2Ptr);
return TCL_ERROR;
}
Tcl_DecrRefCount(argsObj);
Tcl_DecrRefCount(bodyObj);
if (pmPtr->cloneClientdataProc) {
pm2Ptr->clientData = pmPtr->cloneClientdataProc(pmPtr->clientData);
|
| ︙ | ︙ | |||
1384 1385 1386 1387 1388 1389 1390 |
Object *oPtr, /* The object to attach the method to. */
int flags, /* Whether the method is public or not. */
Tcl_Obj *nameObj, /* The name of the method. */
Tcl_Obj *prefixObj) /* List of arguments that form the command
* prefix to forward to. */
{
int prefixLen;
| | | | 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 |
Object *oPtr, /* The object to attach the method to. */
int flags, /* Whether the method is public or not. */
Tcl_Obj *nameObj, /* The name of the method. */
Tcl_Obj *prefixObj) /* List of arguments that form the command
* prefix to forward to. */
{
int prefixLen;
ForwardMethod *fmPtr;
if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
return NULL;
}
if (prefixLen < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method forward prefix must be non-empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
return NULL;
}
fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_IncrRefCount(prefixObj);
return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr,
nameObj, flags, &fwdMethodType, fmPtr);
}
/*
|
| ︙ | ︙ | |||
1423 1424 1425 1426 1427 1428 1429 |
Class *clsPtr, /* The class to attach the method to. */
int flags, /* Whether the method is public or not. */
Tcl_Obj *nameObj, /* The name of the method. */
Tcl_Obj *prefixObj) /* List of arguments that form the command
* prefix to forward to. */
{
int prefixLen;
| | | | 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 |
Class *clsPtr, /* The class to attach the method to. */
int flags, /* Whether the method is public or not. */
Tcl_Obj *nameObj, /* The name of the method. */
Tcl_Obj *prefixObj) /* List of arguments that form the command
* prefix to forward to. */
{
int prefixLen;
ForwardMethod *fmPtr;
if (Tcl_ListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) {
return NULL;
}
if (prefixLen < 1) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"method forward prefix must be non-empty", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
return NULL;
}
fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod));
fmPtr->prefixObj = prefixObj;
Tcl_IncrRefCount(prefixObj);
return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj,
flags, &fwdMethodType, fmPtr);
}
/*
|
| ︙ | ︙ | |||
1462 1463 1464 1465 1466 1467 1468 |
void *clientData, /* Pointer to some per-method context. */
Tcl_Interp *interp,
Tcl_ObjectContext context, /* The method calling context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments as actually seen. */
{
CallContext *contextPtr = (CallContext *) context;
| | | 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 |
void *clientData, /* Pointer to some per-method context. */
Tcl_Interp *interp,
Tcl_ObjectContext context, /* The method calling context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments as actually seen. */
{
CallContext *contextPtr = (CallContext *) context;
ForwardMethod *fmPtr = (ForwardMethod *)clientData;
Tcl_Obj **argObjs, **prefixObjs;
int numPrefixes, len, skip = contextPtr->skip;
/*
* Build the real list of arguments to use. Note that we know that the
* prefixObj field of the ForwardMethod structure holds a reference to a
* non-empty list, so there's a whole class of failures ("not a list") we
|
| ︙ | ︙ | |||
1493 1494 1495 1496 1497 1498 1499 |
static int
FinalizeForwardCall(
void *data[],
Tcl_Interp *interp,
int result)
{
| | | | | | | | 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 |
static int
FinalizeForwardCall(
void *data[],
Tcl_Interp *interp,
int result)
{
Tcl_Obj **argObjs = (Tcl_Obj **)data[0];
TclStackFree(interp, argObjs);
return result;
}
/*
* ----------------------------------------------------------------------
*
* DeleteForwardMethod, CloneForwardMethod --
*
* How to delete and clone forwarded methods.
*
* ----------------------------------------------------------------------
*/
static void
DeleteForwardMethod(
void *clientData)
{
ForwardMethod *fmPtr = (ForwardMethod *)clientData;
Tcl_DecrRefCount(fmPtr->prefixObj);
ckfree(fmPtr);
}
static int
CloneForwardMethod(
TCL_UNUSED(Tcl_Interp *),
void *clientData,
void **newClientData)
{
ForwardMethod *fmPtr = (ForwardMethod *)clientData;
ForwardMethod *fm2Ptr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod));
fm2Ptr->prefixObj = fmPtr->prefixObj;
Tcl_IncrRefCount(fm2Ptr->prefixObj);
*newClientData = fm2Ptr;
return TCL_OK;
}
|
| ︙ | ︙ | |||
1550 1551 1552 1553 1554 1555 1556 |
*/
Proc *
TclOOGetProcFromMethod(
Method *mPtr)
{
if (mPtr->typePtr == &procMethodType) {
| | | | | 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 |
*/
Proc *
TclOOGetProcFromMethod(
Method *mPtr)
{
if (mPtr->typePtr == &procMethodType) {
ProcedureMethod *pmPtr = (ProcedureMethod *)mPtr->clientData;
return pmPtr->procPtr;
}
return NULL;
}
Tcl_Obj *
TclOOGetMethodBody(
Method *mPtr)
{
if (mPtr->typePtr == &procMethodType) {
ProcedureMethod *pmPtr = (ProcedureMethod *)mPtr->clientData;
(void) TclGetString(pmPtr->procPtr->bodyPtr);
return pmPtr->procPtr->bodyPtr;
}
return NULL;
}
Tcl_Obj *
TclOOGetFwdFromMethod(
Method *mPtr)
{
if (mPtr->typePtr == &fwdMethodType) {
ForwardMethod *fwPtr = (ForwardMethod *)mPtr->clientData;
return fwPtr->prefixObj;
}
return NULL;
}
/*
|
| ︙ | ︙ | |||
1617 1618 1619 1620 1621 1622 1623 |
int toRewrite, /* Number of real arguments to replace. */
int rewriteLength, /* Number of arguments to insert instead. */
Tcl_Obj *const *rewriteObjs,/* Arguments to insert instead. */
int *lengthPtr) /* Where to write the resulting length of the
* array of rewritten arguments. */
{
unsigned len = rewriteLength + objc - toRewrite;
| | | 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 |
int toRewrite, /* Number of real arguments to replace. */
int rewriteLength, /* Number of arguments to insert instead. */
Tcl_Obj *const *rewriteObjs,/* Arguments to insert instead. */
int *lengthPtr) /* Where to write the resulting length of the
* array of rewritten arguments. */
{
unsigned len = rewriteLength + objc - toRewrite;
Tcl_Obj **argObjs = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * len);
memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *));
memcpy(argObjs + rewriteLength, objv + toRewrite,
sizeof(Tcl_Obj *) * (objc - toRewrite));
/*
* Now plumb this into the core ensemble rewrite logging system so that
|
| ︙ | ︙ |
Changes to generic/tclOOScript.h.
| ︙ | ︙ | |||
106 107 108 109 110 111 112 |
"\t\tset originDelegate [DelegateName $originObject]\n"
"\t\tset targetDelegate [DelegateName $targetObject]\n"
"\t\tif {\n"
"\t\t\t[info object isa class $originDelegate]\n"
"\t\t\t&& ![info object isa class $targetDelegate]\n"
"\t\t} then {\n"
"\t\t\tcopy $originDelegate $targetDelegate\n"
| | | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 |
"\t\tset originDelegate [DelegateName $originObject]\n"
"\t\tset targetDelegate [DelegateName $targetObject]\n"
"\t\tif {\n"
"\t\t\t[info object isa class $originDelegate]\n"
"\t\t\t&& ![info object isa class $targetDelegate]\n"
"\t\t} then {\n"
"\t\t\tcopy $originDelegate $targetDelegate\n"
"\t\t\tobjdefine $targetObject ::oo::objdefine::mixin -set \\\n"
"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n"
"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n"
"\t\t\t\t}]\n"
"\t\t}\n"
"\t}\n"
"\tproc define::classmethod {name {args {}} {body {}}} {\n"
"\t\t::set argc [::llength [::info level 0]]\n"
|
| ︙ | ︙ |
Deleted generic/tclOOScript.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to generic/tclObj.c.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | * 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. */ #include "tclInt.h" | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | * 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. */ #include "tclInt.h" #include "tclTomMath.h" #include <math.h> #include <assert.h> /* * Table of all object types. */ |
| ︙ | ︙ | |||
54 55 56 57 58 59 60 | #if TCL_THREADS && defined(TCL_MEM_DEBUG) /* * Structure for tracking the source file and line number where a given * Tcl_Obj was allocated. We also track the pointer to the Tcl_Obj itself, * for sanity checking purposes. */ | | | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 |
#if TCL_THREADS && defined(TCL_MEM_DEBUG)
/*
* Structure for tracking the source file and line number where a given
* Tcl_Obj was allocated. We also track the pointer to the Tcl_Obj itself,
* for sanity checking purposes.
*/
typedef struct ObjData {
Tcl_Obj *objPtr; /* The pointer to the allocated Tcl_Obj. */
const char *file; /* The name of the source file calling this
* function; used for debugging. */
int line; /* Line number in the source file; used for
* debugging. */
} ObjData;
#endif /* TCL_MEM_DEBUG && TCL_THREADS */
|
| ︙ | ︙ | |||
165 166 167 168 169 170 171 |
static __thread PendingObjData pendingObjData;
#define ObjInitDeletionContext(contextPtr) \
PendingObjData *const contextPtr = &pendingObjData
#else
static Tcl_ThreadDataKey pendingObjDataKey;
#define ObjInitDeletionContext(contextPtr) \
PendingObjData *const contextPtr = \
| | | | < < | < | > > > | 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 |
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);
static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void UpdateStringOfDouble(Tcl_Obj *objPtr);
static void UpdateStringOfInt(Tcl_Obj *objPtr);
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG)
static void UpdateStringOfOldInt(Tcl_Obj *objPtr);
#endif
static void FreeBignum(Tcl_Obj *objPtr);
static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
static void UpdateStringOfBignum(Tcl_Obj *objPtr);
static int GetBignumFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
int copy, mp_int *bignumValue);
/*
|
| ︙ | ︙ | |||
224 225 226 227 228 229 230 231 |
/*
* The structures below defines the Tcl object types defined in this file by
* means of functions that can be invoked by generic object code. See also
* tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager
* implementations.
*/
const Tcl_ObjType tclBooleanType = {
| > > > > > > > > > | > > > > > > > > > > > > > | 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 |
/*
* The structures below defines the Tcl object types defined in this file by
* means of functions that can be invoked by generic object code. See also
* tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager
* implementations.
*/
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
static const Tcl_ObjType oldBooleanType = {
"boolean", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
TclSetBooleanFromAny /* setFromAnyProc */
};
#endif
const Tcl_ObjType tclBooleanType = {
"booleanString", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
NULL, /* updateStringProc */
TclSetBooleanFromAny /* setFromAnyProc */
};
const Tcl_ObjType tclDoubleType = {
"double", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfDouble, /* updateStringProc */
SetDoubleFromAny /* setFromAnyProc */
};
const Tcl_ObjType tclIntType = {
#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 || defined(TCL_WIDE_INT_IS_LONG)
"int", /* name */
#else
"wideInt", /* name, keeping maximum compatibility with Tcl 8.6 on 32-bit platforms*/
#endif
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfInt, /* updateStringProc */
SetIntFromAny /* setFromAnyProc */
};
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG)
static const Tcl_ObjType oldIntType = {
"int", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfOldInt, /* updateStringProc */
SetIntFromAny /* setFromAnyProc */
};
#endif
const Tcl_ObjType tclBignumType = {
"bignum", /* name */
FreeBignum, /* freeIntRepProc */
DupBignum, /* dupIntRepProc */
UpdateStringOfBignum, /* updateStringProc */
NULL /* setFromAnyProc */
};
|
| ︙ | ︙ | |||
310 311 312 313 314 315 316 |
typedef struct ResolvedCmdName {
Command *cmdPtr; /* A cached Command pointer. */
Namespace *refNsPtr; /* Points to the namespace containing the
* reference (not the namespace that contains
* the referenced command). NULL if the name
* is fully qualified.*/
| | | | | 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 |
typedef struct ResolvedCmdName {
Command *cmdPtr; /* A cached Command pointer. */
Namespace *refNsPtr; /* Points to the namespace containing the
* reference (not the namespace that contains
* the referenced command). NULL if the name
* is fully qualified.*/
unsigned long refNsId; /* refNsPtr's unique namespace id. Used to
* verify that refNsPtr is still valid (e.g.,
* it's possible that the cmd's containing
* namespace was deleted and a new one created
* at the same address). */
unsigned int refNsCmdEpoch; /* Value of the referencing namespace's
* cmdRefEpoch when the pointer was cached.
* Before using the cached pointer, we check
* if the namespace's epoch was incremented;
* if so, this cached pointer is invalid. */
unsigned int cmdEpoch; /* Value of the command's cmdEpoch when this
* pointer was cached. Before using the cached
* pointer, we check if the cmd's epoch was
* incremented; if so, the cmd was renamed,
* deleted, hidden, or exposed, and so the
* pointer is invalid. */
size_t refCount; /* Reference count: 1 for each cmdName object
* that has a pointer to this ResolvedCmdName
|
| ︙ | ︙ | |||
368 369 370 371 372 373 374 375 376 377 378 379 380 381 |
Tcl_RegisterObjType(&tclStringType);
Tcl_RegisterObjType(&tclListType);
Tcl_RegisterObjType(&tclDictType);
Tcl_RegisterObjType(&tclByteCodeType);
Tcl_RegisterObjType(&tclCmdNameType);
Tcl_RegisterObjType(&tclRegexpType);
Tcl_RegisterObjType(&tclProcBodyType);
#ifdef TCL_COMPILE_STATS
Tcl_MutexLock(&tclObjMutex);
tclObjsAlloced = 0;
tclObjsFreed = 0;
{
int i;
| > > > > > > > > > | 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 |
Tcl_RegisterObjType(&tclStringType);
Tcl_RegisterObjType(&tclListType);
Tcl_RegisterObjType(&tclDictType);
Tcl_RegisterObjType(&tclByteCodeType);
Tcl_RegisterObjType(&tclCmdNameType);
Tcl_RegisterObjType(&tclRegexpType);
Tcl_RegisterObjType(&tclProcBodyType);
/* For backward compatibility only ... */
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
Tcl_RegisterObjType(&tclIntType);
#if !defined(TCL_WIDE_INT_IS_LONG)
Tcl_RegisterObjType(&oldIntType);
#endif
Tcl_RegisterObjType(&oldBooleanType);
#endif
#ifdef TCL_COMPILE_STATS
Tcl_MutexLock(&tclObjMutex);
tclObjsAlloced = 0;
tclObjsFreed = 0;
{
int i;
|
| ︙ | ︙ | |||
413 414 415 416 417 418 419 |
Tcl_HashSearch hSearch;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;
if (tablePtr != NULL) {
for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
| | | | | 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 |
Tcl_HashSearch hSearch;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;
if (tablePtr != NULL) {
for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr);
if (objData != NULL) {
ckfree(objData);
}
}
Tcl_DeleteHashTable(tablePtr);
ckfree(tablePtr);
tsdPtr->objThreadMap = NULL;
}
#endif
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
497 498 499 500 501 502 503 |
* would be the natural place for this is invoked afterwards, meaning that
* we try to operate on a data structure already gone.
*/
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->lineCLPtr) {
| | | 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 |
* would be the natural place for this is invoked afterwards, meaning that
* we try to operate on a data structure already gone.
*/
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->lineCLPtr) {
tsdPtr->lineCLPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS);
Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL);
}
return tsdPtr;
}
/*
|
| ︙ | ︙ | |||
532 533 534 535 536 537 538 |
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(sizeof(ContLineLoc) + num*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
|
| ︙ | ︙ | |||
556 557 558 559 560 561 562 | * TclContinuationsEnterDerived for this case, which modified the * stored locations (Rebased to the proper relative offset). Just * returning the stored entry would rebase them a second time, or * more, hosing the data. It is easier to simply replace, as we are * doing. */ | | | 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 |
* TclContinuationsEnterDerived for this case, which modified the
* stored locations (Rebased to the proper relative offset). Just
* returning the stored entry would rebase them a second time, or
* more, hosing the data. It is easier to simply replace, as we are
* doing.
*/
ckfree(Tcl_GetHashValue(hPtr));
}
clLocPtr->num = num;
memcpy(&clLocPtr->loc, loc, num*sizeof(int));
clLocPtr->loc[num] = CLL_END; /* Sentinel */
Tcl_SetHashValue(hPtr, clLocPtr);
|
| ︙ | ︙ | |||
592 593 594 595 596 597 598 |
void
TclContinuationsEnterDerived(
Tcl_Obj *objPtr,
int start,
int *clNext)
{
| | < | 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 |
void
TclContinuationsEnterDerived(
Tcl_Obj *objPtr,
int start,
int *clNext)
{
int length, end, num;
int *wordCLLast = clNext;
/*
* We have to handle invisible continuations lines here as well, despite
* the code we have in TclSubstTokens (TST) for that. Why ? Nesting. If
* our script is the sole argument to an 'eval' command, for example, the
* scriptCLLocPtr we are using was generated by a previous call to TST,
|
| ︙ | ︙ | |||
620 621 622 623 624 625 626 |
*/
/*
* First compute the range of the word within the script. (Is there a
* better way which doesn't shimmer?)
*/
| | | 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 |
*/
/*
* First compute the range of the word within the script. (Is there a
* better way which doesn't shimmer?)
*/
TclGetStringFromObj(objPtr, &length);
end = start + length; /* First char after the word */
/*
* Then compute the table slice covering the range of the word.
*/
while (*wordCLLast >= 0 && *wordCLLast < end) {
|
| ︙ | ︙ | |||
690 691 692 693 694 695 696 |
Tcl_Obj *originObjPtr)
{
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr);
if (hPtr) {
| | | 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 |
Tcl_Obj *originObjPtr)
{
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr);
if (hPtr) {
ContLineLoc *clLocPtr = (ContLineLoc *)Tcl_GetHashValue(hPtr);
TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc);
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
726 727 728 729 730 731 732 |
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (!hPtr) {
return NULL;
}
| | | 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 |
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (!hPtr) {
return NULL;
}
return (ContLineLoc *)Tcl_GetHashValue(hPtr);
}
/*
*----------------------------------------------------------------------
*
* TclThreadFinalizeContLines --
*
|
| ︙ | ︙ | |||
749 750 751 752 753 754 755 | * * TIP #280 *---------------------------------------------------------------------- */ static void TclThreadFinalizeContLines( | | | | | 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 |
*
* TIP #280
*----------------------------------------------------------------------
*/
static void
TclThreadFinalizeContLines(
TCL_UNUSED(ClientData))
{
/*
* Release the hashtable tracking invisible continuation lines.
*/
ThreadSpecificData *tsdPtr = TclGetContLineTable();
Tcl_HashEntry *hPtr;
Tcl_HashSearch hSearch;
for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
ckfree(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(tsdPtr->lineCLPtr);
ckfree(tsdPtr->lineCLPtr);
tsdPtr->lineCLPtr = NULL;
}
/*
*--------------------------------------------------------------
*
* Tcl_RegisterObjType --
|
| ︙ | ︙ | |||
833 834 835 836 837 838 839 |
int
Tcl_AppendAllObjTypes(
Tcl_Interp *interp, /* Interpreter used for error reporting. */
Tcl_Obj *objPtr) /* Points to the Tcl object onto which the
* name of each registered type is appended as
* a list element. */
{
| | | | 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 |
int
Tcl_AppendAllObjTypes(
Tcl_Interp *interp, /* Interpreter used for error reporting. */
Tcl_Obj *objPtr) /* Points to the Tcl object onto which the
* name of each registered type is appended as
* a list element. */
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
int numElems;
/*
* Get the test for a valid list out of the way first.
*/
if (TclListObjLength(interp, objPtr, &numElems) != TCL_OK) {
return TCL_ERROR;
}
/*
* Type names are NUL-terminated, not counted strings. This code relies on
* that.
*/
Tcl_MutexLock(&tableMutex);
for (hPtr = Tcl_FirstHashEntry(&typeTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Tcl_ListObjAppendElement(NULL, objPtr,
Tcl_NewStringObj((char *)Tcl_GetHashKey(&typeTable, hPtr), -1));
}
Tcl_MutexUnlock(&tableMutex);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
881 882 883 884 885 886 887 |
*----------------------------------------------------------------------
*/
const Tcl_ObjType *
Tcl_GetObjType(
const char *typeName) /* Name of Tcl object type to look up. */
{
| | | | 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 |
*----------------------------------------------------------------------
*/
const Tcl_ObjType *
Tcl_GetObjType(
const char *typeName) /* Name of Tcl object type to look up. */
{
Tcl_HashEntry *hPtr;
const Tcl_ObjType *typePtr = NULL;
Tcl_MutexLock(&tableMutex);
hPtr = Tcl_FindHashEntry(&typeTable, typeName);
if (hPtr != NULL) {
typePtr = (const Tcl_ObjType *)Tcl_GetHashValue(hPtr);
}
Tcl_MutexUnlock(&tableMutex);
return typePtr;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
958 959 960 961 962 963 964 965 966 967 968 |
*
* Side effects:
* None.
*
*--------------------------------------------------------------
*/
void
TclDbDumpActiveObjects(
FILE *outFile)
{
| > < | | > | > > > > > | 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 |
*
* Side effects:
* None.
*
*--------------------------------------------------------------
*/
#if TCL_THREADS && defined(TCL_MEM_DEBUG)
void
TclDbDumpActiveObjects(
FILE *outFile)
{
Tcl_HashSearch hSearch;
Tcl_HashEntry *hPtr;
Tcl_HashTable *tablePtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
tablePtr = tsdPtr->objThreadMap;
if (tablePtr != NULL) {
fprintf(outFile, "total objects: %d\n", tablePtr->numEntries);
for (hPtr = Tcl_FirstHashEntry(tablePtr, &hSearch); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr);
if (objData != NULL) {
fprintf(outFile,
"key = 0x%p, objPtr = 0x%p, file = %s, line = %d\n",
Tcl_GetHashKey(tablePtr, hPtr), objData->objPtr,
objData->file, objData->line);
} else {
fprintf(outFile, "key = 0x%p\n",
Tcl_GetHashKey(tablePtr, hPtr));
}
}
}
}
#else
void
TclDbDumpActiveObjects(
TCL_UNUSED(FILE *))
{
}
#endif
/*
*----------------------------------------------------------------------
*
* TclDbInitNewObj --
*
* Called via the TclNewObj or TclDbNewObj macros when TCL_MEM_DEBUG is
|
| ︙ | ︙ | |||
1011 1012 1013 1014 1015 1016 1017 | * None. *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG void TclDbInitNewObj( | | | | | | | 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 |
* None.
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
void
TclDbInitNewObj(
Tcl_Obj *objPtr,
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
objPtr->refCount = 0;
objPtr->typePtr = NULL;
TclInitStringRep(objPtr, NULL, 0);
#if TCL_THREADS
/*
* Add entry to a thread local map used to check if a Tcl_Obj was
* allocated by the currently executing thread.
*/
if (!TclInExit()) {
Tcl_HashEntry *hPtr;
Tcl_HashTable *tablePtr;
int isNew;
ObjData *objData;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->objThreadMap == NULL) {
tsdPtr->objThreadMap = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS);
}
tablePtr = tsdPtr->objThreadMap;
hPtr = Tcl_CreateHashEntry(tablePtr, objPtr, &isNew);
if (!isNew) {
Tcl_Panic("expected to create new entry for object map");
}
/*
* Record the debugging information.
*/
objData = (ObjData *)ckalloc(sizeof(ObjData));
objData->objPtr = objPtr;
objData->file = file;
objData->line = line;
Tcl_SetHashValue(hPtr, objData);
}
#endif /* TCL_THREADS */
}
|
| ︙ | ︙ | |||
1098 1099 1100 1101 1102 1103 1104 |
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewObj(void)
{
| | | 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 |
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewObj(void)
{
Tcl_Obj *objPtr;
/*
* Use the macro defined in tclInt.h - it will use the correct allocator.
*/
TclNewObj(objPtr);
return objPtr;
|
| ︙ | ︙ | |||
1140 1141 1142 1143 1144 1145 1146 | *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewObj( | | | | | < | < | | 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 |
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewObj(
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
Tcl_Obj *objPtr;
/*
* Use the macro defined in tclInt.h - it will use the correct allocator.
*/
TclDbNewObj(objPtr, file, line);
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewObj(
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewObj();
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* TclAllocateFreeObjects --
*
* Function to allocate a number of free Tcl_Objs. This is done using a
* single ckalloc to reduce the overhead for Tcl_Obj allocation.
*
* Assumes mutex is held.
*
* Results:
* None.
*
* Side effects:
|
| ︙ | ︙ | |||
1195 1196 1197 1198 1199 1200 1201 |
#define OBJS_TO_ALLOC_EACH_TIME 100
void
TclAllocateFreeObjects(void)
{
size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj));
char *basePtr;
| | | | | | 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 |
#define OBJS_TO_ALLOC_EACH_TIME 100
void
TclAllocateFreeObjects(void)
{
size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj));
char *basePtr;
Tcl_Obj *prevPtr, *objPtr;
int i;
/*
* This has been noted by Purify to be a potential leak. The problem is
* that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated
* Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of actually
* freeing the memory. TclFinalizeObjects() does not ckfree() this memory,
* but leaves it to Tcl's memory subsystem finalization to release it.
* Purify apparently can't figure that out, and fires a false alarm.
*/
basePtr = (char *)ckalloc(bytesToAlloc);
prevPtr = NULL;
objPtr = (Tcl_Obj *) basePtr;
for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
objPtr->internalRep.twoPtrValue.ptr1 = prevPtr;
prevPtr = objPtr;
objPtr++;
|
| ︙ | ︙ | |||
1247 1248 1249 1250 1251 1252 1253 | * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG void TclFreeObj( | | | | 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 |
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
void
TclFreeObj(
Tcl_Obj *objPtr) /* The object to be freed. */
{
const Tcl_ObjType *typePtr = objPtr->typePtr;
/*
* This macro declares a variable, so must come here...
*/
ObjInitDeletionContext(context);
|
| ︙ | ︙ | |||
1279 1280 1281 1282 1283 1284 1285 |
}
hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
if (hPtr) {
/*
* As the Tcl_Obj is going to be deleted we remove the entry.
*/
| | | | | | | | | | 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 |
}
hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr);
if (hPtr) {
/*
* As the Tcl_Obj is going to be deleted we remove the entry.
*/
ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr);
if (objData != NULL) {
ckfree(objData);
}
Tcl_DeleteHashEntry(hPtr);
}
}
# endif
/*
* Check for a double free of the same value. This is slightly tricky
* because it is customary to free a Tcl_Obj when its refcount falls
* either from 1 to 0, or from 0 to -1. Falling from -1 to -2, though,
* and so on, is always a sign of a botch in the caller.
*/
if (objPtr->refCount < -1) {
Tcl_Panic("Reference count for %p was negative", objPtr);
}
/*
* Now, in case we just approved drop from 1 to 0 as acceptable, make
* sure we do not accept a second free when falling from 0 to -1.
* Skip that possibility so any double free will trigger the panic.
*/
objPtr->refCount = -1;
/*
* Invalidate the string rep first so we can use the bytes value for our
* pointer chain, and signal an obj deletion (as opposed to shimmering)
* with 'length == -1'.
*/
TclInvalidateStringRep(objPtr);
objPtr->length = -1;
if (ObjDeletePending(context)) {
PushObjToDelete(context, objPtr);
} else {
TCL_DTRACE_OBJ_FREE(objPtr);
if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
ObjDeletionLock(context);
typePtr->freeIntRepProc(objPtr);
ObjDeletionUnlock(context);
}
Tcl_MutexLock(&tclObjMutex);
ckfree(objPtr);
Tcl_MutexUnlock(&tclObjMutex);
TclIncrObjsFreed();
ObjDeletionLock(context);
while (ObjOnStack(context)) {
Tcl_Obj *objToFree;
PopObjToDelete(context, objToFree);
TCL_DTRACE_OBJ_FREE(objToFree);
TclFreeIntRep(objToFree);
Tcl_MutexLock(&tclObjMutex);
ckfree(objToFree);
Tcl_MutexUnlock(&tclObjMutex);
TclIncrObjsFreed();
}
ObjDeletionUnlock(context);
}
/*
|
| ︙ | ︙ | |||
1362 1363 1364 1365 1366 1367 1368 |
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashEntry *hPtr;
if (tsdPtr->lineCLPtr) {
hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (hPtr) {
| | | | | 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 |
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashEntry *hPtr;
if (tsdPtr->lineCLPtr) {
hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (hPtr) {
ckfree(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
}
}
}
}
#else /* TCL_MEM_DEBUG */
void
TclFreeObj(
Tcl_Obj *objPtr) /* The object to be freed. */
{
/*
* Invalidate the string rep first so we can use the bytes value for our
* pointer chain, and signal an obj deletion (as opposed to shimmering)
* with 'length == -1'.
*/
TclInvalidateStringRep(objPtr);
objPtr->length = -1;
if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) {
/*
* objPtr can be freed safely, as it will not attempt to free any
* other objects: it will not cause recursive calls to this function.
*/
|
| ︙ | ︙ | |||
1453 1454 1455 1456 1457 1458 1459 |
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashEntry *hPtr;
if (tsdPtr->lineCLPtr) {
hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (hPtr) {
| | | 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 |
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_HashEntry *hPtr;
if (tsdPtr->lineCLPtr) {
hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
if (hPtr) {
ckfree(Tcl_GetHashValue(hPtr));
Tcl_DeleteHashEntry(hPtr);
}
}
}
}
#endif /* TCL_MEM_DEBUG */
|
| ︙ | ︙ | |||
1483 1484 1485 1486 1487 1488 1489 |
*----------------------------------------------------------------------
*/
int
TclObjBeingDeleted(
Tcl_Obj *objPtr)
{
| | | 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 |
*----------------------------------------------------------------------
*/
int
TclObjBeingDeleted(
Tcl_Obj *objPtr)
{
return (objPtr->length == -1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_DuplicateObj --
*
|
| ︙ | ︙ | |||
1581 1582 1583 1584 1585 1586 1587 | * representation from the internal representation. * *---------------------------------------------------------------------- */ char * Tcl_GetString( | | | | 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 |
* representation from the internal representation.
*
*----------------------------------------------------------------------
*/
char *
Tcl_GetString(
Tcl_Obj *objPtr) /* Object whose string rep byte pointer should
* be returned. */
{
if (objPtr->bytes == NULL) {
/*
* Note we do not check for objPtr->typePtr == NULL. An invariant
* of a properly maintained Tcl_Obj is that at least one of
* objPtr->bytes and objPtr->typePtr must not be NULL. If broken
* extensions fail to maintain that invariant, we can crash here.
*/
if (objPtr->typePtr->updateStringProc == NULL) {
/*
* Those Tcl_ObjTypes which choose not to define an
* updateStringProc must be written in such a way that
* (objPtr->bytes) never becomes NULL.
*/
Tcl_Panic("UpdateStringProc should not be invoked for type %s",
objPtr->typePtr->name);
}
objPtr->typePtr->updateStringProc(objPtr);
if (objPtr->bytes == NULL || objPtr->length < 0
|| objPtr->bytes[objPtr->length] != '\0') {
Tcl_Panic("UpdateStringProc for type '%s' "
"failed to create a valid string rep",
objPtr->typePtr->name);
}
}
return objPtr->bytes;
|
| ︙ | ︙ | |||
1637 1638 1639 1640 1641 1642 1643 | * representation from the internal representation. * *---------------------------------------------------------------------- */ char * Tcl_GetStringFromObj( | | | | 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 |
* representation from the internal representation.
*
*----------------------------------------------------------------------
*/
char *
Tcl_GetStringFromObj(
Tcl_Obj *objPtr, /* Object whose string rep byte pointer should
* be returned. */
int *lengthPtr) /* If non-NULL, the location where the string
* rep's byte array length should * be stored.
* If NULL, no length is stored. */
{
if (objPtr->bytes == NULL) {
/*
* Note we do not check for objPtr->typePtr == NULL. An invariant
* of a properly maintained Tcl_Obj is that at least one of
|
| ︙ | ︙ | |||
1661 1662 1663 1664 1665 1666 1667 |
* updateStringProc must be written in such a way that
* (objPtr->bytes) never becomes NULL.
*/
Tcl_Panic("UpdateStringProc should not be invoked for type %s",
objPtr->typePtr->name);
}
objPtr->typePtr->updateStringProc(objPtr);
| | | | | | | | 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 |
* updateStringProc must be written in such a way that
* (objPtr->bytes) never becomes NULL.
*/
Tcl_Panic("UpdateStringProc should not be invoked for type %s",
objPtr->typePtr->name);
}
objPtr->typePtr->updateStringProc(objPtr);
if (objPtr->bytes == NULL || objPtr->length < 0
|| objPtr->bytes[objPtr->length] != '\0') {
Tcl_Panic("UpdateStringProc for type '%s' "
"failed to create a valid string rep",
objPtr->typePtr->name);
}
}
if (lengthPtr != NULL) {
*lengthPtr = objPtr->length;
}
return objPtr->bytes;
}
/*
*----------------------------------------------------------------------
*
* Tcl_InitStringRep --
*
* This function is called in several configurations to provide all
* the tools needed to set an object's string representation. The
* function is determined by the arguments.
*
* (objPtr->bytes != NULL && bytes != NULL) || (numBytes < 0)
* Invalid call -- panic!
*
* objPtr->bytes == NULL && bytes == NULL && numBytes >= 0
* Allocation only - allocate space for (numBytes+1) chars.
* store in objPtr->bytes and return. Also sets
* objPtr->length to 0 and objPtr->bytes[0] to NUL.
*
* objPtr->bytes == NULL && bytes != NULL && numBytes >= 0
* Allocate and copy. bytes is assumed to point to chars to
* copy into the string rep. objPtr->length = numBytes. Allocate
* array of (numBytes + 1) chars. store in objPtr->bytes. Copy
* numBytes chars from bytes to objPtr->bytes; Set
* objPtr->bytes[numBytes] to NUL and return objPtr->bytes.
* Caller must guarantee there are numBytes chars at bytes to
* be copied.
*
* objPtr->bytes != NULL && bytes == NULL && numBytes >= 0
* Truncate. Set objPtr->length to numBytes and
* objPr->bytes[numBytes] to NUL. Caller has to guarantee
* that a prior allocating call allocated enough bytes for
* this to be valid. Return objPtr->bytes.
*
* Caller is expected to ascertain that the bytes copied into
* the string rep make up complete valid UTF-8 characters.
|
| ︙ | ︙ | |||
1722 1723 1724 1725 1726 1727 1728 |
*----------------------------------------------------------------------
*/
char *
Tcl_InitStringRep(
Tcl_Obj *objPtr, /* Object whose string rep is to be set */
const char *bytes,
| | > > > > | | | | | 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 |
*----------------------------------------------------------------------
*/
char *
Tcl_InitStringRep(
Tcl_Obj *objPtr, /* Object whose string rep is to be set */
const char *bytes,
unsigned int numBytes)
{
assert(objPtr->bytes == NULL || bytes == NULL);
if (numBytes > INT_MAX) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
/* Allocate */
if (objPtr->bytes == NULL) {
/* Allocate only as empty - extend later if bytes copied */
objPtr->length = 0;
if (numBytes) {
objPtr->bytes = (char *)attemptckalloc(numBytes + 1);
if (objPtr->bytes == NULL) {
return NULL;
}
if (bytes) {
/* Copy */
memcpy(objPtr->bytes, bytes, numBytes);
objPtr->length = (int) numBytes;
}
} else {
TclInitStringRep(objPtr, NULL, 0);
}
} else {
/* objPtr->bytes != NULL bytes == NULL - Truncate */
objPtr->bytes = (char *)ckrealloc(objPtr->bytes, numBytes + 1);
objPtr->length = (int)numBytes;
}
/* Terminate */
objPtr->bytes[objPtr->length] = '\0';
return objPtr->bytes;
}
|
| ︙ | ︙ | |||
1775 1776 1777 1778 1779 1780 1781 | * the string representation NULL to mark it invalid. * *---------------------------------------------------------------------- */ void Tcl_InvalidateStringRep( | | | 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 |
* the string representation NULL to mark it invalid.
*
*----------------------------------------------------------------------
*/
void
Tcl_InvalidateStringRep(
Tcl_Obj *objPtr) /* Object whose string rep byte pointer should
* be freed. */
{
TclInvalidateStringRep(objPtr);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
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 |
{
TclFreeIntRep(objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetBooleanFromObj --
*
* Attempt to return a boolean from the Tcl object "objPtr". This
* includes conversion from any of Tcl's numeric types.
*
* Results:
* The return value is a standard Tcl object result. If an error occurs
* during conversion, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
* Side effects:
* The intrep of *objPtr may be changed.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetBooleanFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > > > > | 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 |
{
TclFreeIntRep(objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_NewBooleanObj --
*
* This function is normally called when not debugging: i.e., when
* TCL_MEM_DEBUG is not defined. It creates a new Tcl_Obj and
* initializes it from the argument boolean value. A nonzero "boolValue"
* is coerced to 1.
*
* When TCL_MEM_DEBUG is defined, this function just returns the result
* of calling the debugging version Tcl_DbNewLongObj.
*
* Results:
* The newly created object is returned. This object will have an invalid
* string representation. The returned object has ref count 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#undef Tcl_NewBooleanObj
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_NewBooleanObj(
int boolValue) /* Boolean used to initialize new object. */
{
return Tcl_DbNewWideIntObj(boolValue!=0, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewBooleanObj(
int boolValue) /* Boolean used to initialize new object. */
{
Tcl_Obj *objPtr;
TclNewIntObj(objPtr, boolValue!=0);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_DbNewBooleanObj --
*
* This function is normally called when debugging: i.e., when
* TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the
* same as the Tcl_NewBooleanObj function above except that it calls
* Tcl_DbCkalloc directly with the file name and line number from its
* caller. This simplifies debugging since then the [memory active]
* command will report the correct file name and line number when
* reporting objects that haven't been freed.
*
* When TCL_MEM_DEBUG is not defined, this function just returns the
* result of calling Tcl_NewBooleanObj.
*
* Results:
* The newly created object is returned. This object will have an invalid
* string representation. The returned object has ref count 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
#undef Tcl_DbNewBooleanObj
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewBooleanObj(
int boolValue, /* Boolean used to initialize new object. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
/* Optimized TclInvalidateStringRep() */
objPtr->bytes = NULL;
objPtr->internalRep.wideValue = (boolValue != 0);
objPtr->typePtr = &tclIntType;
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewBooleanObj(
int boolValue, /* Boolean used to initialize new object. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewBooleanObj(boolValue);
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_SetBooleanObj --
*
* Modify an object to be a boolean object and to have the specified
* boolean value. A nonzero "boolValue" is coerced to 1.
*
* Results:
* None.
*
* Side effects:
* The object's old string rep, if any, is freed. Also, any old internal
* rep is freed.
*
*----------------------------------------------------------------------
*/
#undef Tcl_SetBooleanObj
void
Tcl_SetBooleanObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
int boolValue) /* Boolean used to set object's value. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj");
}
TclSetIntObj(objPtr, boolValue!=0);
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_GetBooleanFromObj --
*
* Attempt to return a boolean from the Tcl object "objPtr". This
* includes conversion from any of Tcl's numeric types.
*
* Results:
* The return value is a standard Tcl object result. If an error occurs
* during conversion, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
* Side effects:
* The intrep of *objPtr may be changed.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetBooleanFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get boolean. */
int *boolPtr) /* Place to store resulting boolean. */
{
do {
if (objPtr->typePtr == &tclIntType) {
*boolPtr = (objPtr->internalRep.wideValue != 0);
return TCL_OK;
}
if (objPtr->typePtr == &tclBooleanType) {
*boolPtr = objPtr->internalRep.longValue != 0;
return TCL_OK;
}
if (objPtr->typePtr == &tclDoubleType) {
/*
* Caution: Don't be tempted to check directly for the "double"
* Tcl_ObjType and then compare the intrep to 0.0. This isn't
* reliable because a "double" Tcl_ObjType can hold the NaN value.
* Use the API Tcl_GetDoubleFromObj, which does the checking and
|
| ︙ | ︙ | |||
1963 1964 1965 1966 1967 1968 1969 | * Results: * The return value is a standard Tcl result. If an error occurs during * conversion, an error message is left in the interpreter's result * unless "interp" is NULL. * * Side effects: * If no error occurs, an integer 1 or 0 is stored as "objPtr"s internal | | > > > > > | | 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 |
* Results:
* The return value is a standard Tcl result. If an error occurs during
* conversion, an error message is left in the interpreter's result
* unless "interp" is NULL.
*
* Side effects:
* If no error occurs, an integer 1 or 0 is stored as "objPtr"s internal
* representation and the type of "objPtr" is set to boolean or int/wideInt.
*
* Warning: If the returned type is "wideInt" (32-bit platforms) and your
* platform is bigendian, you cannot use internalRep.longValue to distinguish
* between false and true. On Windows and most other platforms this still will
* work fine, but basically it is non-portable.
*
*----------------------------------------------------------------------
*/
int
TclSetBooleanFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
/*
* For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine
* whether a boolean conversion is possible without generating the string
* rep.
*/
|
| ︙ | ︙ | |||
2002 2003 2004 2005 2006 2007 2008 |
if (ParseBoolean(objPtr) == TCL_OK) {
return TCL_OK;
}
badBoolean:
if (interp != NULL) {
| | | < | > | 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 |
if (ParseBoolean(objPtr) == TCL_OK) {
return TCL_OK;
}
badBoolean:
if (interp != NULL) {
int length;
const char *str = TclGetStringFromObj(objPtr, &length);
Tcl_Obj *msg;
TclNewLiteralStringObj(msg, "expected boolean value but got \"");
Tcl_AppendLimitedToObj(msg, str, length, 50, "");
Tcl_AppendToObj(msg, "\"", -1);
Tcl_SetObjResult(interp, msg);
Tcl_SetErrorCode(interp, "TCL", "VALUE", "BOOLEAN", NULL);
}
return TCL_ERROR;
}
static int
ParseBoolean(
Tcl_Obj *objPtr) /* The object to parse/convert. */
{
int newBool;
char lowerCase[6];
const char *str = TclGetString(objPtr);
size_t i, length = objPtr->length;
if ((length == 0) || (length > 5)) {
/*
* Longest valid boolean string rep. is "false".
*/
return TCL_ERROR;
|
| ︙ | ︙ | |||
2121 2122 2123 2124 2125 2126 2127 |
* Free the old internalRep before setting the new one. We do this as late
* as possible to allow the conversion code, in particular
* Tcl_GetStringFromObj, to use that old internalRep.
*/
goodBoolean:
TclFreeIntRep(objPtr);
| | | 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 |
* Free the old internalRep before setting the new one. We do this as late
* as possible to allow the conversion code, in particular
* Tcl_GetStringFromObj, to use that old internalRep.
*/
goodBoolean:
TclFreeIntRep(objPtr);
objPtr->internalRep.longValue = newBool;
objPtr->typePtr = &tclBooleanType;
return TCL_OK;
numericBoolean:
TclFreeIntRep(objPtr);
objPtr->internalRep.wideValue = newBool;
objPtr->typePtr = &tclIntType;
|
| ︙ | ︙ | |||
2159 2160 2161 2162 2163 2164 2165 | */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewDoubleObj Tcl_Obj * Tcl_NewDoubleObj( | | | | | 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 |
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewDoubleObj
Tcl_Obj *
Tcl_NewDoubleObj(
double dblValue) /* Double used to initialize the object. */
{
return Tcl_DbNewDoubleObj(dblValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewDoubleObj(
double dblValue) /* Double used to initialize the object. */
{
Tcl_Obj *objPtr;
TclNewDoubleObj(objPtr, dblValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
/*
|
| ︙ | ︙ | |||
2207 2208 2209 2210 2211 2212 2213 | *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewDoubleObj( | | | | | < | < | 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 |
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewDoubleObj(
double dblValue, /* Double used to initialize the object. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
/* Optimized TclInvalidateStringRep() */
objPtr->bytes = NULL;
objPtr->internalRep.doubleValue = dblValue;
objPtr->typePtr = &tclDoubleType;
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewDoubleObj(
double dblValue, /* Double used to initialize the object. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewDoubleObj(dblValue);
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2258 2259 2260 2261 2262 2263 2264 | * rep is freed. * *---------------------------------------------------------------------- */ void Tcl_SetDoubleObj( | | | | 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 |
* rep is freed.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetDoubleObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
double dblValue) /* Double used to set the object's value. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetDoubleObj");
}
TclSetDoubleObj(objPtr, dblValue);
}
|
| ︙ | ︙ | |||
2291 2292 2293 2294 2295 2296 2297 |
*
*----------------------------------------------------------------------
*/
int
Tcl_GetDoubleFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
| | | | 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 |
*
*----------------------------------------------------------------------
*/
int
Tcl_GetDoubleFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get a double. */
double *dblPtr) /* Place to store resulting double. */
{
do {
if (objPtr->typePtr == &tclDoubleType) {
if (TclIsNaN(objPtr->internalRep.doubleValue)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"floating point value is Not a Number", -1));
|
| ︙ | ︙ | |||
2346 2347 2348 2349 2350 2351 2352 |
*
*----------------------------------------------------------------------
*/
static int
SetDoubleFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
| | > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | | < < | < | | < | | | < < | | | | | 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 |
*
*----------------------------------------------------------------------
*/
static int
SetDoubleFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
return TclParseNumber(interp, objPtr, "floating-point number", NULL, -1,
NULL, 0);
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfDouble --
*
* Update the string representation for a double-precision floating point
* object. This must obey the current tcl_precision value for
* double-to-string conversions. Note: This function does not free an
* existing old string rep so storage will be lost if this has not
* already been done.
*
* Results:
* None.
*
* Side effects:
* The object's string is set to a valid string that results from the
* double-to-string conversion.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfDouble(
Tcl_Obj *objPtr) /* Double obj with string rep to update. */
{
char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_DOUBLE_SPACE);
TclOOM(dst, TCL_DOUBLE_SPACE + 1);
Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, dst);
(void) Tcl_InitStringRep(objPtr, NULL, strlen(dst));
}
/*
*----------------------------------------------------------------------
*
* Tcl_NewIntObj --
*
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
* Tcl_NewIntObj to create a new integer object end up calling the
* debugging function Tcl_DbNewLongObj instead.
*
* Otherwise, if the client is compiled without TCL_MEM_DEBUG defined,
* calls to Tcl_NewIntObj result in a call to one of the two
* Tcl_NewIntObj implementations below. We provide two implementations so
* that the Tcl core can be compiled to do memory debugging of the core
* even if a client does not request it for itself.
*
* Integer and long integer objects share the same "integer" type
* implementation. We store all integers as longs and Tcl_GetIntFromObj
* checks whether the current value of the long can be represented by an
* int.
*
* Results:
* The newly created object is returned. This object will have an invalid
* string representation. The returned object has ref count 0.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
#undef Tcl_NewIntObj
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_NewIntObj(
int intValue) /* Int used to initialize the new object. */
{
return Tcl_DbNewWideIntObj((long)intValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewIntObj(
int intValue) /* Int used to initialize the new object. */
{
Tcl_Obj *objPtr;
TclNewIntObj(objPtr, intValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_SetIntObj --
*
* Modify an object to be an integer and to have the specified integer
* value.
*
* Results:
* None.
*
* Side effects:
* The object's old string rep, if any, is freed. Also, any old internal
* rep is freed.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
#undef Tcl_SetIntObj
void
Tcl_SetIntObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
int intValue) /* Integer used to set object's value. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetIntObj");
}
TclSetIntObj(objPtr, intValue);
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_GetIntFromObj --
*
* Attempt to return an int from the Tcl object "objPtr". If the object
* is not already an int, an attempt will be made to convert it to one.
*
* Integer and long integer objects share the same "integer" type
* implementation. We store all integers as longs and Tcl_GetIntFromObj
* checks whether the current value of the long can be represented by an
* int.
*
* Results:
* The return value is a standard Tcl object result. If an error occurs
* during conversion or if the long integer held by the object can not be
* represented by an int, an error message is left in the interpreter's
* result unless "interp" is NULL.
*
* Side effects:
* If the object is not already an int, the conversion will free any old
* internal representation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetIntFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get a int. */
int *intPtr) /* Place to store resulting int. */
{
#if (LONG_MAX == INT_MAX)
return TclGetLongFromObj(interp, objPtr, (long *) intPtr);
#else
long l;
if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) {
|
| ︙ | ︙ | |||
2487 2488 2489 2490 2491 2492 2493 | * int-to-string conversion. * *---------------------------------------------------------------------- */ static void UpdateStringOfInt( | | > > > > > > > > > > > > > | 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 |
* int-to-string conversion.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfInt(
Tcl_Obj *objPtr) /* Int object whose string rep to update. */
{
char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE);
TclOOM(dst, TCL_INTEGER_SPACE + 1);
(void) Tcl_InitStringRep(objPtr, NULL,
TclFormatInt(dst, objPtr->internalRep.wideValue));
}
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG)
static void
UpdateStringOfOldInt(
Tcl_Obj *objPtr) /* Int object whose string rep to update. */
{
char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE);
TclOOM(dst, TCL_INTEGER_SPACE + 1);
(void) Tcl_InitStringRep(objPtr, NULL,
TclFormatInt(dst, objPtr->internalRep.longValue));
}
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_NewLongObj --
*
* If a client is compiled with TCL_MEM_DEBUG defined, calls to
|
| ︙ | ︙ | |||
2532 2533 2534 2535 2536 2537 2538 | #ifndef TCL_NO_DEPRECATED #undef Tcl_NewLongObj #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_NewLongObj( | | | | | 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 |
#ifndef TCL_NO_DEPRECATED
#undef Tcl_NewLongObj
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_NewLongObj(
long longValue) /* Long integer used to initialize the
* new object. */
{
return Tcl_DbNewWideIntObj(longValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewLongObj(
long longValue) /* Long integer used to initialize the
* new object. */
{
Tcl_Obj *objPtr;
TclNewIntObj(objPtr, longValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
#endif /* TCL_NO_DEPRECATED */
|
| ︙ | ︙ | |||
2591 2592 2593 2594 2595 2596 2597 | #ifndef TCL_NO_DEPRECATED #undef Tcl_DbNewLongObj #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewLongObj( | | | | | < | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
#ifndef TCL_NO_DEPRECATED
#undef Tcl_DbNewLongObj
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewLongObj(
long longValue, /* Long integer used to initialize the new
* object. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
/* Optimized TclInvalidateStringRep */
objPtr->bytes = NULL;
objPtr->internalRep.wideValue = longValue;
objPtr->typePtr = &tclIntType;
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewLongObj(
long longValue, /* Long integer used to initialize the new
* object. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewWideIntObj(longValue);
}
#endif /* TCL_MEM_DEBUG */
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_SetLongObj --
*
* Modify an object to be an integer object and to have the specified
* long integer value.
*
* Results:
* None.
*
* Side effects:
* The object's old string rep, if any, is freed. Also, any old internal
* rep is freed.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
#undef Tcl_SetLongObj
void
Tcl_SetLongObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
long longValue) /* Long integer used to initialize the
* object's value. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetLongObj");
}
TclSetIntObj(objPtr, longValue);
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_GetLongFromObj --
*
|
| ︙ | ︙ | |||
2649 2650 2651 2652 2653 2654 2655 |
*
*----------------------------------------------------------------------
*/
int
Tcl_GetLongFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
| | | | 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 |
*
*----------------------------------------------------------------------
*/
int
Tcl_GetLongFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* The object from which to get a long. */
long *longPtr) /* Place to store resulting long. */
{
do {
#ifdef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclIntType) {
*longPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
|
| ︙ | ︙ | |||
2695 2696 2697 2698 2699 2700 2701 2702 | /* * Must check for those bignum values that can fit in a long, even * when auto-narrowing is enabled. Only those values in the signed * long range get auto-narrowed to tclIntType, while all the * values in the unsigned long range will fit in a long. */ mp_int big; | > | > | > | 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 |
/*
* Must check for those bignum values that can fit in a long, even
* when auto-narrowing is enabled. Only those values in the signed
* long range get auto-narrowed to tclIntType, while all the
* values in the unsigned long range will fit in a long.
*/
{
mp_int big;
unsigned long scratch, value = 0;
unsigned char *bytes = (unsigned char *) &scratch;
size_t numBytes;
TclUnpackBignum(objPtr, big);
if (mp_to_ubin(&big, bytes, sizeof(long), &numBytes) == MP_OKAY) {
while (numBytes-- > 0) {
value = (value << CHAR_BIT) | *bytes++;
}
if (big.sign) {
if (value <= 1 + (unsigned long)LONG_MAX) {
*longPtr = - (long) value;
return TCL_OK;
}
} else {
if (value <= (unsigned long)ULONG_MAX) {
*longPtr = (long) value;
return TCL_OK;
}
}
}
}
#ifndef TCL_WIDE_INT_IS_LONG
tooLarge:
#endif
if (interp != NULL) {
const char *s = "integer value too large to represent";
Tcl_Obj *msg = Tcl_NewStringObj(s, -1);
|
| ︙ | ︙ | |||
2763 2764 2765 2766 2767 2768 2769 | */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewWideIntObj Tcl_Obj * Tcl_NewWideIntObj( | | | | | 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 |
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewWideIntObj
Tcl_Obj *
Tcl_NewWideIntObj(
Tcl_WideInt wideValue)
/* Wide integer used to initialize the new
* object. */
{
return Tcl_DbNewWideIntObj(wideValue, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewWideIntObj(
Tcl_WideInt wideValue)
/* Wide integer used to initialize the new
* object. */
{
Tcl_Obj *objPtr;
TclNewObj(objPtr);
TclSetIntObj(objPtr, wideValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
|
| ︙ | ︙ | |||
2822 2823 2824 2825 2826 2827 2828 | *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewWideIntObj( | | | | | < | < | 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 |
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewWideIntObj(
Tcl_WideInt wideValue,
/* Wide integer used to initialize the new
* object. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
TclSetIntObj(objPtr, wideValue);
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewWideIntObj(
Tcl_WideInt wideValue,
/* Long integer used to initialize the new
* object. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewWideIntObj(wideValue);
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2873 2874 2875 2876 2877 2878 2879 | * rep is freed. * *---------------------------------------------------------------------- */ void Tcl_SetWideIntObj( | | | | 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 |
* rep is freed.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetWideIntObj(
Tcl_Obj *objPtr, /* Object w. internal rep to init. */
Tcl_WideInt wideValue)
/* Wide integer used to initialize the
* object's value. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj");
}
|
| ︙ | ︙ | |||
2909 2910 2911 2912 2913 2914 2915 |
*
*----------------------------------------------------------------------
*/
int
Tcl_GetWideIntFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
| | | | 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 |
*
*----------------------------------------------------------------------
*/
int
Tcl_GetWideIntFromObj(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object from which to get a wide int. */
Tcl_WideInt *wideIntPtr)
/* Place to store resulting long. */
{
do {
if (objPtr->typePtr == &tclIntType) {
*wideIntPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
|
| ︙ | ︙ | |||
2935 2936 2937 2938 2939 2940 2941 | /* * Must check for those bignum values that can fit in a * Tcl_WideInt, even when auto-narrowing is enabled. */ mp_int big; Tcl_WideUInt value = 0; | | | | 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 |
/*
* Must check for those bignum values that can fit in a
* Tcl_WideInt, even when auto-narrowing is enabled.
*/
mp_int big;
Tcl_WideUInt value = 0;
size_t numBytes;
Tcl_WideInt scratch;
unsigned char *bytes = (unsigned char *) &scratch;
TclUnpackBignum(objPtr, big);
if (mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes) == MP_OKAY) {
while (numBytes-- > 0) {
value = (value << CHAR_BIT) | *bytes++;
}
if (big.sign) {
if (value <= 1 + ~(Tcl_WideUInt)WIDE_MIN) {
*wideIntPtr = - (Tcl_WideInt) value;
return TCL_OK;
|
| ︙ | ︙ | |||
3014 3015 3016 3017 3018 3019 3020 3021 3022 |
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
}
return TCL_ERROR;
}
if (objPtr->typePtr == &tclBignumType) {
mp_int big;
Tcl_WideUInt value = 0, scratch;
| > | | > | > > > > | 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 |
TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
}
return TCL_ERROR;
}
if (objPtr->typePtr == &tclBignumType) {
mp_int big;
mp_err err;
Tcl_WideUInt value = 0, scratch;
size_t numBytes;
unsigned char *bytes = (unsigned char *) &scratch;
Tcl_GetBignumFromObj(NULL, objPtr, &big);
err = mp_mod_2d(&big, (int) (CHAR_BIT * sizeof(Tcl_WideInt)), &big);
if (err == MP_OKAY) {
err = mp_to_ubin(&big, bytes, sizeof(Tcl_WideInt), &numBytes);
}
if (err != MP_OKAY) {
return TCL_ERROR;
}
while (numBytes-- > 0) {
value = (value << CHAR_BIT) | *bytes++;
}
*wideIntPtr = !big.sign ? (Tcl_WideInt)value : -(Tcl_WideInt)value;
mp_clear(&big);
return TCL_OK;
}
|
| ︙ | ︙ | |||
3056 3057 3058 3059 3060 3061 3062 |
Tcl_Obj *objPtr)
{
mp_int toFree; /* Bignum to free */
TclUnpackBignum(objPtr, toFree);
mp_clear(&toFree);
if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) < 0) {
| | | 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 |
Tcl_Obj *objPtr)
{
mp_int toFree; /* Bignum to free */
TclUnpackBignum(objPtr, toFree);
mp_clear(&toFree);
if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) < 0) {
ckfree(objPtr->internalRep.twoPtrValue.ptr1);
}
objPtr->typePtr = NULL;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3141 3142 3143 3144 3145 3146 3147 |
Tcl_Panic("UpdateStringOfBignum: string length limit exceeded");
}
stringVal = Tcl_InitStringRep(objPtr, NULL, size - 1);
TclOOM(stringVal, size);
| | | 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 |
Tcl_Panic("UpdateStringOfBignum: string length limit exceeded");
}
stringVal = Tcl_InitStringRep(objPtr, NULL, size - 1);
TclOOM(stringVal, size);
if (MP_OKAY != mp_to_radix(&bignumVal, stringVal, size, NULL, 10)) {
Tcl_Panic("conversion failure in UpdateStringOfBignum");
}
(void) Tcl_InitStringRep(objPtr, NULL, size - 1);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
3168 3169 3170 3171 3172 3173 3174 | */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewBignumObj Tcl_Obj * Tcl_NewBignumObj( | | | | 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 |
*/
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewBignumObj
Tcl_Obj *
Tcl_NewBignumObj(
void *bignumValue)
{
return Tcl_DbNewBignumObj(bignumValue, "unknown", 0);
}
#else
Tcl_Obj *
Tcl_NewBignumObj(
void *bignumValue)
{
Tcl_Obj *objPtr;
TclNewObj(objPtr);
Tcl_SetBignumObj(objPtr, bignumValue);
return objPtr;
}
|
| ︙ | ︙ | |||
3206 3207 3208 3209 3210 3211 3212 | * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewBignumObj( | | | | | | 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 |
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewBignumObj(
void *bignumValue,
const char *file,
int line)
{
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
Tcl_SetBignumObj(objPtr, bignumValue);
return objPtr;
}
#else
Tcl_Obj *
Tcl_DbNewBignumObj(
void *bignumValue,
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewBignumObj(bignumValue);
}
#endif
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
3261 3262 3263 3264 3265 3266 3267 |
{
do {
if (objPtr->typePtr == &tclBignumType) {
if (copy || Tcl_IsShared(objPtr)) {
mp_int temp;
TclUnpackBignum(objPtr, temp);
| | > > | | > > | 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 |
{
do {
if (objPtr->typePtr == &tclBignumType) {
if (copy || Tcl_IsShared(objPtr)) {
mp_int temp;
TclUnpackBignum(objPtr, temp);
if (mp_init_copy(bignumValue, &temp) != MP_OKAY) {
return TCL_ERROR;
}
} else {
TclUnpackBignum(objPtr, *bignumValue);
/* Optimized TclFreeIntRep */
objPtr->internalRep.twoPtrValue.ptr1 = NULL;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = NULL;
/*
* TODO: If objPtr has a string rep, this leaves
* it undisturbed. Not clear that's proper. Pure
* bignum values are converted to empty string.
*/
if (objPtr->bytes == NULL) {
TclInitStringRep(objPtr, NULL, 0);
}
}
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
if (mp_init_i64(bignumValue,
objPtr->internalRep.wideValue) != MP_OKAY) {
return TCL_ERROR;
}
return TCL_OK;
}
if (objPtr->typePtr == &tclDoubleType) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
TclGetString(objPtr)));
|
| ︙ | ︙ | |||
3327 3328 3329 3330 3331 3332 3333 |
*----------------------------------------------------------------------
*/
int
Tcl_GetBignumFromObj(
Tcl_Interp *interp, /* Tcl interpreter for error reporting */
Tcl_Obj *objPtr, /* Object to read */
| | | | 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 |
*----------------------------------------------------------------------
*/
int
Tcl_GetBignumFromObj(
Tcl_Interp *interp, /* Tcl interpreter for error reporting */
Tcl_Obj *objPtr, /* Object to read */
void *bignumValue) /* Returned bignum value. */
{
return GetBignumFromObj(interp, objPtr, 1, (mp_int *)bignumValue);
}
/*
*----------------------------------------------------------------------
*
* Tcl_TakeBignumFromObj --
*
|
| ︙ | ︙ | |||
3362 3363 3364 3365 3366 3367 3368 |
*----------------------------------------------------------------------
*/
int
Tcl_TakeBignumFromObj(
Tcl_Interp *interp, /* Tcl interpreter for error reporting */
Tcl_Obj *objPtr, /* Object to read */
| | | | 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 |
*----------------------------------------------------------------------
*/
int
Tcl_TakeBignumFromObj(
Tcl_Interp *interp, /* Tcl interpreter for error reporting */
Tcl_Obj *objPtr, /* Object to read */
void *bignumValue) /* Returned bignum value. */
{
return GetBignumFromObj(interp, objPtr, 0, (mp_int *)bignumValue);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetBignumObj --
*
|
| ︙ | ︙ | |||
3387 3388 3389 3390 3391 3392 3393 |
*
*----------------------------------------------------------------------
*/
void
Tcl_SetBignumObj(
Tcl_Obj *objPtr, /* Object to set */
| | | > | | 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 |
*
*----------------------------------------------------------------------
*/
void
Tcl_SetBignumObj(
Tcl_Obj *objPtr, /* Object to set */
void *big) /* Value to store */
{
Tcl_WideUInt value = 0;
size_t numBytes;
Tcl_WideUInt scratch;
unsigned char *bytes = (unsigned char *) &scratch;
mp_int *bignumValue = (mp_int *) big;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj");
}
if (mp_to_ubin(bignumValue, bytes, sizeof(Tcl_WideUInt), &numBytes) != MP_OKAY) {
goto tooLargeForWide;
}
while (numBytes-- > 0) {
value = (value << CHAR_BIT) | *bytes++;
}
if (value > ((Tcl_WideUInt)WIDE_MAX + bignumValue->sign)) {
goto tooLargeForWide;
|
| ︙ | ︙ | |||
3440 3441 3442 3443 3444 3445 3446 |
*
*----------------------------------------------------------------------
*/
void
TclSetBignumIntRep(
Tcl_Obj *objPtr,
| | > | 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 |
*
*----------------------------------------------------------------------
*/
void
TclSetBignumIntRep(
Tcl_Obj *objPtr,
void *big)
{
mp_int *bignumValue = (mp_int *)big;
objPtr->typePtr = &tclBignumType;
PACK_BIGNUM(*bignumValue, objPtr);
/*
* Clear the mp_int value.
*
* Don't call mp_clear() because it would free the digit array we just
|
| ︙ | ︙ | |||
3501 3502 3503 3504 3505 3506 3507 |
if (objPtr->typePtr == &tclIntType) {
*typePtr = TCL_NUMBER_INT;
*clientDataPtr = &objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclBignumType) {
static Tcl_ThreadDataKey bignumKey;
| | > | 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 |
if (objPtr->typePtr == &tclIntType) {
*typePtr = TCL_NUMBER_INT;
*clientDataPtr = &objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclBignumType) {
static Tcl_ThreadDataKey bignumKey;
mp_int *bigPtr = (mp_int *)Tcl_GetThreadData(&bignumKey,
sizeof(mp_int));
TclUnpackBignum(objPtr, *bigPtr);
*typePtr = TCL_NUMBER_BIG;
*clientDataPtr = bigPtr;
return TCL_OK;
}
} while (TCL_OK ==
|
| ︙ | ︙ | |||
3575 3576 3577 3578 3579 3580 3581 |
*/
#undef Tcl_IsShared
int
Tcl_IsShared(
Tcl_Obj *objPtr) /* The object to test for being shared. */
{
| | | 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 |
*/
#undef Tcl_IsShared
int
Tcl_IsShared(
Tcl_Obj *objPtr) /* The object to test for being shared. */
{
return ((objPtr)->refCount > 1);
}
/*
*----------------------------------------------------------------------
*
* Tcl_DbIncrRefCount --
*
|
| ︙ | ︙ | |||
3599 3600 3601 3602 3603 3604 3605 3606 3607 | * * Side effects: * The object's ref count is incremented. * *---------------------------------------------------------------------- */ void Tcl_DbIncrRefCount( | > | < | 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 |
*
* Side effects:
* The object's ref count is incremented.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
void
Tcl_DbIncrRefCount(
Tcl_Obj *objPtr, /* The object we are registering a reference
* to. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
Tcl_Panic("incrementing refCount of previously disposed object");
}
#if TCL_THREADS
|
| ︙ | ︙ | |||
3637 3638 3639 3640 3641 3642 3643 |
hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
if (!hPtr) {
Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
"incr ref count");
}
}
# endif /* TCL_THREADS */
| > > | > > > > > > > > | 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 |
hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
if (!hPtr) {
Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
"incr ref count");
}
}
# endif /* TCL_THREADS */
++(objPtr)->refCount;
}
#else /* !TCL_MEM_DEBUG */
void
Tcl_DbIncrRefCount(
Tcl_Obj *objPtr, /* The object we are registering a reference
* to. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
++(objPtr)->refCount;
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_DbDecrRefCount --
*
* This function is normally called when debugging: i.e., when
|
| ︙ | ︙ | |||
3662 3663 3664 3665 3666 3667 3668 3669 3670 | * * Side effects: * The object's ref count is incremented. * *---------------------------------------------------------------------- */ void Tcl_DbDecrRefCount( | > | < | 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 |
*
* Side effects:
* The object's ref count is incremented.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
void
Tcl_DbDecrRefCount(
Tcl_Obj *objPtr, /* The object we are releasing a reference
* to. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
Tcl_Panic("decrementing refCount of previously disposed object");
}
#if TCL_THREADS
|
| ︙ | ︙ | |||
3700 3701 3702 3703 3704 3705 3706 |
hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
if (!hPtr) {
Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
"decr ref count");
}
}
# endif /* TCL_THREADS */
| > > > > > | > > > > > > | > | 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 |
hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
if (!hPtr) {
Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
"decr ref count");
}
}
# endif /* TCL_THREADS */
if (objPtr->refCount-- <= 1) {
TclFreeObj(objPtr);
}
}
#else /* !TCL_MEM_DEBUG */
void
Tcl_DbDecrRefCount(
Tcl_Obj *objPtr, /* The object we are releasing a reference
* to. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
if (objPtr->refCount-- <= 1) {
TclFreeObj(objPtr);
}
}
#endif /* TCL_MEM_DEBUG */
/*
*----------------------------------------------------------------------
*
* Tcl_DbIsShared --
*
* This function is normally called when debugging: i.e., when
|
| ︙ | ︙ | |||
3730 3731 3732 3733 3734 3735 3736 | * None. * *---------------------------------------------------------------------- */ int Tcl_DbIsShared( | | > > > > > | 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 |
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_DbIsShared(
Tcl_Obj *objPtr, /* The object to test for being shared. */
#ifdef TCL_MEM_DEBUG
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
#else
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
#endif
{
#ifdef TCL_MEM_DEBUG
if (objPtr->refCount == 0x61616161) {
fprintf(stderr, "file = %s, line = %d\n", file, line);
fflush(stderr);
Tcl_Panic("checking whether previously disposed object is shared");
}
|
| ︙ | ︙ | |||
3802 3803 3804 3805 3806 3807 3808 | * Tcl_CreateHashEntry. * *---------------------------------------------------------------------- */ void Tcl_InitObjHashTable( | | | 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 |
* Tcl_CreateHashEntry.
*
*----------------------------------------------------------------------
*/
void
Tcl_InitObjHashTable(
Tcl_HashTable *tablePtr)
/* Pointer to table record, which is supplied
* by the caller. */
{
Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS,
&tclObjHashKeyType);
}
|
| ︙ | ︙ | |||
3828 3829 3830 3831 3832 3833 3834 | * Increments the reference count on the object. * *---------------------------------------------------------------------- */ static Tcl_HashEntry * AllocObjEntry( | | | | 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 |
* Increments the reference count on the object.
*
*----------------------------------------------------------------------
*/
static Tcl_HashEntry *
AllocObjEntry(
TCL_UNUSED(Tcl_HashTable *),
void *keyPtr) /* Key to store in the hash table entry. */
{
Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
Tcl_HashEntry *hPtr = (Tcl_HashEntry *)ckalloc(sizeof(Tcl_HashEntry));
hPtr->key.objPtr = objPtr;
Tcl_IncrRefCount(objPtr);
hPtr->clientData = NULL;
return hPtr;
}
|
| ︙ | ︙ | |||
3863 3864 3865 3866 3867 3868 3869 |
*/
int
TclCompareObjKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
| | | | | 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 |
*/
int
TclCompareObjKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
Tcl_Obj *objPtr1 = (Tcl_Obj *)keyPtr;
Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue;
const char *p1, *p2;
size_t l1, l2;
/*
* If the object pointers are the same then they match.
* OPT: this comparison was moved to the caller
if (objPtr1 == objPtr2) return 1;
*/
|
| ︙ | ︙ | |||
3926 3927 3928 3929 3930 3931 3932 |
void
TclFreeObjEntry(
Tcl_HashEntry *hPtr) /* Hash entry to free. */
{
Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue;
Tcl_DecrRefCount(objPtr);
| | | 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 |
void
TclFreeObjEntry(
Tcl_HashEntry *hPtr) /* Hash entry to free. */
{
Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue;
Tcl_DecrRefCount(objPtr);
ckfree(hPtr);
}
/*
*----------------------------------------------------------------------
*
* TclHashObjKey --
*
|
| ︙ | ︙ | |||
3949 3950 3951 3952 3953 3954 3955 | * None. * *---------------------------------------------------------------------- */ TCL_HASH_TYPE TclHashObjKey( | | > | < | 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 |
* None.
*
*----------------------------------------------------------------------
*/
TCL_HASH_TYPE
TclHashObjKey(
TCL_UNUSED(Tcl_HashTable *),
void *keyPtr) /* Key from which to compute hash value. */
{
Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
int length;
const char *string = TclGetStringFromObj(objPtr, &length);
TCL_HASH_TYPE result = 0;
/*
* I tried a zillion different hash functions and asked many other people
* for advice. Many people had their own favorite functions, all
* different, but no-one had much idea why they were good ones. I chose
* the one below (multiply by 9 and add new character) because of the
|
| ︙ | ︙ | |||
3991 3992 3993 3994 3995 3996 3997 |
*
* See also HashStringKey in tclHash.c.
* See also HashString in tclLiteral.c.
*
* See [tcl-Feature Request #2958832]
*/
| | | 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 |
*
* See also HashStringKey in tclHash.c.
* See also HashString in tclLiteral.c.
*
* See [tcl-Feature Request #2958832]
*/
if (length > 0) {
result = UCHAR(*string);
while (--length) {
result += (result << 3) + UCHAR(*++string);
}
}
return result;
}
|
| ︙ | ︙ | |||
4023 4024 4025 4026 4027 4028 4029 |
*----------------------------------------------------------------------
*/
Tcl_Command
Tcl_GetCommandFromObj(
Tcl_Interp *interp, /* The interpreter in which to resolve the
* command and to report errors. */
| | | | | | | | 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 |
*----------------------------------------------------------------------
*/
Tcl_Command
Tcl_GetCommandFromObj(
Tcl_Interp *interp, /* The interpreter in which to resolve the
* command and to report errors. */
Tcl_Obj *objPtr) /* The object containing the command's name.
* If the name starts with "::", will be
* looked up in global namespace. Else, looked
* up first in the current namespace, then in
* global namespace. */
{
ResolvedCmdName *resPtr;
/*
* Get the internal representation, converting to a command type if
* needed. The internal representation is a ResolvedCmdName that points to
* the actual command.
*
* Check the context namespace and the namespace epoch of the resolved
* symbol to make sure that it is fresh. Note that we verify that the
* namespace id of the context namespace is the same as the one we cached;
* this insures that the namespace wasn't deleted and a new one created at
* the same address with the same command epoch. Note that fully qualified
* names have a NULL refNsPtr, these checks needn't be made.
*
* Check also that the command's epoch is up to date, and that the command
* is not deleted.
*
* If any check fails, then force another conversion to the command type,
* to discard the old rep and create a new one.
*/
resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
if (objPtr->typePtr == &tclCmdNameType) {
Command *cmdPtr = resPtr->cmdPtr;
if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch)
&& (interp == cmdPtr->nsPtr->interp)
&& !(cmdPtr->nsPtr->flags & NS_DYING)) {
Namespace *refNsPtr = (Namespace *)
TclGetCurrentNamespace(interp);
if ((resPtr->refNsPtr == NULL)
|| ((refNsPtr == resPtr->refNsPtr)
&& (resPtr->refNsId == refNsPtr->nsId)
&& (resPtr->refNsCmdEpoch == refNsPtr->cmdRefEpoch))) {
return (Tcl_Command) cmdPtr;
}
}
}
/*
* OK, must create a new internal representation (or fail) as any cache we
* had is invalid one way or another.
*/
/* See [07d13d99b0a9] why we cannot call SetCmdNameFromAny() directly here. */
if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) {
return NULL;
}
resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
return (Tcl_Command) (resPtr ? resPtr->cmdPtr : NULL);
}
/*
*----------------------------------------------------------------------
*
* TclSetCmdNameObj --
|
| ︙ | ︙ | |||
4116 4117 4118 4119 4120 4121 4122 |
Interp *iPtr = (Interp *) interp;
ResolvedCmdName *fillPtr;
const char *name = TclGetString(objPtr);
if (resPtr) {
fillPtr = resPtr;
} else {
| | | 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 |
Interp *iPtr = (Interp *) interp;
ResolvedCmdName *fillPtr;
const char *name = TclGetString(objPtr);
if (resPtr) {
fillPtr = resPtr;
} else {
fillPtr = (ResolvedCmdName *)ckalloc(sizeof(ResolvedCmdName));
fillPtr->refCount = 1;
}
fillPtr->cmdPtr = cmdPtr;
cmdPtr->refCount++;
fillPtr->cmdEpoch = cmdPtr->cmdEpoch;
|
| ︙ | ︙ | |||
4159 4160 4161 4162 4163 4164 4165 |
}
}
void
TclSetCmdNameObj(
Tcl_Interp *interp, /* Points to interpreter containing command
* that should be cached in objPtr. */
| | | | | 4514 4515 4516 4517 4518 4519 4520 4521 4522 4523 4524 4525 4526 4527 4528 4529 4530 4531 4532 4533 4534 4535 4536 |
}
}
void
TclSetCmdNameObj(
Tcl_Interp *interp, /* Points to interpreter containing command
* that should be cached in objPtr. */
Tcl_Obj *objPtr, /* Points to Tcl object to be changed to a
* CmdName object. */
Command *cmdPtr) /* Points to Command structure that the
* CmdName object should refer to. */
{
ResolvedCmdName *resPtr;
if (objPtr->typePtr == &tclCmdNameType) {
resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
if (resPtr != NULL && resPtr->cmdPtr == cmdPtr) {
return;
}
}
SetCmdNameObj(interp, objPtr, cmdPtr, NULL);
}
|
| ︙ | ︙ | |||
4199 4200 4201 4202 4203 4204 4205 | * ResolvedSymbol, which may free the Command structure. * *---------------------------------------------------------------------- */ static void FreeCmdNameInternalRep( | | | | | 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 |
* ResolvedSymbol, which may free the Command structure.
*
*----------------------------------------------------------------------
*/
static void
FreeCmdNameInternalRep(
Tcl_Obj *objPtr) /* CmdName object with internal
* representation to free. */
{
ResolvedCmdName *resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
/*
* Decrement the reference count of the ResolvedCmdName structure. If
* there are no more uses, free the ResolvedCmdName structure.
*/
if (resPtr->refCount-- <= 1) {
/*
* Now free the cached command, unless it is still in its hash
* table or if there are other references to it from other cmdName
* objects.
*/
Command *cmdPtr = resPtr->cmdPtr;
TclCleanupCommandMacro(cmdPtr);
ckfree(resPtr);
}
objPtr->typePtr = NULL;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4247 4248 4249 4250 4251 4252 4253 |
*
*----------------------------------------------------------------------
*/
static void
DupCmdNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
| | | | 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 |
*
*----------------------------------------------------------------------
*/
static void
DupCmdNameInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
ResolvedCmdName *resPtr = (ResolvedCmdName *)srcPtr->internalRep.twoPtrValue.ptr1;
copyPtr->internalRep.twoPtrValue.ptr1 = resPtr;
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
resPtr->refCount++;
copyPtr->typePtr = &tclCmdNameType;
}
|
| ︙ | ︙ | |||
4281 4282 4283 4284 4285 4286 4287 |
*
*----------------------------------------------------------------------
*/
static int
SetCmdNameFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
| | | | | 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 |
*
*----------------------------------------------------------------------
*/
static int
SetCmdNameFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
const char *name;
Command *cmdPtr;
ResolvedCmdName *resPtr;
if (interp == NULL) {
return TCL_ERROR;
}
/*
* Find the Command structure, if any, that describes the command called
|
| ︙ | ︙ | |||
4312 4313 4314 4315 4316 4317 4318 |
* report the failure to find the command as an error.
*/
if (cmdPtr == NULL) {
return TCL_ERROR;
}
| | | 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 |
* report the failure to find the command as an error.
*/
if (cmdPtr == NULL) {
return TCL_ERROR;
}
resPtr = (ResolvedCmdName *)objPtr->internalRep.twoPtrValue.ptr1;
if ((objPtr->typePtr == &tclCmdNameType) && (resPtr->refCount == 1)) {
/*
* Re-use existing ResolvedCmdName struct when possible.
* Cleanup the old fields that need it.
*/
Command *oldCmdPtr = resPtr->cmdPtr;
|
| ︙ | ︙ | |||
4350 4351 4352 4353 4354 4355 4356 | * None. * *---------------------------------------------------------------------- */ int Tcl_RepresentationCmd( | | | | 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 |
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_RepresentationCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *descObj;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "value");
return TCL_ERROR;
}
/*
* Value is a bignum with a refcount of 14, object pointer at 0x12345678,
* internal representation 0x45671234:0x98765432, string representation
* "1872361827361287"
*/
descObj = Tcl_ObjPrintf("value is a %s with a refcount of %d,"
" object pointer at %p",
objv[1]->typePtr ? objv[1]->typePtr->name : "pure string",
objv[1]->refCount, objv[1]);
if (objv[1]->typePtr) {
if (objv[1]->typePtr == &tclDoubleType) {
Tcl_AppendPrintfToObj(descObj, ", internal representation %g",
|
| ︙ | ︙ |
Changes to generic/tclOptimize.c.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 |
#define DefineTargetAddress(tablePtr, address) \
((void) Tcl_CreateHashEntry((tablePtr), (void *) (address), &isNew))
#define IsTargetAddress(tablePtr, address) \
(Tcl_FindHashEntry((tablePtr), (void *) (address)) != NULL)
#define AddrLength(address) \
(tclInstructionTable[*(unsigned char *)(address)].numBytes)
#define InstLength(instruction) \
| | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
#define DefineTargetAddress(tablePtr, address) \
((void) Tcl_CreateHashEntry((tablePtr), (void *) (address), &isNew))
#define IsTargetAddress(tablePtr, address) \
(Tcl_FindHashEntry((tablePtr), (void *) (address)) != NULL)
#define AddrLength(address) \
(tclInstructionTable[*(unsigned char *)(address)].numBytes)
#define InstLength(instruction) \
(tclInstructionTable[UCHAR(instruction)].numBytes)
/*
* ----------------------------------------------------------------------
*
* LocateTargetAddresses --
*
* Populate a hash table with places that we need to be careful around
|
| ︙ | ︙ | |||
227 228 229 230 231 232 233 |
case INST_PUSH1:
if (nextInst == INST_POP) {
blank = size + InstLength(nextInst);
} else if (nextInst == INST_STR_CONCAT1
&& TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) {
Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
TclGetUInt1AtPtr(currentInstPtr + 1));
| | | | 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 |
case INST_PUSH1:
if (nextInst == INST_POP) {
blank = size + InstLength(nextInst);
} else if (nextInst == INST_STR_CONCAT1
&& TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) {
Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
TclGetUInt1AtPtr(currentInstPtr + 1));
int numBytes;
(void) TclGetStringFromObj(litPtr, &numBytes);
if (numBytes == 0) {
blank = size + InstLength(nextInst);
}
}
break;
case INST_PUSH4:
if (nextInst == INST_POP) {
blank = size + 1;
} else if (nextInst == INST_STR_CONCAT1
&& TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) {
Tcl_Obj *litPtr = TclFetchLiteral(envPtr,
TclGetUInt4AtPtr(currentInstPtr + 1));
int numBytes;
(void) TclGetStringFromObj(litPtr, &numBytes);
if (numBytes == 0) {
blank = size + InstLength(nextInst);
}
}
break;
|
| ︙ | ︙ | |||
283 284 285 286 287 288 289 290 291 292 293 294 295 296 | case INST_JUMP_FALSE1: case INST_JUMP_FALSE4: case INST_INCR_SCALAR1: case INST_INCR_ARRAY1: case INST_INCR_ARRAY_STK: case INST_INCR_SCALAR_STK: case INST_INCR_STK: case INST_EQ: case INST_NEQ: case INST_LT: case INST_LE: case INST_GT: case INST_GE: case INST_MOD: | > > | 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 | case INST_JUMP_FALSE1: case INST_JUMP_FALSE4: case INST_INCR_SCALAR1: case INST_INCR_ARRAY1: case INST_INCR_ARRAY_STK: case INST_INCR_SCALAR_STK: case INST_INCR_STK: case INST_LOR: case INST_LAND: case INST_EQ: case INST_NEQ: case INST_LT: case INST_LE: case INST_GT: case INST_GE: case INST_MOD: |
| ︙ | ︙ | |||
423 424 425 426 427 428 429 |
* ----------------------------------------------------------------------
*/
void
TclOptimizeBytecode(
void *envPtr)
{
| | | | | 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 |
* ----------------------------------------------------------------------
*/
void
TclOptimizeBytecode(
void *envPtr)
{
ConvertZeroEffectToNOP((CompileEnv *)envPtr);
AdvanceJumps((CompileEnv *)envPtr);
TrimUnreachable((CompileEnv *)envPtr);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
* End:
*/
|
Changes to generic/tclPanic.c.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #if defined(_WIN32) || defined(__CYGWIN__) | | > > > > | 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 |
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#if defined(_WIN32) || defined(__CYGWIN__)
MODULE_SCOPE TCL_NORETURN void tclWinDebugPanic(const char *format, ...);
#endif
/*
* The panicProc variable contains a pointer to an application specific panic
* procedure.
*/
#if defined(__CYGWIN__) || (defined(_WIN32) && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8))
static TCL_NORETURN1 Tcl_PanicProc *panicProc = tclWinDebugPanic;
#else
static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL;
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_SetPanicProc --
*
* Replace the default panic behavior with the specified function.
|
| ︙ | ︙ | |||
41 42 43 44 45 46 47 48 |
*----------------------------------------------------------------------
*/
void
Tcl_SetPanicProc(
TCL_NORETURN1 Tcl_PanicProc *proc)
{
panicProc = proc;
| > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
*----------------------------------------------------------------------
*/
void
Tcl_SetPanicProc(
TCL_NORETURN1 Tcl_PanicProc *proc)
{
#if defined(_WIN32)
/* tclWinDebugPanic only installs if there is no panicProc yet. */
if (((Tcl_PanicProc *)proc != tclWinDebugPanic) || (panicProc == NULL))
#elif defined(__CYGWIN__)
if (proc == NULL)
panicProc = tclWinDebugPanic;
else
#endif
panicProc = proc;
Tcl_InitSubsystems();
}
/*
*----------------------------------------------------------------------
*
* Tcl_PanicVA --
*
* Print an error message and kill the process.
*
* Results:
* None.
*
* Side effects:
* The process dies, entering the debugger if possible.
*
*----------------------------------------------------------------------
*/
void
Tcl_PanicVA(
const char *format, /* Format string, suitable for passing to
* fprintf. */
va_list argList) /* Variable argument list. */
{
char *arg1, *arg2, *arg3; /* Additional arguments (variable in number)
* to pass to fprintf. */
char *arg4, *arg5, *arg6, *arg7, *arg8;
arg1 = va_arg(argList, char *);
arg2 = va_arg(argList, char *);
arg3 = va_arg(argList, char *);
arg4 = va_arg(argList, char *);
arg5 = va_arg(argList, char *);
arg6 = va_arg(argList, char *);
arg7 = va_arg(argList, char *);
arg8 = va_arg(argList, char *);
if (panicProc != NULL) {
panicProc(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8);
#ifdef _WIN32
} else if (IsDebuggerPresent()) {
tclWinDebugPanic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8);
#endif
} else {
fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6, arg7,
arg8);
fprintf(stderr, "\n");
fflush(stderr);
#if defined(_WIN32) || defined(__CYGWIN__)
# if defined(__GNUC__)
__builtin_trap();
# elif defined(_WIN64)
__debugbreak();
# elif defined(_MSC_VER) && defined (_M_IX86)
_asm {int 3}
# else
DebugBreak();
# endif
#endif
#if defined(_WIN32)
ExitProcess(1);
#else
abort();
#endif
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_Panic --
*
* Print an error message and kill the process.
*
* Results:
* None.
*
* Side effects:
* The process dies, entering the debugger if possible.
*
*----------------------------------------------------------------------
*/
/*
* The following comment is here so that Coverity's static analizer knows that
* a Tcl_Panic() call can never return and avoids lots of false positives.
*/
/* coverity[+kill] */
void
Tcl_Panic(
const char *format,
...)
{
va_list argList;
va_start(argList, format);
Tcl_PanicVA(format, argList);
va_end (argList);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
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 130 131 132 133 134 135 136 137 138 139 |
TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
};
/*
* Prototypes for local functions defined in this file:
*/
static inline int CommandComplete(const char *script, int numBytes);
static int ParseComment(const char *src, int numBytes,
Tcl_Parse *parsePtr);
static int ParseTokens(const char *src, int numBytes, int mask,
int flags, Tcl_Parse *parsePtr);
static int ParseWhiteSpace(const char *src, int numBytes,
int *incompletePtr, char *typePtr);
static int ParseAllWhiteSpace(const char *src, int numBytes,
int *incompletePtr);
static int ParseHex(const char *src, int numBytes,
int *resultPtr);
/*
*----------------------------------------------------------------------
*
* TclParseInit --
*
* Initialize the fields of a Tcl_Parse struct.
|
| ︙ | ︙ | |||
145 146 147 148 149 150 151 |
*----------------------------------------------------------------------
*/
void
TclParseInit(
Tcl_Interp *interp, /* Interpreter to use for error reporting */
const char *start, /* Start of string to be parsed. */
| | | 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 |
*----------------------------------------------------------------------
*/
void
TclParseInit(
Tcl_Interp *interp, /* Interpreter to use for error reporting */
const char *start, /* Start of string to be parsed. */
int numBytes, /* Total number of bytes in string. If < 0,
* the script consists of all bytes up to the
* first null character. */
Tcl_Parse *parsePtr) /* Points to struct to initialize */
{
parsePtr->numWords = 0;
parsePtr->tokenPtr = parsePtr->staticTokens;
parsePtr->numTokens = 0;
|
| ︙ | ︙ | |||
191 192 193 194 195 196 197 |
int
Tcl_ParseCommand(
Tcl_Interp *interp, /* Interpreter to use for error reporting; if
* NULL, then no error message is provided. */
const char *start, /* First character of string containing one or
* more Tcl commands. */
| | | | > > > > < < < < | 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 |
int
Tcl_ParseCommand(
Tcl_Interp *interp, /* Interpreter to use for error reporting; if
* NULL, then no error message is provided. */
const char *start, /* First character of string containing one or
* more Tcl commands. */
int numBytes, /* Total number of bytes in string. If < 0,
* the script consists of all bytes up to the
* first null character. */
int nested, /* Non-zero means this is a nested command:
* close bracket should be considered a
* command terminator. If zero, then close
* bracket has no special meaning. */
Tcl_Parse *parsePtr)
/* Structure to fill in with information about
* the parsed command; any previous
* information in the structure is ignored. */
{
const char *src; /* Points to current character in the
* command. */
char type; /* Result returned by CHAR_TYPE(*src). */
Tcl_Token *tokenPtr; /* Pointer to token being filled in. */
int wordIndex; /* Index of word token for current word. */
int terminators; /* CHAR_TYPE bits that indicate the end of a
* command. */
const char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to
* point to char after terminating one. */
int scanned;
if (numBytes < 0 && start) {
numBytes = strlen(start);
}
TclParseInit(interp, start, numBytes, parsePtr);
if ((start == NULL) && (numBytes != 0)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"can't parse a NULL pointer", -1));
}
return TCL_ERROR;
}
parsePtr->commentStart = NULL;
parsePtr->commentSize = 0;
parsePtr->commandStart = NULL;
parsePtr->commandSize = 0;
if (nested != 0) {
terminators = TYPE_COMMAND_END | TYPE_CLOSE_BRACK;
} else {
|
| ︙ | ︙ | |||
340 341 342 343 344 345 346 | */ expPtr = &parsePtr->tokenPtr[expIdx]; if ((0 == expandWord) /* Haven't seen prefix already */ && (1 == parsePtr->numTokens - expIdx) /* Only one token */ | | | 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 |
*/
expPtr = &parsePtr->tokenPtr[expIdx];
if ((0 == expandWord)
/* Haven't seen prefix already */
&& (1 == parsePtr->numTokens - expIdx)
/* Only one token */
&& (((1 == (size_t) expPtr->size)
/* Same length as prefix */
&& (expPtr->start[0] == '*')))
/* Is the prefix */
&& (numBytes > 0) && (0 == ParseWhiteSpace(termPtr,
numBytes, &parsePtr->incomplete, &type))
&& (type != TYPE_COMMAND_END)
/* Non-whitespace follows */) {
|
| ︙ | ︙ | |||
375 376 377 378 379 380 381 |
* case of a word consisting of a single range of literal text.
*/
tokenPtr = &parsePtr->tokenPtr[wordIndex];
tokenPtr->size = src - tokenPtr->start;
tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1);
if (expandWord) {
| < | | 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 |
* case of a word consisting of a single range of literal text.
*/
tokenPtr = &parsePtr->tokenPtr[wordIndex];
tokenPtr->size = src - tokenPtr->start;
tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1);
if (expandWord) {
int i, isLiteral = 1;
/*
* When a command includes a word that is an expanded literal; for
* example, {*}{1 2 3}, the parser performs that expansion
* immediately, generating several TCL_TOKEN_SIMPLE_WORDs instead
* of a single TCL_TOKEN_EXPAND_WORD that the Tcl_ParseCommand()
* caller might have to expand. This notably makes it simpler for
|
| ︙ | ︙ | |||
422 423 424 425 426 427 428 |
/*
* Step through the literal string, parsing and counting list
* elements.
*/
while (nextElem < listEnd) {
| | | 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 |
/*
* Step through the literal string, parsing and counting list
* elements.
*/
while (nextElem < listEnd) {
int size;
code = TclFindElement(NULL, nextElem, listEnd - nextElem,
&elemStart, &nextElem, &size, &literal);
if ((code != TCL_OK) || !literal) {
break;
}
if (elemStart < listEnd) {
|
| ︙ | ︙ | |||
614 615 616 617 618 619 620 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | | 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 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ParseWhiteSpace(
const char *src, /* First character to parse. */
int numBytes, /* Max number of bytes to scan. */
int *incompletePtr, /* Set this boolean memory to true if parsing
* indicates an incomplete command. */
char *typePtr) /* Points to location to store character type
* of character that ends run of whitespace */
{
char type = TYPE_NORMAL;
const char *p = src;
while (1) {
while (numBytes && ((type = CHAR_TYPE(*p)) & TYPE_SPACE)) {
numBytes--;
p++;
}
if (numBytes && (type & TYPE_SUBS)) {
|
| ︙ | ︙ | |||
668 669 670 671 672 673 674 | * * Results: * Returns the number of bytes recognized as white space. * *---------------------------------------------------------------------- */ | | | | | | | | | | | | | 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 |
*
* Results:
* Returns the number of bytes recognized as white space.
*
*----------------------------------------------------------------------
*/
static int
ParseAllWhiteSpace(
const char *src, /* First character to parse. */
int numBytes, /* Max number of byes to scan */
int *incompletePtr) /* Set true if parse is incomplete. */
{
char type;
const char *p = src;
do {
int scanned = ParseWhiteSpace(p, numBytes, incompletePtr, &type);
p += scanned;
numBytes -= scanned;
} while (numBytes && (*p == '\n') && (p++, --numBytes));
return (p-src);
}
int
TclParseAllWhiteSpace(
const char *src, /* First character to parse. */
int numBytes) /* Max number of byes to scan */
{
int dummy;
return ParseAllWhiteSpace(src, numBytes, &dummy);
}
/*
*----------------------------------------------------------------------
*
* ParseHex --
*
* Scans a hexadecimal number as a Tcl_UniChar value (e.g., for parsing
* \x and \u escape sequences). At most numBytes bytes are scanned.
*
* Results:
* The numeric value is stored in *resultPtr. Returns the number of bytes
* consumed.
*
* Notes:
* Relies on the following properties of the ASCII character set, with
* which UTF-8 is compatible:
*
* The digits '0' .. '9' and the letters 'A' .. 'Z' and 'a' .. 'z' occupy
* consecutive code points, and '0' < 'A' < 'a'.
*
*----------------------------------------------------------------------
*/
int
ParseHex(
const char *src, /* First character to parse. */
int numBytes, /* Max number of byes to scan */
int *resultPtr) /* Points to storage provided by caller where
* the character resulting from the
* conversion is to be written. */
{
int result = 0;
const char *p = src;
while (numBytes--) {
unsigned char digit = UCHAR(*p);
if (!isxdigit(digit) || (result > 0x10FFF)) {
break;
}
p++;
result <<= 4;
if (digit >= 'a') {
|
| ︙ | ︙ | |||
776 777 778 779 780 781 782 |
*----------------------------------------------------------------------
*/
int
TclParseBackslash(
const char *src, /* Points to the backslash character of a a
* backslash sequence. */
| | | | < | | | 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 |
*----------------------------------------------------------------------
*/
int
TclParseBackslash(
const char *src, /* Points to the backslash character of a a
* backslash sequence. */
int numBytes, /* Max number of bytes to scan. */
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;
Tcl_UniChar unichar = 0;
int result;
int count;
char buf[4] = "";
if (numBytes == 0) {
if (readPtr != NULL) {
*readPtr = 0;
}
return 0;
|
| ︙ | ︙ | |||
814 815 816 817 818 819 820 |
count = 1;
goto done;
}
count = 2;
switch (*p) {
/*
| | | | | | | | | > > > > > > > > > > | > > > | 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 |
count = 1;
goto done;
}
count = 2;
switch (*p) {
/*
* Note: in the conversions below, use absolute values (e.g., 0xA)
* rather than symbolic values (e.g. \n) that get converted by the
* compiler. It's possible that compilers on some platforms will do
* the symbolic conversions differently, which could result in
* non-portable Tcl scripts.
*/
case 'a':
result = 0x7;
break;
case 'b':
result = 0x8;
break;
case 'f':
result = 0xC;
break;
case 'n':
result = 0xA;
break;
case 'r':
result = 0xD;
break;
case 't':
result = 0x9;
break;
case 'v':
result = 0xB;
break;
case 'x':
count += ParseHex(p+1, (numBytes > 3) ? 2 : numBytes-2, &result);
if (count == 2) {
/*
* No hexdigits -> This is just "x".
*/
result = 'x';
} else {
/*
* Keep only the last byte (2 hex digits).
*/
result = UCHAR(result);
}
break;
case 'u':
count += ParseHex(p+1, (numBytes > 5) ? 4 : numBytes-2, &result);
if (count == 2) {
/*
* No hexdigits -> This is just "u".
*/
result = 'u';
} else if (((result & 0xFC00) == 0xD800) && (count == 6)
&& (p[5] == '\\') && (p[6] == 'u') && (numBytes >= 10)) {
/* If high surrogate is immediately followed by a low surrogate
* escape, combine them into one character. */
int low;
int count2 = ParseHex(p+7, 4, &low);
if ((count2 == 4) && ((low & 0xFC00) == 0xDC00)) {
result = ((result & 0x3FF)<<10 | (low & 0x3FF)) + 0x10000;
count += count2 + 2;
}
}
break;
case 'U':
count += ParseHex(p+1, (numBytes > 9) ? 8 : numBytes-2, &result);
if (count == 2) {
/*
* No hexdigits -> This is just "U".
*/
result = 'U';
} else if ((result | 0x7FF) == 0xDFFF) {
/* Upper or lower surrogate, not allowed in this syntax. */
result = 0xFFFD;
}
break;
case '\n':
count--;
do {
p++;
count++;
|
| ︙ | ︙ | |||
921 922 923 924 925 926 927 |
* special, we shouldn't break up a correct utf-8 character. [Bug
* #217987] test subst-3.2
*/
if (Tcl_UtfCharComplete(p, numBytes - 1)) {
count = TclUtfToUniChar(p, &unichar) + 1; /* +1 for '\' */
} else {
| | | 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 |
* special, we shouldn't break up a correct utf-8 character. [Bug
* #217987] test subst-3.2
*/
if (Tcl_UtfCharComplete(p, numBytes - 1)) {
count = TclUtfToUniChar(p, &unichar) + 1; /* +1 for '\' */
} else {
char utfBytes[4];
memcpy(utfBytes, p, numBytes - 1);
utfBytes[numBytes - 1] = '\0';
count = TclUtfToUniChar(utfBytes, &unichar) + 1;
}
result = unichar;
break;
|
| ︙ | ︙ | |||
961 962 963 964 965 966 967 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | | 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 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ParseComment(
const char *src, /* First character to parse. */
int numBytes, /* Max number of bytes to scan. */
Tcl_Parse *parsePtr) /* Information about parse in progress.
* Updated if parsing indicates an incomplete
* command. */
{
const char *p = src;
int incomplete = parsePtr->incomplete;
while (numBytes) {
int scanned = ParseAllWhiteSpace(p, numBytes, &incomplete);
p += scanned;
numBytes -= scanned;
if ((numBytes == 0) || (*p != '#')) {
break;
}
if (parsePtr->commentStart == NULL) {
|
| ︙ | ︙ | |||
1036 1037 1038 1039 1040 1041 1042 | * None. * *---------------------------------------------------------------------- */ static int ParseTokens( | | | | 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 |
* None.
*
*----------------------------------------------------------------------
*/
static int
ParseTokens(
const char *src, /* First character to parse. */
int numBytes, /* Max number of bytes to scan. */
int mask, /* Specifies when to stop parsing. The parse
* stops at the first unquoted character whose
* CHAR_TYPE contains any of the bits in
* mask. */
int flags, /* OR-ed bits indicating what substitutions to
* perform: TCL_SUBST_COMMANDS,
* TCL_SUBST_VARIABLES, and
|
| ︙ | ︙ | |||
1128 1129 1130 1131 1132 1133 1134 | * Command substitution. Call Tcl_ParseCommand recursively (and * repeatedly) to parse the nested command(s), then throw away the * parse information. */ src++; numBytes--; | | | 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 |
* Command substitution. Call Tcl_ParseCommand recursively (and
* repeatedly) to parse the nested command(s), then throw away the
* parse information.
*/
src++;
numBytes--;
nestedPtr = (Tcl_Parse *)TclStackAlloc(parsePtr->interp, sizeof(Tcl_Parse));
while (1) {
const char *curEnd;
if (Tcl_ParseCommand(parsePtr->interp, src, numBytes, 1,
nestedPtr) != TCL_OK) {
parsePtr->errorType = nestedPtr->errorType;
parsePtr->term = nestedPtr->term;
|
| ︙ | ︙ | |||
1277 1278 1279 1280 1281 1282 1283 |
void
Tcl_FreeParse(
Tcl_Parse *parsePtr) /* Structure that was filled in by a previous
* call to Tcl_ParseCommand. */
{
if (parsePtr->tokenPtr != parsePtr->staticTokens) {
| | | 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 |
void
Tcl_FreeParse(
Tcl_Parse *parsePtr) /* Structure that was filled in by a previous
* call to Tcl_ParseCommand. */
{
if (parsePtr->tokenPtr != parsePtr->staticTokens) {
ckfree(parsePtr->tokenPtr);
parsePtr->tokenPtr = parsePtr->staticTokens;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1315 1316 1317 1318 1319 1320 1321 |
int
Tcl_ParseVarName(
Tcl_Interp *interp, /* Interpreter to use for error reporting; if
* NULL, then no error message is provided. */
const char *start, /* Start of variable substitution string.
* First character must be "$". */
| | | < < < | < > > > | 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 |
int
Tcl_ParseVarName(
Tcl_Interp *interp, /* Interpreter to use for error reporting; if
* NULL, then no error message is provided. */
const char *start, /* Start of variable substitution string.
* First character must be "$". */
int numBytes, /* Total number of bytes in string. If < 0,
* the string consists of all bytes up to the
* first null character. */
Tcl_Parse *parsePtr, /* Structure to fill in with information about
* the variable name. */
int append) /* Non-zero means append tokens to existing
* information in parsePtr; zero means ignore
* existing tokens in parsePtr and
* reinitialize it. */
{
Tcl_Token *tokenPtr;
const char *src;
int varIndex;
unsigned array;
if (numBytes < 0 && start) {
numBytes = strlen(start);
}
if (!append) {
TclParseInit(interp, start, numBytes, parsePtr);
}
if ((numBytes == 0) || (start == NULL)) {
return TCL_ERROR;
}
/*
* Generate one token for the variable, an additional token for the name,
* plus any number of additional tokens for the index, if there is one.
*/
|
| ︙ | ︙ | |||
1508 1509 1510 1511 1512 1513 1514 |
*
*----------------------------------------------------------------------
*/
const char *
Tcl_ParseVar(
Tcl_Interp *interp, /* Context for looking up variable. */
| | | | | 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 |
*
*----------------------------------------------------------------------
*/
const char *
Tcl_ParseVar(
Tcl_Interp *interp, /* Context for looking up variable. */
const char *start, /* Start of variable substitution. First
* character must be "$". */
const char **termPtr) /* If non-NULL, points to word to fill in with
* character just after last one in the
* variable specifier. */
{
Tcl_Obj *objPtr;
int code;
Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse));
if (Tcl_ParseVarName(interp, start, -1, parsePtr, 0) != TCL_OK) {
TclStackFree(interp, parsePtr);
return NULL;
}
if (termPtr != NULL) {
|
| ︙ | ︙ | |||
1593 1594 1595 1596 1597 1598 1599 |
int
Tcl_ParseBraces(
Tcl_Interp *interp, /* Interpreter to use for error reporting; if
* NULL, then no error message is provided. */
const char *start, /* Start of string enclosed in braces. The
* first character must be {'. */
| | | | | | > > | > > > < < < < < < < | 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 |
int
Tcl_ParseBraces(
Tcl_Interp *interp, /* Interpreter to use for error reporting; if
* NULL, then no error message is provided. */
const char *start, /* Start of string enclosed in braces. The
* first character must be {'. */
int numBytes, /* Total number of bytes in string. If < 0,
* the string consists of all bytes up to the
* first null character. */
Tcl_Parse *parsePtr,
/* Structure to fill in with information about
* the string. */
int append, /* Non-zero means append tokens to existing
* information in parsePtr; zero means ignore
* existing tokens in parsePtr and
* reinitialize it. */
const char **termPtr) /* If non-NULL, points to word in which to
* store a pointer to the character just after
* the terminating '}' if the parse was
* successful. */
{
Tcl_Token *tokenPtr;
const char *src;
int startIndex, level, length;
if (numBytes < 0 && start) {
numBytes = strlen(start);
}
if (!append) {
TclParseInit(interp, start, numBytes, parsePtr);
}
if ((numBytes == 0) || (start == NULL)) {
return TCL_ERROR;
}
src = start;
startIndex = parsePtr->numTokens;
TclGrowParseTokenArray(parsePtr, 1);
tokenPtr = &parsePtr->tokenPtr[startIndex];
tokenPtr->type = TCL_TOKEN_TEXT;
|
| ︙ | ︙ | |||
1736 1737 1738 1739 1740 1741 1742 |
* Guess if the problem is due to comments by searching the source string
* for a possible open brace within the context of a comment. Since we
* aren't performing a full Tcl parse, just look for an open brace
* preceded by a '<whitespace>#' on the same line.
*/
{
| | | | 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 |
* Guess if the problem is due to comments by searching the source string
* for a possible open brace within the context of a comment. Since we
* aren't performing a full Tcl parse, just look for an open brace
* preceded by a '<whitespace>#' on the same line.
*/
{
int openBrace = 0;
while (--src > start) {
switch (*src) {
case '{':
openBrace = 1;
break;
case '\n':
openBrace = 0;
break;
case '#' :
if (openBrace && TclIsSpaceProcM(src[-1])) {
Tcl_AppendToObj(Tcl_GetObjResult(parsePtr->interp),
": possible unbalanced brace in comment", -1);
goto error;
}
break;
}
}
|
| ︙ | ︙ | |||
1796 1797 1798 1799 1800 1801 1802 |
int
Tcl_ParseQuotedString(
Tcl_Interp *interp, /* Interpreter to use for error reporting; if
* NULL, then no error message is provided. */
const char *start, /* Start of the quoted string. The first
* character must be '"'. */
| | | < < < | < > > > | 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 |
int
Tcl_ParseQuotedString(
Tcl_Interp *interp, /* Interpreter to use for error reporting; if
* NULL, then no error message is provided. */
const char *start, /* Start of the quoted string. The first
* character must be '"'. */
int numBytes, /* Total number of bytes in string. If < 0,
* the string consists of all bytes up to the
* first null character. */
Tcl_Parse *parsePtr,
/* Structure to fill in with information about
* the string. */
int append, /* Non-zero means append tokens to existing
* information in parsePtr; zero means ignore
* existing tokens in parsePtr and
* reinitialize it. */
const char **termPtr) /* If non-NULL, points to word in which to
* store a pointer to the character just after
* the quoted string's terminating close-quote
* if the parse succeeds. */
{
if (numBytes < 0 && start) {
numBytes = strlen(start);
}
if (!append) {
TclParseInit(interp, start, numBytes, parsePtr);
}
if ((numBytes == 0) || (start == NULL)) {
return TCL_ERROR;
}
if (TCL_OK != ParseTokens(start+1, numBytes-1, TYPE_QUOTE, TCL_SUBST_ALL,
parsePtr)) {
goto error;
}
if (*parsePtr->term != '"') {
|
| ︙ | ︙ | |||
1878 1879 1880 1881 1882 1883 1884 |
*----------------------------------------------------------------------
*/
void
TclSubstParse(
Tcl_Interp *interp,
const char *bytes,
| | | | 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 |
*----------------------------------------------------------------------
*/
void
TclSubstParse(
Tcl_Interp *interp,
const char *bytes,
int numBytes,
int flags,
Tcl_Parse *parsePtr,
Tcl_InterpState *statePtr)
{
int length = numBytes;
const char *p = bytes;
TclParseInit(interp, p, length, parsePtr);
/*
* First parse the string rep of objPtr, as if it were enclosed as a
* "-quoted word in a normal Tcl command. Honor flags that selectively
|
| ︙ | ︙ | |||
1998 1999 2000 2001 2002 2003 2004 | * within that substitution until we reach the actual parse * error. We'll do additional parsing to determine what length * to claim for the final TCL_TOKEN_COMMAND token. */ Tcl_Token *tokenPtr; const char *lastTerm = parsePtr->term; | | | 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 |
* within that substitution until we reach the actual parse
* error. We'll do additional parsing to determine what length
* to claim for the final TCL_TOKEN_COMMAND token.
*/
Tcl_Token *tokenPtr;
const char *lastTerm = parsePtr->term;
Tcl_Parse *nestedPtr = (Tcl_Parse *)
TclStackAlloc(interp, sizeof(Tcl_Parse));
while (TCL_OK ==
Tcl_ParseCommand(NULL, p, length, 0, nestedPtr)) {
Tcl_FreeParse(nestedPtr);
p = nestedPtr->term + (nestedPtr->term < nestedPtr->end);
length = nestedPtr->end - p;
|
| ︙ | ︙ | |||
2140 2141 2142 2143 2144 2145 2146 |
isLiteral = 0;
break;
}
}
if (isLiteral) {
maxNumCL = NUM_STATIC_POS;
| | | 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 |
isLiteral = 0;
break;
}
}
if (isLiteral) {
maxNumCL = NUM_STATIC_POS;
clPosition = (int *)ckalloc(maxNumCL * sizeof(int));
}
adjust = 0;
result = NULL;
for (; count>0 && code==TCL_OK ; count--, tokenPtr++) {
Tcl_Obj *appendObj = NULL;
const char *append = NULL;
|
| ︙ | ︙ | |||
2180 2181 2182 2183 2184 2185 2186 |
* everything, just the number of lines we have to add as
* correction.
*/
if ((appendByteLength == 1) && (utfCharBytes[0] == ' ')
&& (tokenPtr->start[1] == '\n')) {
if (isLiteral) {
| | | | | 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 |
* everything, just the number of lines we have to add as
* correction.
*/
if ((appendByteLength == 1) && (utfCharBytes[0] == ' ')
&& (tokenPtr->start[1] == '\n')) {
if (isLiteral) {
int clPos;
if (result == 0) {
clPos = 0;
} else {
TclGetStringFromObj(result, &clPos);
}
if (numCL >= maxNumCL) {
maxNumCL *= 2;
clPosition = (int *)ckrealloc(clPosition,
maxNumCL * sizeof(int));
}
clPosition[numCL] = clPos;
numCL++;
}
adjust++;
}
|
| ︙ | ︙ | |||
2348 2349 2350 2351 2352 2353 2354 |
/*
* Release the temp table we used to collect the locations of
* continuation lines, if any.
*/
if (maxNumCL) {
| | | 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 |
/*
* Release the temp table we used to collect the locations of
* continuation lines, if any.
*/
if (maxNumCL) {
ckfree(clPosition);
}
} else {
Tcl_ResetResult(interp);
}
}
if (tokensLeftPtr != NULL) {
*tokensLeftPtr = count;
|
| ︙ | ︙ | |||
2386 2387 2388 2389 2390 2391 2392 |
*
*----------------------------------------------------------------------
*/
static inline int
CommandComplete(
const char *script, /* Script to check. */
| | | 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 |
*
*----------------------------------------------------------------------
*/
static inline int
CommandComplete(
const char *script, /* Script to check. */
int numBytes) /* Number of bytes in script. */
{
Tcl_Parse parse;
const char *p, *end;
int result;
p = script;
end = p + numBytes;
|
| ︙ | ︙ | |||
2460 2461 2462 2463 2464 2465 2466 |
*/
int
TclObjCommandComplete(
Tcl_Obj *objPtr) /* Points to object holding script to
* check. */
{
| | | 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 |
*/
int
TclObjCommandComplete(
Tcl_Obj *objPtr) /* Points to object holding script to
* check. */
{
int length;
const char *script = TclGetStringFromObj(objPtr, &length);
return CommandComplete(script, length);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclPathObj.c.
| ︙ | ︙ | |||
21 22 23 24 25 26 27 | static Tcl_Obj * AppendPath(Tcl_Obj *head, Tcl_Obj *tail); static void DupFsPathInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeFsPathInternalRep(Tcl_Obj *pathPtr); static void UpdateStringOfFsPath(Tcl_Obj *pathPtr); static int SetFsPathFromAny(Tcl_Interp *interp, Tcl_Obj *pathPtr); | | | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | static Tcl_Obj * AppendPath(Tcl_Obj *head, Tcl_Obj *tail); static void DupFsPathInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeFsPathInternalRep(Tcl_Obj *pathPtr); static void UpdateStringOfFsPath(Tcl_Obj *pathPtr); static int SetFsPathFromAny(Tcl_Interp *interp, Tcl_Obj *pathPtr); static int FindSplitPos(const char *path, int separator); static int IsSeparatorOrNull(int ch); static Tcl_Obj * GetExtension(Tcl_Obj *pathPtr); static int MakePathFromNormalized(Tcl_Interp *interp, Tcl_Obj *pathPtr); /* * Define the 'path' object type, which Tcl uses to represent file paths |
| ︙ | ︙ | |||
43 44 45 46 47 48 49 |
UpdateStringOfFsPath, /* updateStringProc */
SetFsPathFromAny /* setFromAnyProc */
};
/*
* struct FsPath --
*
| | < < < < < < < < < < < < < < < < < | | | | < | | > | > > | < | | | 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 |
UpdateStringOfFsPath, /* updateStringProc */
SetFsPathFromAny /* setFromAnyProc */
};
/*
* struct FsPath --
*
* Internal representation of a Tcl_Obj of fsPathType
*/
typedef struct FsPath {
Tcl_Obj *translatedPathPtr; /* If the path has been normalized (flags ==
* 0), this is NULL. Otherwise it is a path
* in which any ~user sequences have been
* translated away. */
Tcl_Obj *normPathPtr; /* If the path has been normalized (flags ==
* 0), this is an absolute path without ., ..
* or ~user components. Otherwise it is a
* path, possibly absolute, to normalize
* relative to cwdPtr. */
Tcl_Obj *cwdPtr; /* If NULL, either translatedPtr exists or
* normPathPtr exists and is absolute. */
int flags; /* Flags to describe interpretation - see
* below. */
ClientData nativePathPtr; /* Native representation of this path, which
* is filesystem dependent. */
int filesystemEpoch; /* Used to ensure the path representation was
* generated during the correct filesystem
* epoch. The epoch changes when
* filesystem-mounts are changed. */
const Tcl_Filesystem *fsPtr;/* The Tcl_Filesystem that claims this path */
} FsPath;
/*
|
| ︙ | ︙ | |||
127 128 129 130 131 132 133 | * * The behaviour of this function if passed a non-absolute path is NOT * defined. * * pathPtr may have a refCount of zero, or may be a shared object. * * Results: | | | > | | < | | 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 |
*
* The behaviour of this function if passed a non-absolute path is NOT
* defined.
*
* pathPtr may have a refCount of zero, or may be a shared object.
*
* Results:
* The result is returned in a Tcl_Obj with a refCount already
* incremented, which gives the caller ownership of it. The caller must
* arrange for Tcl_DecRefCount to be called when the object is no-longer
* needed.
*
* Side effects:
* None (beyond the memory allocation for the result).
*
* Special note:
* Originally based on code from Matt Newman and Jean-Claude Wippler.
* Totally rewritten later by Vince Darley to handle symbolic links.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclFSNormalizeAbsolutePath(
Tcl_Interp *interp, /* Interpreter to use */
|
| ︙ | ︙ | |||
217 218 219 220 221 222 223 |
oldDirSep = dirSep;
}
again:
if (IsSeparatorOrNull(dirSep[2])) {
/*
* Need to skip '.' in the path.
*/
| | | | | | 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 |
oldDirSep = dirSep;
}
again:
if (IsSeparatorOrNull(dirSep[2])) {
/*
* Need to skip '.' in the path.
*/
int curLen;
if (retVal == NULL) {
const char *path = TclGetString(pathPtr);
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
TclGetStringFromObj(retVal, &curLen);
if (curLen == 0) {
Tcl_AppendToObj(retVal, dirSep, 1);
}
dirSep += 2;
oldDirSep = dirSep;
if (dirSep[0] != 0 && dirSep[1] == '.') {
goto again;
}
continue;
}
if (dirSep[2] == '.' && IsSeparatorOrNull(dirSep[3])) {
Tcl_Obj *linkObj;
int curLen;
char *linkStr;
/*
* Have '..' so need to skip previous directory.
*/
if (retVal == NULL) {
const char *path = TclGetString(pathPtr);
retVal = Tcl_NewStringObj(path, dirSep - path);
Tcl_IncrRefCount(retVal);
}
TclGetStringFromObj(retVal, &curLen);
if (curLen == 0) {
Tcl_AppendToObj(retVal, dirSep, 1);
}
if (!first || (tclPlatform == TCL_PLATFORM_UNIX)) {
linkObj = Tcl_FSLink(retVal, NULL, 0);
/* Safety check in case driver caused sharing */
|
| ︙ | ︙ | |||
283 284 285 286 287 288 289 | * to retVal's directory. This means concatenating * the link onto the directory of the path so far. */ const char *path = TclGetStringFromObj(retVal, &curLen); | | | 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 |
* to retVal's directory. This means concatenating
* the link onto the directory of the path so far.
*/
const char *path =
TclGetStringFromObj(retVal, &curLen);
while (--curLen >= 0) {
if (IsSeparatorOrNull(path[curLen])) {
break;
}
}
/*
* We want the trailing slash.
|
| ︙ | ︙ | |||
316 317 318 319 320 321 322 |
linkStr = TclGetStringFromObj(retVal, &curLen);
/*
* Convert to forward-slashes on windows.
*/
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
| | | | 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 |
linkStr = TclGetStringFromObj(retVal, &curLen);
/*
* Convert to forward-slashes on windows.
*/
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
int i;
for (i = 0; i < curLen; i++) {
if (linkStr[i] == '\\') {
linkStr[i] = '/';
}
}
}
}
} else {
linkStr = TclGetStringFromObj(retVal, &curLen);
}
/*
* Either way, we now remove the last path element (but
* not the first character of the path).
*/
while (--curLen >= 0) {
if (IsSeparatorOrNull(linkStr[curLen])) {
if (curLen) {
Tcl_SetObjLength(retVal, curLen);
} else {
Tcl_SetObjLength(retVal, 1);
}
break;
|
| ︙ | ︙ | |||
396 397 398 399 400 401 402 |
}
/*
* Ensure a windows drive like C:/ has a trailing separator.
*/
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
| | | 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 |
}
/*
* Ensure a windows drive like C:/ has a trailing separator.
*/
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
int len;
const char *path = TclGetStringFromObj(retVal, &len);
if (len == 2 && path[0] != 0 && path[1] == ':') {
if (Tcl_IsShared(retVal)) {
TclDecrRefCount(retVal);
retVal = Tcl_DuplicateObj(retVal);
Tcl_IncrRefCount(retVal);
|
| ︙ | ︙ | |||
570 571 572 573 574 575 576 | * Check if the joined-on bit has any directory delimiters in * it. If so, the 'dirname' would be a joining of the main * part with the dirname of the joined-on bit. We could handle * that special case here, but we don't, and instead just use * the standardPath code. */ | | > | | 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 |
* Check if the joined-on bit has any directory delimiters in
* it. If so, the 'dirname' would be a joining of the main
* part with the dirname of the joined-on bit. We could handle
* that special case here, but we don't, and instead just use
* the standardPath code.
*/
int numBytes;
const char *rest =
TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
if (strchr(rest, '/') != NULL) {
goto standardPath;
}
/*
* If the joined-on bit is empty, then [file dirname] is
* documented to return all but the last non-empty element
|
| ︙ | ︙ | |||
607 608 609 610 611 612 613 | /* * Check if the joined-on bit has any directory delimiters in * it. If so, the 'tail' would be only the part following the * last delimiter. We could handle that special case here, but * we don't, and instead just use the standardPath code. */ | | > | | 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 |
/*
* Check if the joined-on bit has any directory delimiters in
* it. If so, the 'tail' would be only the part following the
* last delimiter. We could handle that special case here, but
* we don't, and instead just use the standardPath code.
*/
int numBytes;
const char *rest =
TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes);
if (strchr(rest, '/') != NULL) {
goto standardPath;
}
/*
* If the joined-on bit is empty, then [file tail] is
* documented to return the last non-empty element
|
| ︙ | ︙ | |||
635 636 637 638 639 640 641 |
Tcl_IncrRefCount(fsPathPtr->normPathPtr);
return fsPathPtr->normPathPtr;
}
case TCL_PATH_EXTENSION:
return GetExtension(fsPathPtr->normPathPtr);
case TCL_PATH_ROOT: {
const char *fileName, *extension;
| | | 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 |
Tcl_IncrRefCount(fsPathPtr->normPathPtr);
return fsPathPtr->normPathPtr;
}
case TCL_PATH_EXTENSION:
return GetExtension(fsPathPtr->normPathPtr);
case TCL_PATH_ROOT: {
const char *fileName, *extension;
int length;
fileName = TclGetStringFromObj(fsPathPtr->normPathPtr,
&length);
extension = TclGetExtension(fileName);
if (extension == NULL) {
/*
* There is no extension so the root is the same as the
|
| ︙ | ︙ | |||
658 659 660 661 662 663 664 | * suffix removed. Do that by joining our "head" to * our "tail" with the extension suffix removed from * the tail. */ Tcl_Obj *resultPtr = TclNewFSPathObj(fsPathPtr->cwdPtr, fileName, | | | 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 | * suffix removed. Do that by joining our "head" to * our "tail" with the extension suffix removed from * the tail. */ Tcl_Obj *resultPtr = TclNewFSPathObj(fsPathPtr->cwdPtr, fileName, (int)(length - strlen(extension))); Tcl_IncrRefCount(resultPtr); return resultPtr; } } default: /* We should never get here */ |
| ︙ | ︙ | |||
686 687 688 689 690 691 692 |
Tcl_Obj *splitPtr, *resultPtr;
standardPath:
resultPtr = NULL;
if (portion == TCL_PATH_EXTENSION) {
return GetExtension(pathPtr);
} else if (portion == TCL_PATH_ROOT) {
| | | < | | 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 |
Tcl_Obj *splitPtr, *resultPtr;
standardPath:
resultPtr = NULL;
if (portion == TCL_PATH_EXTENSION) {
return GetExtension(pathPtr);
} else if (portion == TCL_PATH_ROOT) {
int length;
const char *fileName, *extension;
fileName = TclGetStringFromObj(pathPtr, &length);
extension = TclGetExtension(fileName);
if (extension == NULL) {
Tcl_IncrRefCount(pathPtr);
return pathPtr;
} else {
Tcl_Obj *root = Tcl_NewStringObj(fileName,
(int) (length - strlen(extension)));
Tcl_IncrRefCount(root);
return root;
}
}
/*
* Tcl_FSSplitPath in the handling of home directories;
* Tcl_FSSplitPath preserves the "~", but this code computes the
* actual full path name, if we had just a single component.
*/
splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements);
Tcl_IncrRefCount(splitPtr);
if (splitElements == 1 && TclGetString(pathPtr)[0] == '~') {
Tcl_Obj *norm;
|
| ︙ | ︙ | |||
865 866 867 868 869 870 871 | * we are joining a single relative path onto an object that is * already of path type. The 'TclNewFSPathObj' call below creates an * object which can be normalized more efficiently. Currently we only * use the special case when we have exactly two elements, but we * could expand that in the future. * * Bugfix [a47641a0]. TclNewFSPathObj requires first argument | | | | 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 |
* we are joining a single relative path onto an object that is
* already of path type. The 'TclNewFSPathObj' call below creates an
* object which can be normalized more efficiently. Currently we only
* use the special case when we have exactly two elements, but we
* could expand that in the future.
*
* Bugfix [a47641a0]. TclNewFSPathObj requires first argument
* to be an absolute path. Added a check to ensure that elt is absolute.
*/
if ((eltIr)
&& !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))
&& TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) {
Tcl_Obj *tailObj = objv[1];
Tcl_PathType type;
/* if forceRelative - second path is relative */
type = forceRelative ? TCL_PATH_RELATIVE :
TclGetPathType(tailObj, NULL, NULL, NULL);
if (type == TCL_PATH_RELATIVE) {
const char *str;
int len;
str = TclGetStringFromObj(tailObj, &len);
if (len == 0) {
/*
* This happens if we try to handle the root volume '/'.
* There's no need to return a special path object, when
* the base itself is just fine!
|
| ︙ | ︙ | |||
910 911 912 913 914 915 916 | /* * Finally, on Windows, 'file join' is defined to convert * all backslashes to forward slashes, so the base part * cannot have backslashes either. */ if ((tclPlatform != TCL_PLATFORM_WINDOWS) | | | 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 |
/*
* Finally, on Windows, 'file join' is defined to convert
* all backslashes to forward slashes, so the base part
* cannot have backslashes either.
*/
if ((tclPlatform != TCL_PLATFORM_WINDOWS)
|| (strchr(Tcl_GetString(elt), '\\') == NULL)) {
if (PATHFLAGS(elt)) {
return TclNewFSPathObj(elt, str, len);
}
if (TCL_PATH_ABSOLUTE != Tcl_FSGetPathType(elt)) {
return TclNewFSPathObj(elt, str, len);
}
|
| ︙ | ︙ | |||
946 947 948 949 950 951 952 |
}
}
}
assert ( res == NULL );
for (i = 0; i < elements; i++) {
| | < | 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 |
}
}
}
assert ( res == NULL );
for (i = 0; i < elements; i++) {
int driveNameLength, strEltLen, length;
Tcl_PathType type;
char *strElt, *ptr;
Tcl_Obj *driveName = NULL;
Tcl_Obj *elt = objv[i];
strElt = TclGetStringFromObj(elt, &strEltLen);
driveNameLength = 0;
|
| ︙ | ︙ | |||
1095 1096 1097 1098 1099 1100 1101 |
res = Tcl_DuplicateObj(res);
Tcl_IncrRefCount(res);
}
}
if (length > 0 && ptr[length -1] != '/') {
Tcl_AppendToObj(res, &separator, 1);
| | | | 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 |
res = Tcl_DuplicateObj(res);
Tcl_IncrRefCount(res);
}
}
if (length > 0 && ptr[length -1] != '/') {
Tcl_AppendToObj(res, &separator, 1);
TclGetStringFromObj(res, &length);
}
Tcl_SetObjLength(res, length + (int) strlen(strElt));
ptr = TclGetString(res) + length;
for (; *strElt != '\0'; strElt++) {
if (*strElt == separator) {
while (strElt[1] == separator) {
strElt++;
}
|
| ︙ | ︙ | |||
1199 1200 1201 1202 1203 1204 1205 | /* * Helper function for SetFsPathFromAny. Returns position of first directory * delimiter in the path. If no separator is found, then returns the position * of the end of the string. */ | | | 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 |
/*
* Helper function for SetFsPathFromAny. Returns position of first directory
* delimiter in the path. If no separator is found, then returns the position
* of the end of the string.
*/
static int
FindSplitPos(
const char *path,
int separator)
{
int count = 0;
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
|
| ︙ | ︙ | |||
1253 1254 1255 1256 1257 1258 1259 |
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclNewFSPathObj(
Tcl_Obj *dirPtr,
const char *addStrRep,
| | | 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 |
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclNewFSPathObj(
Tcl_Obj *dirPtr,
const char *addStrRep,
int len)
{
FsPath *fsPathPtr;
Tcl_Obj *pathPtr;
const char *p;
int state = 0, count = 0;
/* [Bug 2806250] - this is only a partial solution of the problem.
|
| ︙ | ︙ | |||
1285 1286 1287 1288 1289 1290 1291 |
pathPtr = AppendPath(dirPtr, tail);
Tcl_DecrRefCount(tail);
return pathPtr;
}
pathPtr = Tcl_NewObj();
| | | 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 |
pathPtr = AppendPath(dirPtr, tail);
Tcl_DecrRefCount(tail);
return pathPtr;
}
pathPtr = Tcl_NewObj();
fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
/*
* Set up the path.
*/
fsPathPtr->translatedPathPtr = NULL;
fsPathPtr->normPathPtr = Tcl_NewStringObj(addStrRep, len);
|
| ︙ | ︙ | |||
1310 1311 1312 1313 1314 1315 1316 |
/*
* Look for path components made up of only "."
* This is overly conservative analysis to keep simple. It may mark some
* things as needing more aggressive normalization that don't actually
* need it. No harm done.
*/
| | | | 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 |
/*
* Look for path components made up of only "."
* This is overly conservative analysis to keep simple. It may mark some
* things as needing more aggressive normalization that don't actually
* need it. No harm done.
*/
for (p = addStrRep; len > 0; p++, len--) {
switch (state) {
case 0: /* So far only "." since last dirsep or start */
switch (*p) {
case '.':
count++;
break;
case '/':
case '\\':
case ':':
if (count) {
PATHFLAGS(pathPtr) |= TCLPATH_NEEDNORM;
len = 0;
|
| ︙ | ︙ | |||
1352 1353 1354 1355 1356 1357 1358 1359 1360 |
}
static Tcl_Obj *
AppendPath(
Tcl_Obj *head,
Tcl_Obj *tail)
{
const char *bytes;
Tcl_Obj *copy = Tcl_DuplicateObj(head);
| > < | | | 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 |
}
static Tcl_Obj *
AppendPath(
Tcl_Obj *head,
Tcl_Obj *tail)
{
int numBytes;
const char *bytes;
Tcl_Obj *copy = Tcl_DuplicateObj(head);
/*
* This is likely buggy when dealing with virtual filesystem drivers
* that use some character other than "/" as a path separator. I know
* of no evidence that such a foolish thing exists. This solution was
* chosen so that "JoinPath" operations that pass through either path
* intrep produce the same results; that is, bugward compatibility. If
* we need to fix that bug here, it needs fixing in TclJoinPath() too.
*/
bytes = TclGetStringFromObj(tail, &numBytes);
if (numBytes == 0) {
Tcl_AppendToObj(copy, "/", 1);
} else {
TclpNativeJoinPath(copy, bytes);
}
return copy;
}
|
| ︙ | ︙ | |||
1397 1398 1399 1400 1401 1402 1403 | * The old representation may be freed, and new memory allocated. * *--------------------------------------------------------------------------- */ Tcl_Obj * TclFSMakePathRelative( | | | | 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 |
* The old representation may be freed, and new memory allocated.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclFSMakePathRelative(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *pathPtr, /* The path we have. */
Tcl_Obj *cwdPtr) /* Make it relative to this. */
{
int cwdLen, len;
const char *tempStr;
Tcl_ObjIntRep *irPtr = TclFetchIntRep(pathPtr, &fsPathType);
if (irPtr) {
FsPath *fsPathPtr = PATHOBJ(pathPtr);
if (PATHFLAGS(pathPtr) != 0 && fsPathPtr->cwdPtr == cwdPtr) {
|
| ︙ | ︙ | |||
1468 1469 1470 1471 1472 1473 1474 | * The old representation may be freed, and new memory allocated. * *--------------------------------------------------------------------------- */ static int MakePathFromNormalized( | | | | 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 |
* The old representation may be freed, and new memory allocated.
*
*---------------------------------------------------------------------------
*/
static int
MakePathFromNormalized(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *pathPtr) /* The object to convert. */
{
FsPath *fsPathPtr;
if (TclHasIntRep(pathPtr, &fsPathType)) {
return TCL_OK;
}
fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
/*
* It's a pure normalized absolute path.
*/
fsPathPtr->translatedPathPtr = NULL;
|
| ︙ | ︙ | |||
1503 1504 1505 1506 1507 1508 1509 | } /* *--------------------------------------------------------------------------- * * Tcl_FSNewNativePath -- * | | | | 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 | } /* *--------------------------------------------------------------------------- * * Tcl_FSNewNativePath -- * * Performs the something like the reverse of the usual * obj->path->nativerep conversions. If some code retrieves a path in * native form (from, e.g. readlink or a native dialog), and that path is * to be used at the Tcl level, then calling this function is an * efficient way of creating the appropriate path object type. * * Any memory which is allocated for 'clientData' should be retained * until clientData is passed to the filesystem's freeInternalRepProc * when it can be freed. The built in platform-specific filesystems use * 'ckalloc' to allocate clientData, and ckfree to free it. * * Results: * NULL or a valid path object pointer, with refCount zero. * * Side effects: * New memory may be allocated. * |
| ︙ | ︙ | |||
1545 1546 1547 1548 1549 1550 1551 |
/*
* Free old representation; shouldn't normally be any, but best to be
* safe.
*/
Tcl_StoreIntRep(pathPtr, &fsPathType, NULL);
| | | | | | | > > | > > > > > | 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 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 |
/*
* Free old representation; shouldn't normally be any, but best to be
* safe.
*/
Tcl_StoreIntRep(pathPtr, &fsPathType, NULL);
fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
fsPathPtr->translatedPathPtr = NULL;
Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr));
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = clientData;
fsPathPtr->fsPtr = fromFilesystem;
fsPathPtr->filesystemEpoch = TclFSEpoch();
SETPATHOBJ(pathPtr, fsPathPtr);
PATHFLAGS(pathPtr) = 0;
return pathPtr;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetTranslatedPath --
*
* Attempts to extract the translated path from the given
* Tcl_Obj. If the translation succeeds (i.e. the object is a valid
* path), then it is returned. Otherwise NULL is returned and an
* error message may be left in the interpreter if it is not NULL.
*
* Results:
* A Tcl_Obj pointer or NULL.
*
* Side effects:
* pathPtr is converted to fsPathType if necessary.
*
* FsPath members are modified as needed.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_FSGetTranslatedPath(
Tcl_Interp *interp,
Tcl_Obj *pathPtr)
{
Tcl_Obj *retObj = NULL;
FsPath *srcFsPathPtr;
if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
return NULL;
}
srcFsPathPtr = PATHOBJ(pathPtr);
if (srcFsPathPtr->translatedPathPtr == NULL) {
if (PATHFLAGS(pathPtr) == 0) {
/*
* Path is already normalized
*/
retObj = srcFsPathPtr->normPathPtr;
} else {
/*
* We lack a translated path result, but we have a directory
* (cwdPtr) and a tail (normPathPtr), and if we join the
* translated version of cwdPtr to normPathPtr, we'll get the
* translated result we need, and can store it for future use.
*/
|
| ︙ | ︙ | |||
1620 1621 1622 1623 1624 1625 1626 |
if (translatedCwdIrPtr) {
srcFsPathPtr->filesystemEpoch
= PATHOBJ(translatedCwdPtr)->filesystemEpoch;
} else {
srcFsPathPtr->filesystemEpoch = 0;
}
Tcl_DecrRefCount(translatedCwdPtr);
| < < < < < < < < | 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 |
if (translatedCwdIrPtr) {
srcFsPathPtr->filesystemEpoch
= PATHOBJ(translatedCwdPtr)->filesystemEpoch;
} else {
srcFsPathPtr->filesystemEpoch = 0;
}
Tcl_DecrRefCount(translatedCwdPtr);
}
} else {
/*
* It is an ordinary path object.
*/
retObj = srcFsPathPtr->translatedPathPtr;
|
| ︙ | ︙ | |||
1670 1671 1672 1673 1674 1675 1676 |
Tcl_FSGetTranslatedStringPath(
Tcl_Interp *interp,
Tcl_Obj *pathPtr)
{
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (transPtr != NULL) {
| | | | 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 |
Tcl_FSGetTranslatedStringPath(
Tcl_Interp *interp,
Tcl_Obj *pathPtr)
{
Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
if (transPtr != NULL) {
int len;
const char *orig = TclGetStringFromObj(transPtr, &len);
char *result = (char *)ckalloc(len+1);
memcpy(result, orig, len+1);
TclDecrRefCount(transPtr);
return result;
}
return NULL;
|
| ︙ | ︙ | |||
1720 1721 1722 1723 1724 1725 1726 |
if (PATHFLAGS(pathPtr) != 0) {
/*
* This is a special path object which is the result of something like
* 'file join'
*/
Tcl_Obj *dir, *copy;
| | < | | 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 |
if (PATHFLAGS(pathPtr) != 0) {
/*
* This is a special path object which is the result of something like
* 'file join'
*/
Tcl_Obj *dir, *copy;
int tailLen, cwdLen, pathType;
pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr);
dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr);
if (dir == NULL) {
return NULL;
}
/* TODO: Figure out why this is needed. */
TclGetString(pathPtr);
TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen);
if (tailLen) {
copy = AppendPath(dir, fsPathPtr->normPathPtr);
} else {
copy = Tcl_DuplicateObj(dir);
}
Tcl_IncrRefCount(dir);
Tcl_IncrRefCount(copy);
|
| ︙ | ︙ | |||
1796 1797 1798 1799 1800 1801 1802 | fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr; Tcl_IncrRefCount(fsPathPtr->cwdPtr); TclDecrRefCount(fsPathPtr->normPathPtr); fsPathPtr->normPathPtr = copy; | < < < < < < < < < | | | | 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 |
fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr;
Tcl_IncrRefCount(fsPathPtr->cwdPtr);
TclDecrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->normPathPtr = copy;
TclDecrRefCount(dir);
TclDecrRefCount(origDir);
} else {
TclDecrRefCount(fsPathPtr->cwdPtr);
fsPathPtr->cwdPtr = NULL;
TclDecrRefCount(fsPathPtr->normPathPtr);
fsPathPtr->normPathPtr = copy;
TclDecrRefCount(dir);
}
PATHFLAGS(pathPtr) = 0;
}
/*
* Ensure cwd hasn't changed.
*/
if (fsPathPtr->cwdPtr != NULL) {
if (!TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) {
TclGetString(pathPtr);
Tcl_StoreIntRep(pathPtr, &fsPathType, NULL);
if (SetFsPathFromAny(interp, pathPtr) != TCL_OK) {
return NULL;
}
fsPathPtr = PATHOBJ(pathPtr);
} else if (fsPathPtr->normPathPtr == NULL) {
int cwdLen;
Tcl_Obj *copy;
copy = AppendPath(fsPathPtr->cwdPtr, pathPtr);
(void) TclGetStringFromObj(fsPathPtr->cwdPtr, &cwdLen);
cwdLen += (Tcl_GetString(copy)[cwdLen] == '/');
/*
* Normalize the combined string, but only starting after the end
* of the previously normalized 'dir'. This should be much faster!
*/
TclFSNormalizeToUniquePath(interp, copy, cwdLen-1);
fsPathPtr->normPathPtr = copy;
Tcl_IncrRefCount(fsPathPtr->normPathPtr);
}
}
if (fsPathPtr->normPathPtr == NULL) {
Tcl_Obj *useThisCwd = NULL;
/*
* Since normPathPtr is NULL but this is a valid path object, we know
* that the translatedPathPtr cannot be NULL.
*/
Tcl_Obj *absolutePath = fsPathPtr->translatedPathPtr;
const char *path = TclGetString(absolutePath);
Tcl_IncrRefCount(absolutePath);
|
| ︙ | ︙ | |||
1953 1954 1955 1956 1957 1958 1959 | } /* *--------------------------------------------------------------------------- * * Tcl_FSGetInternalRep -- * | | < | < | > | > < > > > < > > > < < | < > | | | | < < < < < < < < < > > | | | | | | < < < < | | | | > < | < > | | > > | | < < | < < | > | | | < < | 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 |
}
/*
*---------------------------------------------------------------------------
*
* Tcl_FSGetInternalRep --
*
* Produces a native representation of a given path object in the given
* filesystem.
*
* In the future it might be desirable to have separate versions
* of this function with different signatures, for example
* Tcl_FSGetNativeWinPath, Tcl_FSGetNativeUnixPath etc. Right now, since
* native paths are all string based, we use just one function.
*
* Results:
*
* The native handle for the path, or NULL if the path is not handled by
* the given filesystem
*
* Side effects:
*
* Tcl_FSCreateInternalRepProc if needed to produce the native
* handle, which is then stored in the internal representation of pathPtr.
*
*---------------------------------------------------------------------------
*/
ClientData
Tcl_FSGetInternalRep(
Tcl_Obj *pathPtr,
const Tcl_Filesystem *fsPtr)
{
FsPath *srcFsPathPtr;
if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) {
return NULL;
}
srcFsPathPtr = PATHOBJ(pathPtr);
/*
* Currently there must be a unique bi-directional mapping between a path
* and a filesystem, and therefore there is no way to "remap" a file, i.e.,
* to map a file in one filesystem into another. Another way of putting
* this is that 'stacked' filesystems are not allowed. It could be useful
* in the future to redesign the system to allow that.
*
* Even something simple like a 'pass through' filesystem which logs all
* activity and passes the calls onto the native system would be nice, but
* not currently easily achievable.
*/
if (srcFsPathPtr->fsPtr == NULL) {
Tcl_FSGetFileSystemForPath(pathPtr);
srcFsPathPtr = PATHOBJ(pathPtr);
if (srcFsPathPtr->fsPtr == NULL) {
/*
* The path is probably not a valid path in the filesystsem, and is
* most likely to be a use of the empty path "" via a direct call
* to one of the objectified interfaces (e.g. from the Tcl
* testsuite).
*/
return NULL;
}
}
/*
* If the file belongs to a different filesystem, perhaps it is actually
* linked through to a file in the given filesystem. Check this by
* inspecting the filesystem associated with the given path.
*/
if (fsPtr != srcFsPathPtr->fsPtr) {
const Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathPtr);
if (actualFs == fsPtr) {
return Tcl_FSGetInternalRep(pathPtr, fsPtr);
}
return NULL;
}
if (srcFsPathPtr->nativePathPtr == NULL) {
Tcl_FSCreateInternalRepProc *proc;
char *nativePathPtr;
proc = srcFsPathPtr->fsPtr->createInternalRepProc;
if (proc == NULL) {
return NULL;
}
nativePathPtr = (char *)proc(pathPtr);
srcFsPathPtr = PATHOBJ(pathPtr);
srcFsPathPtr->nativePathPtr = nativePathPtr;
srcFsPathPtr->filesystemEpoch = TclFSEpoch();
}
return srcFsPathPtr->nativePathPtr;
}
/*
*---------------------------------------------------------------------------
*
* TclFSEnsureEpochOk --
*
* Ensure that the path is a valid path, and that it has a
* fsPathType internal representation that is not stale.
*
* Results:
* A standard Tcl return code.
*
* Side effects:
* The internal representation of fsPtrPtr is converted to fsPathType if
* possible.
*
*---------------------------------------------------------------------------
*/
int
TclFSEnsureEpochOk(
Tcl_Obj *pathPtr,
const Tcl_Filesystem **fsPtrPtr)
{
FsPath *srcFsPathPtr;
if (!TclHasIntRep(pathPtr, &fsPathType)) {
return TCL_OK;
}
srcFsPathPtr = PATHOBJ(pathPtr);
if (!TclFSEpochOk(srcFsPathPtr->filesystemEpoch)) {
/*
* The filesystem has changed in some way since the internal
* representation for this object was calculated. Discard the stale
* representation and recalculate it.
*/
TclGetString(pathPtr);
Tcl_StoreIntRep(pathPtr, &fsPathType, NULL);
if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
return TCL_ERROR;
}
srcFsPathPtr = PATHOBJ(pathPtr);
}
if (srcFsPathPtr->fsPtr != NULL) {
/*
* There is already a filesystem assigned to this path.
*/
*fsPtrPtr = srcFsPathPtr->fsPtr;
}
return TCL_OK;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
2176 2177 2178 2179 2180 2181 2182 |
int
Tcl_FSEqualPaths(
Tcl_Obj *firstPtr,
Tcl_Obj *secondPtr)
{
const char *firstStr, *secondStr;
| | < | 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 |
int
Tcl_FSEqualPaths(
Tcl_Obj *firstPtr,
Tcl_Obj *secondPtr)
{
const char *firstStr, *secondStr;
int firstLen, secondLen, tempErrno;
if (firstPtr == secondPtr) {
return 1;
}
if (firstPtr == NULL || secondPtr == NULL) {
return 0;
|
| ︙ | ︙ | |||
2216 2217 2218 2219 2220 2221 2222 | } /* *--------------------------------------------------------------------------- * * SetFsPathFromAny -- * | | | > | | | | | 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 |
}
/*
*---------------------------------------------------------------------------
*
* SetFsPathFromAny --
*
* Attempt to convert the internal representation of pathPtr to
* fsPathType.
*
* A tilde ("~") character at the beginnig of the filename indicates the
* current user's home directory, and "~<user>" indicates a particular
* user's directory.
*
* Results:
* Standard Tcl error code.
*
* Side effects:
* The old representation may be freed, and new memory allocated.
*
*---------------------------------------------------------------------------
*/
static int
SetFsPathFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *pathPtr) /* The object to convert. */
{
int len;
FsPath *fsPathPtr;
Tcl_Obj *transPtr;
const char *name;
if (TclHasIntRep(pathPtr, &fsPathType)) {
return TCL_OK;
}
/*
* First step is to translate the filename. This is similar to
|
| ︙ | ︙ | |||
2267 2268 2269 2270 2271 2272 2273 |
/*
* Handle tilde substitutions, if needed.
*/
if (len && name[0] == '~') {
Tcl_DString temp;
| | | 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 |
/*
* Handle tilde substitutions, if needed.
*/
if (len && name[0] == '~') {
Tcl_DString temp;
int split;
char separator = '/';
/*
* We have multiple cases '~/foo/bar...', '~user/foo/bar...', etc.
* split becomes value 1 for '~/...' as well as for '~'.
*/
split = FindSplitPos(name, separator);
|
| ︙ | ︙ | |||
2304 2305 2306 2307 2308 2309 2310 |
return TCL_ERROR;
}
Tcl_DStringInit(&temp);
Tcl_JoinPath(1, &dir, &temp);
Tcl_DStringFree(&dirString);
} else {
/*
| | | 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 |
return TCL_ERROR;
}
Tcl_DStringInit(&temp);
Tcl_JoinPath(1, &dir, &temp);
Tcl_DStringFree(&dirString);
} else {
/*
* There is a '~user'
*/
const char *expandedUser;
Tcl_DString userName;
Tcl_DStringInit(&userName);
Tcl_DStringAppend(&userName, name+1, split-1);
|
| ︙ | ︙ | |||
2355 2356 2357 2358 2359 2360 2361 |
/*
* Skip '~'. It's replaced by its expansion.
*/
objc--; objv++;
while (objc--) {
| | < | 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 |
/*
* Skip '~'. It's replaced by its expansion.
*/
objc--; objv++;
while (objc--) {
TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++));
}
TclDecrRefCount(parts);
} else {
Tcl_Obj *pair[2];
pair[0] = transPtr;
pair[1] = Tcl_NewStringObj(name+split+1, -1);
|
| ︙ | ︙ | |||
2382 2383 2384 2385 2386 2387 2388 |
}
/*
* Now we have a translated filename in 'transPtr'. This will have forward
* slashes on Windows, and will not contain any ~user sequences.
*/
| | | 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 |
}
/*
* Now we have a translated filename in 'transPtr'. This will have forward
* slashes on Windows, and will not contain any ~user sequences.
*/
fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
if (transPtr == pathPtr) {
transPtr = Tcl_DuplicateObj(pathPtr);
fsPathPtr->filesystemEpoch = 0;
} else {
fsPathPtr->filesystemEpoch = TclFSEpoch();
}
|
| ︙ | ︙ | |||
2433 2434 2435 2436 2437 2438 2439 |
if (freeProc != NULL) {
freeProc(fsPathPtr->nativePathPtr);
fsPathPtr->nativePathPtr = NULL;
}
}
| | | | 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 |
if (freeProc != NULL) {
freeProc(fsPathPtr->nativePathPtr);
fsPathPtr->nativePathPtr = NULL;
}
}
ckfree(fsPathPtr);
}
static void
DupFsPathInternalRep(
Tcl_Obj *srcPtr, /* Path obj with internal rep to copy. */
Tcl_Obj *copyPtr) /* Path obj with internal rep to set. */
{
FsPath *srcFsPathPtr = PATHOBJ(srcPtr);
FsPath *copyFsPathPtr = (FsPath *)ckalloc(sizeof(FsPath));
SETPATHOBJ(copyPtr, copyFsPathPtr);
copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr;
if (copyFsPathPtr->translatedPathPtr != NULL) {
Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr);
}
|
| ︙ | ︙ | |||
2499 2500 2501 2502 2503 2504 2505 | * Memory may be allocated. * *--------------------------------------------------------------------------- */ static void UpdateStringOfFsPath( | | | | 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 |
* Memory may be allocated.
*
*---------------------------------------------------------------------------
*/
static void
UpdateStringOfFsPath(
Tcl_Obj *pathPtr) /* path obj with string rep to update. */
{
FsPath *fsPathPtr = PATHOBJ(pathPtr);
int cwdLen;
Tcl_Obj *copy;
if (PATHFLAGS(pathPtr) == 0 || fsPathPtr->cwdPtr == NULL) {
Tcl_Panic("Called UpdateStringOfFsPath with invalid object");
}
copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr);
|
| ︙ | ︙ | |||
2546 2547 2548 2549 2550 2551 2552 |
*
*---------------------------------------------------------------------------
*/
int
TclNativePathInFilesystem(
Tcl_Obj *pathPtr,
| | | 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 |
*
*---------------------------------------------------------------------------
*/
int
TclNativePathInFilesystem(
Tcl_Obj *pathPtr,
TCL_UNUSED(ClientData *))
{
/*
* A special case is required to handle the empty path "". This is a valid
* path (i.e. the user should be able to do 'file exists ""' without
* throwing an error), but equally the path doesn't exist. Those are the
* semantics of Tcl (at present anyway), so we have to abide by them here.
*/
|
| ︙ | ︙ | |||
2574 2575 2576 2577 2578 2579 2580 |
} else {
/*
* It is somewhat unusual to reach this code path without the object
* being of fsPathType. However, we do our best to deal with the
* situation.
*/
| | | 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 |
} else {
/*
* It is somewhat unusual to reach this code path without the object
* being of fsPathType. However, we do our best to deal with the
* situation.
*/
int len;
(void) TclGetStringFromObj(pathPtr, &len);
if (len == 0) {
/*
* We reject the empty path "".
*/
|
| ︙ | ︙ |
Changes to generic/tclPipe.c.
| ︙ | ︙ | |||
179 180 181 182 183 184 185 |
void
Tcl_DetachPids(
int numPids, /* Number of pids to detach: gives size of
* array pointed to by pidPtr. */
Tcl_Pid *pidPtr) /* Array of pids to detach. */
{
| | | | 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 |
void
Tcl_DetachPids(
int numPids, /* Number of pids to detach: gives size of
* array pointed to by pidPtr. */
Tcl_Pid *pidPtr) /* Array of pids to detach. */
{
Detached *detPtr;
int i;
Tcl_MutexLock(&pipeMutex);
for (i = 0; i < numPids; i++) {
detPtr = (Detached *)ckalloc(sizeof(Detached));
detPtr->pid = pidPtr[i];
detPtr->nextPtr = detList;
detList = detPtr;
}
Tcl_MutexUnlock(&pipeMutex);
}
|
| ︙ | ︙ | |||
215 216 217 218 219 220 221 |
*
*----------------------------------------------------------------------
*/
void
Tcl_ReapDetachedProcs(void)
{
| | | | 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 |
*
*----------------------------------------------------------------------
*/
void
Tcl_ReapDetachedProcs(void)
{
Detached *detPtr;
Detached *nextPtr, *prevPtr;
int status, code;
Tcl_MutexLock(&pipeMutex);
for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) {
status = TclProcessWait(detPtr->pid, WNOHANG, &code, NULL, NULL);
if (status == TCL_PROCESS_UNCHANGED || (status == TCL_PROCESS_ERROR
&& code != ECHILD)) {
prevPtr = detPtr;
detPtr = detPtr->nextPtr;
continue;
}
nextPtr = detPtr->nextPtr;
if (prevPtr == NULL) {
detList = detPtr->nextPtr;
} else {
prevPtr->nextPtr = detPtr->nextPtr;
}
ckfree(detPtr);
detPtr = nextPtr;
}
Tcl_MutexUnlock(&pipeMutex);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
332 333 334 335 336 337 338 |
if (interp != NULL) {
int count;
Tcl_Obj *objPtr;
Tcl_Seek(errorChan, 0, SEEK_SET);
objPtr = Tcl_NewObj();
count = Tcl_ReadChars(errorChan, objPtr, -1, 0);
| | | 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 |
if (interp != NULL) {
int count;
Tcl_Obj *objPtr;
Tcl_Seek(errorChan, 0, SEEK_SET);
objPtr = Tcl_NewObj();
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",
Tcl_PosixError(interp)));
} else if (count > 0) {
|
| ︙ | ︙ | |||
409 410 411 412 413 414 415 |
TclFile *inPipePtr, /* If non-NULL, input to the pipeline comes
* from a pipe (unless overridden by
* redirection in the command). The file id
* with which to write to this pipe is stored
* at *inPipePtr. NULL means command specified
* its own input source. */
TclFile *outPipePtr, /* If non-NULL, output to the pipeline goes to
| | | 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 |
TclFile *inPipePtr, /* If non-NULL, input to the pipeline comes
* from a pipe (unless overridden by
* redirection in the command). The file id
* with which to write to this pipe is stored
* at *inPipePtr. NULL means command specified
* its own input source. */
TclFile *outPipePtr, /* If non-NULL, output to the pipeline goes to
* a pipe, unless overridden by redirection in
* the command. The file id with which to read
* frome this pipe is stored at *outPipePtr.
* NULL means command specified its own output
* sink. */
TclFile *errFilePtr) /* If non-NULL, all stderr output from the
* pipeline will go to a temporary file
* created here, and a descriptor to read the
|
| ︙ | ︙ | |||
820 821 822 823 824 825 826 |
/*
* Scan through the argc array, creating a process for each group of
* arguments between the "|" characters.
*/
Tcl_ReapDetachedProcs();
| | | 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 |
/*
* Scan through the argc array, creating a process for each group of
* arguments between the "|" characters.
*/
Tcl_ReapDetachedProcs();
pidPtr = (Tcl_Pid *)ckalloc(cmdCount * sizeof(Tcl_Pid));
curInFile = inputFile;
for (i = 0; i < argc; i = lastArg + 1) {
int result, joinThisError;
Tcl_Pid pid;
const char *oldName;
|
| ︙ | ︙ | |||
974 975 976 977 978 979 980 |
}
if (pidPtr != NULL) {
for (i = 0; i < numPids; i++) {
if (pidPtr[i] != (Tcl_Pid) -1) {
Tcl_DetachPids(1, &pidPtr[i]);
}
}
| | | 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 |
}
if (pidPtr != NULL) {
for (i = 0; i < numPids; i++) {
if (pidPtr[i] != (Tcl_Pid) -1) {
Tcl_DetachPids(1, &pidPtr[i]);
}
}
ckfree(pidPtr);
}
numPids = -1;
goto cleanup;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1078 1079 1080 1081 1082 1083 1084 |
goto error;
}
return channel;
error:
if (numPids > 0) {
Tcl_DetachPids(numPids, pidPtr);
| | | 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 |
goto error;
}
return channel;
error:
if (numPids > 0) {
Tcl_DetachPids(numPids, pidPtr);
ckfree(pidPtr);
}
if (inPipe != NULL) {
TclpCloseFile(inPipe);
}
if (outPipe != NULL) {
TclpCloseFile(outPipe);
}
|
| ︙ | ︙ |
Changes to generic/tclPkg.c.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 | /* * For each package that is known in any way to an interpreter, there is one * record of the following type. These records are stored in the * "packageTable" hash table in the interpreter, keyed by package name such as * "Tk" (no version number). */ | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
/*
* For each package that is known in any way to an interpreter, there is one
* record of the following type. These records are stored in the
* "packageTable" hash table in the interpreter, keyed by package name such as
* "Tk" (no version number).
*/
typedef struct Package {
Tcl_Obj *version;
PkgAvail *availPtr; /* First in list of all available versions of
* this package. */
const void *clientData; /* Client data. */
} Package;
typedef struct Require {
|
| ︙ | ︙ | |||
107 108 109 110 111 112 113 | static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result); /* * Helper macros. */ #define DupBlock(v,s,len) \ | | | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 |
static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result);
/*
* Helper macros.
*/
#define DupBlock(v,s,len) \
((v) = (char *)ckalloc(len), memcpy((v),(s),(len)))
#define DupString(v,s) \
do { \
size_t local__len = strlen(s) + 1; \
DupBlock((v),(s),local__len); \
} while (0)
/*
|
| ︙ | ︙ | |||
171 172 173 174 175 176 177 |
return TCL_OK;
}
if (CheckVersionAndConvert(interp, Tcl_GetString(pkgPtr->version), &pvi,
NULL) != TCL_OK) {
return TCL_ERROR;
} else if (CheckVersionAndConvert(interp, version, &vi, NULL) != TCL_OK) {
| | | | | 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 |
return TCL_OK;
}
if (CheckVersionAndConvert(interp, Tcl_GetString(pkgPtr->version), &pvi,
NULL) != TCL_OK) {
return TCL_ERROR;
} else if (CheckVersionAndConvert(interp, version, &vi, NULL) != TCL_OK) {
ckfree(pvi);
return TCL_ERROR;
}
res = CompareVersions(pvi, vi, NULL);
ckfree(pvi);
ckfree(vi);
if (res == 0) {
if (clientData != NULL) {
pkgPtr->clientData = clientData;
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
222 223 224 225 226 227 228 |
*
*----------------------------------------------------------------------
*/
static void
PkgFilesCleanupProc(
ClientData clientData,
| | | | | | | | | | | 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 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 |
*
*----------------------------------------------------------------------
*/
static void
PkgFilesCleanupProc(
ClientData clientData,
TCL_UNUSED(Tcl_Interp *))
{
PkgFiles *pkgFiles = (PkgFiles *) clientData;
Tcl_HashSearch search;
Tcl_HashEntry *entry;
while (pkgFiles->names) {
PkgName *name = pkgFiles->names;
pkgFiles->names = name->nextPtr;
ckfree(name);
}
entry = Tcl_FirstHashEntry(&pkgFiles->table, &search);
while (entry) {
Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(entry);
Tcl_DecrRefCount(obj);
entry = Tcl_NextHashEntry(&search);
}
Tcl_DeleteHashTable(&pkgFiles->table);
ckfree(pkgFiles);
return;
}
void *
TclInitPkgFiles(
Tcl_Interp *interp)
{
/*
* If assocdata "tclPkgFiles" doesn't exist yet, create it.
*/
PkgFiles *pkgFiles = (PkgFiles *)Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
if (!pkgFiles) {
pkgFiles = (PkgFiles *)ckalloc(sizeof(PkgFiles));
pkgFiles->names = NULL;
Tcl_InitHashTable(&pkgFiles->table, TCL_STRING_KEYS);
Tcl_SetAssocData(interp, "tclPkgFiles", PkgFilesCleanupProc, pkgFiles);
}
return pkgFiles;
}
void
TclPkgFileSeen(
Tcl_Interp *interp,
const char *fileName)
{
PkgFiles *pkgFiles = (PkgFiles *)
Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
if (pkgFiles && pkgFiles->names) {
const char *name = pkgFiles->names->name;
Tcl_HashTable *table = &pkgFiles->table;
int isNew;
Tcl_HashEntry *entry = (Tcl_HashEntry *)Tcl_CreateHashEntry(table, name, &isNew);
Tcl_Obj *list;
if (isNew) {
list = Tcl_NewObj();
Tcl_SetHashValue(entry, list);
Tcl_IncrRefCount(list);
} else {
list = (Tcl_Obj *)Tcl_GetHashValue(entry);
}
Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(fileName, -1));
}
}
#undef Tcl_PkgRequire
const char *
|
| ︙ | ︙ | |||
443 444 445 446 447 448 449 |
static int
TclNRPkgRequireProc(
ClientData clientData,
Tcl_Interp *interp,
int reqc,
Tcl_Obj *const reqv[])
{
| | | | | | | | | | | | | 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 |
static int
TclNRPkgRequireProc(
ClientData clientData,
Tcl_Interp *interp,
int reqc,
Tcl_Obj *const reqv[])
{
RequireProcArgs *args = (RequireProcArgs *)clientData;
Tcl_NRAddCallback(interp,
PkgRequireCore, (void *) args->name, INT2PTR(reqc), (void *) reqv,
args->clientDataPtr);
return TCL_OK;
}
static int
PkgRequireCore(
ClientData data[],
Tcl_Interp *interp,
TCL_UNUSED(int))
{
const char *name = (const char *)data[0];
int reqc = PTR2INT(data[1]);
Tcl_Obj **reqv = (Tcl_Obj **)data[2];
int code = CheckAllRequirements(interp, reqc, reqv);
Require *reqPtr;
if (code != TCL_OK) {
return code;
}
reqPtr = (Require *)ckalloc(sizeof(Require));
Tcl_NRAddCallback(interp, PkgRequireCoreCleanup, reqPtr, NULL, NULL, NULL);
reqPtr->clientDataPtr = data[3];
reqPtr->name = name;
reqPtr->pkgPtr = FindPackage(interp, name);
if (reqPtr->pkgPtr->version == NULL) {
Tcl_NRAddCallback(interp,
SelectPackage, reqPtr, INT2PTR(reqc), reqv,
(void *)PkgRequireCoreStep1);
} else {
Tcl_NRAddCallback(interp,
PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), reqv, NULL);
}
return TCL_OK;
}
static int
PkgRequireCoreStep1(
ClientData data[],
Tcl_Interp *interp,
TCL_UNUSED(int))
{
Tcl_DString command;
char *script;
Require *reqPtr = (Require *)data[0];
int reqc = PTR2INT(data[1]);
Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
const char *name = reqPtr->name /* Name of desired package. */;
/*
* If we've got the package in the DB already, go on to actually loading
* it.
*/
|
| ︙ | ︙ | |||
547 548 549 550 551 552 553 |
static int
PkgRequireCoreStep2(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 |
static int
PkgRequireCoreStep2(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Require *reqPtr = (Require *)data[0];
int reqc = PTR2INT(data[1]);
Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
const char *name = reqPtr->name; /* Name of desired package. */
if ((result != TCL_OK) && (result != TCL_ERROR)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad return code: %d", result));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
result = TCL_ERROR;
|
| ︙ | ︙ | |||
571 572 573 574 575 576 577 |
/*
* pkgPtr may now be invalid, so refresh it.
*/
reqPtr->pkgPtr = FindPackage(interp, name);
Tcl_NRAddCallback(interp,
| | | | | | | 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 |
/*
* pkgPtr may now be invalid, so refresh it.
*/
reqPtr->pkgPtr = FindPackage(interp, name);
Tcl_NRAddCallback(interp,
SelectPackage, reqPtr, INT2PTR(reqc), reqv,
(void *)PkgRequireCoreFinal);
return TCL_OK;
}
static int
PkgRequireCoreFinal(
ClientData data[],
Tcl_Interp *interp,
TCL_UNUSED(int))
{
Require *reqPtr = (Require *)data[0];
int reqc = PTR2INT(data[1]), satisfies;
Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
char *pkgVersionI;
void *clientDataPtr = reqPtr->clientDataPtr;
const char *name = reqPtr->name; /* Name of desired package. */
if (reqPtr->pkgPtr->version == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't find package %s", name));
|
| ︙ | ︙ | |||
606 607 608 609 610 611 612 |
*/
if (reqc != 0) {
CheckVersionAndConvert(interp, Tcl_GetString(reqPtr->pkgPtr->version),
&pkgVersionI, NULL);
satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);
| | | 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 |
*/
if (reqc != 0) {
CheckVersionAndConvert(interp, Tcl_GetString(reqPtr->pkgPtr->version),
&pkgVersionI, NULL);
satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);
ckfree(pkgVersionI);
if (!satisfies) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"version conflict for package \"%s\": have %s, need",
name, Tcl_GetString(reqPtr->pkgPtr->version)));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT",
NULL);
|
| ︙ | ︙ | |||
631 632 633 634 635 636 637 |
Tcl_SetObjResult(interp, reqPtr->pkgPtr->version);
return TCL_OK;
}
static int
PkgRequireCoreCleanup(
ClientData data[],
| | | | | | | 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 |
Tcl_SetObjResult(interp, reqPtr->pkgPtr->version);
return TCL_OK;
}
static int
PkgRequireCoreCleanup(
ClientData data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
ckfree(data[0]);
return result;
}
static int
SelectPackage(
ClientData data[],
Tcl_Interp *interp,
TCL_UNUSED(int))
{
PkgAvail *availPtr, *bestPtr, *bestStablePtr;
char *availVersion, *bestVersion, *bestStableVersion;
/* Internal rep. of versions */
int availStable, satisfies;
Require *reqPtr = (Require *)data[0];
int reqc = PTR2INT(data[1]);
Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
const char *name = reqPtr->name;
Package *pkgPtr = reqPtr->pkgPtr;
Interp *iPtr = (Interp *) interp;
/*
* Check whether we're already attempting to load some version of this
* package (circular dependency detection).
|
| ︙ | ︙ | |||
703 704 705 706 707 708 709 |
* Check satisfaction of requirements before considering the current
* version further.
*/
if (reqc > 0) {
satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv);
if (!satisfies) {
| | | | | | | | | | | | 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 |
* Check satisfaction of requirements before considering the current
* version further.
*/
if (reqc > 0) {
satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv);
if (!satisfies) {
ckfree(availVersion);
availVersion = NULL;
continue;
}
}
if (bestPtr != NULL) {
int res = CompareVersions(availVersion, bestVersion, NULL);
/*
* Note: Used internal reps in the comparison!
*/
if (res > 0) {
/*
* The version of the package sought is better than the
* currently selected version.
*/
ckfree(bestVersion);
bestVersion = NULL;
goto newbest;
}
} else {
newbest:
/*
* We have found a version which is better than our max.
*/
bestPtr = availPtr;
CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL);
}
if (!availStable) {
ckfree(availVersion);
availVersion = NULL;
continue;
}
if (bestStablePtr != NULL) {
int res = CompareVersions(availVersion, bestStableVersion, NULL);
/*
* Note: Used internal reps in the comparison!
*/
if (res > 0) {
/*
* This stable version of the package sought is better than
* the currently selected stable version.
*/
ckfree(bestStableVersion);
bestStableVersion = NULL;
goto newstable;
}
} else {
newstable:
/*
* We have found a stable version which is better than our max
* stable.
*/
bestStablePtr = availPtr;
CheckVersionAndConvert(interp, bestStablePtr->version,
&bestStableVersion, NULL);
}
ckfree(availVersion);
availVersion = NULL;
} /* end for */
/*
* Clean up memorized internal reps, if any.
*/
if (bestVersion != NULL) {
ckfree(bestVersion);
bestVersion = NULL;
}
if (bestStableVersion != NULL) {
ckfree(bestStableVersion);
bestStableVersion = NULL;
}
/*
* Now choose a version among the two best. For 'latest' we simply take
* (actually keep) the best. For 'stable' we take the best stable, if
* there is any, or the best if there is nothing stable.
*/
if ((iPtr->packagePrefer == PKG_PREFER_STABLE)
&& (bestStablePtr != NULL)) {
bestPtr = bestStablePtr;
}
if (bestPtr == NULL) {
Tcl_NRAddCallback(interp,
(Tcl_NRPostProc *)data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
} else {
/*
* We found an ifneeded script for the package. Be careful while
* executing it: this could cause reentrancy, so (a) protect the
* script itself from deletion and (b) don't assume that bestPtr will
* still exist when the script completes.
*/
char *versionToProvide = bestPtr->version;
PkgFiles *pkgFiles;
PkgName *pkgName;
Tcl_Preserve(versionToProvide);
pkgPtr->clientData = versionToProvide;
pkgFiles = (PkgFiles *)TclInitPkgFiles(interp);
/*
* Push "ifneeded" package name in "tclPkgFiles" assocdata.
*/
pkgName = (PkgName *)ckalloc(sizeof(PkgName) + strlen(name));
pkgName->nextPtr = pkgFiles->names;
strcpy(pkgName->name, name);
pkgFiles->names = pkgName;
if (bestPtr->pkgIndex) {
TclPkgFileSeen(interp, bestPtr->pkgIndex);
}
reqPtr->versionToProvide = versionToProvide;
|
| ︙ | ︙ | |||
847 848 849 850 851 852 853 |
static int
SelectPackageFinal(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | | | | | | | 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 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 |
static int
SelectPackageFinal(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Require *reqPtr = (Require *)data[0];
int reqc = PTR2INT(data[1]);
Tcl_Obj **const reqv = (Tcl_Obj **)data[2];
const char *name = reqPtr->name;
char *versionToProvide = reqPtr->versionToProvide;
/*
* Pop the "ifneeded" package name from "tclPkgFiles" assocdata
*/
PkgFiles *pkgFiles = (PkgFiles *)Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
PkgName *pkgName = pkgFiles->names;
pkgFiles->names = pkgName->nextPtr;
ckfree(pkgName);
reqPtr->pkgPtr = FindPackage(interp, name);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
if (reqPtr->pkgPtr->version == NULL) {
result = TCL_ERROR;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"attempt to provide package %s %s failed:"
" no version of package %s provided",
name, versionToProvide, name));
Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
NULL);
} else {
char *pvi, *vi;
if (TCL_OK != CheckVersionAndConvert(interp,
Tcl_GetString(reqPtr->pkgPtr->version), &pvi, NULL)) {
result = TCL_ERROR;
} else if (CheckVersionAndConvert(interp,
versionToProvide, &vi, NULL) != TCL_OK) {
ckfree(pvi);
result = TCL_ERROR;
} else {
int res = CompareVersions(pvi, vi, NULL);
ckfree(pvi);
ckfree(vi);
if (res != 0) {
result = TCL_ERROR;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"attempt to provide package %s %s failed:"
" package %s %s provided instead",
name, versionToProvide,
name, Tcl_GetString(reqPtr->pkgPtr->version)));
|
| ︙ | ︙ | |||
939 940 941 942 943 944 945 |
reqPtr->pkgPtr->version = NULL;
}
reqPtr->pkgPtr->clientData = NULL;
return result;
}
Tcl_NRAddCallback(interp,
| | | 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 |
reqPtr->pkgPtr->version = NULL;
}
reqPtr->pkgPtr->clientData = NULL;
return result;
}
Tcl_NRAddCallback(interp,
(Tcl_NRPostProc *)data[3], reqPtr, INT2PTR(reqc), (void *) reqv, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_PkgPresent / Tcl_PkgPresentEx --
|
| ︙ | ︙ | |||
1000 1001 1002 1003 1004 1005 1006 |
{
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
Package *pkgPtr;
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
if (hPtr) {
| | | 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 |
{
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
Package *pkgPtr;
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
if (hPtr) {
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
/*
* At this point we know that the package is present. Make sure
* that the provided version meets the current requirement by
* calling Tcl_PkgRequireEx() to check for us.
*/
|
| ︙ | ︙ | |||
1048 1049 1050 1051 1052 1053 1054 | * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_PackageObjCmd( | | | < | | 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 |
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_PackageObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRPackageObjCmd, clientData, objc, objv);
}
int
TclNRPackageObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const pkgOptions[] = {
"files", "forget", "ifneeded", "names", "prefer",
"present", "provide", "require", "unknown", "vcompare",
|
| ︙ | ︙ | |||
1105 1106 1107 1108 1109 1110 1111 |
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "package");
return TCL_ERROR;
}
pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
if (pkgFiles) {
| | | < | | | | | < | | | | | | | | 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 |
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "package");
return TCL_ERROR;
}
pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
if (pkgFiles) {
Tcl_HashEntry *entry =
Tcl_FindHashEntry(&pkgFiles->table, Tcl_GetString(objv[2]));
if (entry) {
Tcl_SetObjResult(interp, (Tcl_Obj *)Tcl_GetHashValue(entry));
}
}
break;
}
case PKG_FORGET: {
const char *keyString;
PkgFiles *pkgFiles = (PkgFiles *)
Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
for (i = 2; i < objc; i++) {
keyString = TclGetString(objv[i]);
if (pkgFiles) {
hPtr = Tcl_FindHashEntry(&pkgFiles->table, keyString);
if (hPtr) {
Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
Tcl_DeleteHashEntry(hPtr);
Tcl_DecrRefCount(obj);
}
}
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
if (hPtr == NULL) {
continue;
}
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
Tcl_DeleteHashEntry(hPtr);
if (pkgPtr->version != NULL) {
Tcl_DecrRefCount(pkgPtr->version);
}
while (pkgPtr->availPtr != NULL) {
availPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr->nextPtr;
Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
if (availPtr->pkgIndex) {
Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
availPtr->pkgIndex = NULL;
}
ckfree(availPtr);
}
ckfree(pkgPtr);
}
break;
}
case PKG_IFNEEDED: {
int length, res;
char *argv3i, *avi;
if ((objc != 4) && (objc != 5)) {
Tcl_WrongNumArgs(interp, 2, objv, "package version ?script?");
return TCL_ERROR;
}
argv3 = TclGetString(objv[3]);
if (CheckVersionAndConvert(interp, argv3, &argv3i, NULL) != TCL_OK) {
return TCL_ERROR;
}
argv2 = TclGetString(objv[2]);
if (objc == 4) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr == NULL) {
ckfree(argv3i);
return TCL_OK;
}
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
} else {
pkgPtr = FindPackage(interp, argv2);
}
argv3 = TclGetStringFromObj(objv[3], &length);
for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL;
prevPtr = availPtr, availPtr = availPtr->nextPtr) {
if (CheckVersionAndConvert(interp, availPtr->version, &avi,
NULL) != TCL_OK) {
ckfree(argv3i);
return TCL_ERROR;
}
res = CompareVersions(avi, argv3i, NULL);
ckfree(avi);
if (res == 0) {
if (objc == 4) {
ckfree(argv3i);
Tcl_SetObjResult(interp,
Tcl_NewStringObj(availPtr->script, -1));
return TCL_OK;
}
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
if (availPtr->pkgIndex) {
Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
availPtr->pkgIndex = NULL;
}
break;
}
}
ckfree(argv3i);
if (objc == 4) {
return TCL_OK;
}
if (availPtr == NULL) {
availPtr = (PkgAvail *)ckalloc(sizeof(PkgAvail));
availPtr->pkgIndex = NULL;
DupBlock(availPtr->version, argv3, length + 1);
if (prevPtr == NULL) {
availPtr->nextPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr;
} else {
|
| ︙ | ︙ | |||
1243 1244 1245 1246 1247 1248 1249 |
} else {
Tcl_Obj *resultObj;
resultObj = Tcl_NewObj();
tablePtr = &iPtr->packageTable;
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
| | | | 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 |
} else {
Tcl_Obj *resultObj;
resultObj = Tcl_NewObj();
tablePtr = &iPtr->packageTable;
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
Tcl_ListObjAppendElement(NULL,resultObj, Tcl_NewStringObj(
(char *)Tcl_GetHashKey(tablePtr, hPtr), -1));
}
}
Tcl_SetObjResult(interp, resultObj);
}
break;
case PKG_PRESENT: {
const char *name;
|
| ︙ | ︙ | |||
1272 1273 1274 1275 1276 1277 1278 |
} else {
exact = 0;
name = argv2;
}
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
if (hPtr != NULL) {
| | | 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 |
} else {
exact = 0;
name = argv2;
}
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, name);
if (hPtr != NULL) {
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
goto require;
}
}
version = NULL;
if (exact) {
|
| ︙ | ︙ | |||
1307 1308 1309 1310 1311 1312 1313 |
Tcl_WrongNumArgs(interp, 2, objv, "package ?version?");
return TCL_ERROR;
}
argv2 = TclGetString(objv[2]);
if (objc == 3) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr != NULL) {
| | | 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 |
Tcl_WrongNumArgs(interp, 2, objv, "package ?version?");
return TCL_ERROR;
}
argv2 = TclGetString(objv[2]);
if (objc == 3) {
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr != NULL) {
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
Tcl_SetObjResult(interp, pkgPtr->version);
}
}
return TCL_OK;
}
argv3 = TclGetString(objv[3]);
|
| ︙ | ︙ | |||
1394 1395 1396 1397 1398 1399 1400 |
Tcl_NRAddCallback(interp,
PkgRequireCore, (void *) argv2, INT2PTR(newobjc),
newObjvPtr, NULL);
return TCL_OK;
}
break;
case PKG_UNKNOWN: {
| | | | 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 |
Tcl_NRAddCallback(interp,
PkgRequireCore, (void *) argv2, INT2PTR(newobjc),
newObjvPtr, NULL);
return TCL_OK;
}
break;
case PKG_UNKNOWN: {
int length;
if (objc == 2) {
if (iPtr->packageUnknown != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj(iPtr->packageUnknown, -1));
}
} else if (objc == 3) {
if (iPtr->packageUnknown != NULL) {
ckfree(iPtr->packageUnknown);
}
argv2 = TclGetStringFromObj(objv[2], &length);
if (argv2[0] == 0) {
iPtr->packageUnknown = NULL;
} else {
DupBlock(iPtr->packageUnknown, argv2, length+1);
}
|
| ︙ | ︙ | |||
1464 1465 1466 1467 1468 1469 1470 |
return TCL_ERROR;
}
argv3 = TclGetString(objv[3]);
argv2 = TclGetString(objv[2]);
if (CheckVersionAndConvert(interp, argv2, &iva, NULL) != TCL_OK ||
CheckVersionAndConvert(interp, argv3, &ivb, NULL) != TCL_OK) {
if (iva != NULL) {
| | | | | | 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 |
return TCL_ERROR;
}
argv3 = TclGetString(objv[3]);
argv2 = TclGetString(objv[2]);
if (CheckVersionAndConvert(interp, argv2, &iva, NULL) != TCL_OK ||
CheckVersionAndConvert(interp, argv3, &ivb, NULL) != TCL_OK) {
if (iva != NULL) {
ckfree(iva);
}
/*
* ivb cannot be set in this branch.
*/
return TCL_ERROR;
}
/*
* Comparison is done on the internal representation.
*/
Tcl_SetObjResult(interp,
Tcl_NewIntObj(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 = Tcl_NewObj();
argv2 = TclGetString(objv[2]);
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
if (hPtr != NULL) {
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
for (availPtr = pkgPtr->availPtr; availPtr != NULL;
availPtr = availPtr->nextPtr) {
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(availPtr->version, -1));
}
}
Tcl_SetObjResult(interp, resultObj);
|
| ︙ | ︙ | |||
1515 1516 1517 1518 1519 1520 1521 |
return TCL_ERROR;
}
argv2 = TclGetString(objv[2]);
if (CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK) {
return TCL_ERROR;
} else if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) {
| | | | | 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 |
return TCL_ERROR;
}
argv2 = TclGetString(objv[2]);
if (CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK) {
return TCL_ERROR;
} else if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) {
ckfree(argv2i);
return TCL_ERROR;
}
satisfies = SomeRequirementSatisfied(argv2i, objc-3, objv+3);
ckfree(argv2i);
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies));
break;
}
default:
Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions");
}
return TCL_OK;
}
static int
TclNRPackageObjCmdCleanup(
ClientData data[],
TCL_UNUSED(Tcl_Interp *),
int result)
{
TclDecrRefCount((Tcl_Obj *) data[0]);
TclDecrRefCount((Tcl_Obj *) data[1]);
return result;
}
|
| ︙ | ︙ | |||
1572 1573 1574 1575 1576 1577 1578 |
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
int isNew;
Package *pkgPtr;
hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew);
if (isNew) {
| | | | 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 |
Interp *iPtr = (Interp *) interp;
Tcl_HashEntry *hPtr;
int isNew;
Package *pkgPtr;
hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew);
if (isNew) {
pkgPtr = (Package *)ckalloc(sizeof(Package));
pkgPtr->version = NULL;
pkgPtr->availPtr = NULL;
pkgPtr->clientData = NULL;
Tcl_SetHashValue(hPtr, pkgPtr);
} else {
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
}
return pkgPtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1611 1612 1613 1614 1615 1616 1617 |
Package *pkgPtr;
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
PkgAvail *availPtr;
for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
| | | | | | 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 |
Package *pkgPtr;
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
PkgAvail *availPtr;
for (hPtr = Tcl_FirstHashEntry(&iPtr->packageTable, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
pkgPtr = (Package *)Tcl_GetHashValue(hPtr);
if (pkgPtr->version != NULL) {
Tcl_DecrRefCount(pkgPtr->version);
}
while (pkgPtr->availPtr != NULL) {
availPtr = pkgPtr->availPtr;
pkgPtr->availPtr = availPtr->nextPtr;
Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
if (availPtr->pkgIndex) {
Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
availPtr->pkgIndex = NULL;
}
ckfree(availPtr);
}
ckfree(pkgPtr);
}
Tcl_DeleteHashTable(&iPtr->packageTable);
if (iPtr->packageUnknown != NULL) {
ckfree(iPtr->packageUnknown);
}
}
/*
*----------------------------------------------------------------------
*
* CheckVersionAndConvert --
|
| ︙ | ︙ | |||
1670 1671 1672 1673 1674 1675 1676 |
const char *p = string;
char prevChar;
int hasunstable = 0;
/*
* 4* assuming that each char is a separator (a,b become ' -x ').
* 4+ to have spce for an additional -2 at the end
*/
| | | 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 |
const char *p = string;
char prevChar;
int hasunstable = 0;
/*
* 4* assuming that each char is a separator (a,b become ' -x ').
* 4+ to have spce for an additional -2 at the end
*/
char *ibuf = (char *)ckalloc(4 + 4*strlen(string));
char *ip = ibuf;
/*
* Basic rules
* (1) First character has to be a digit.
* (2) All other characters have to be a digit or '.'
* (3) Two '.'s may not follow each other.
|
| ︙ | ︙ | |||
1738 1739 1740 1741 1742 1743 1744 |
prevChar = *p;
}
if (prevChar!='.' && prevChar!='a' && prevChar!='b') {
*ip = '\0';
if (internal != NULL) {
*internal = ibuf;
} else {
| | | | 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 |
prevChar = *p;
}
if (prevChar!='.' && prevChar!='a' && prevChar!='b') {
*ip = '\0';
if (internal != NULL) {
*internal = ibuf;
} else {
ckfree(ibuf);
}
if (stable != NULL) {
*stable = !hasunstable;
}
return TCL_OK;
}
error:
ckfree(ibuf);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected version number but got \"%s\"", string));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL);
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
1997 1998 1999 2000 2001 2002 2003 |
* Syntax of requirement = version
* = version-version
* = version-
*/
char *dash = NULL, *buf;
| | | 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 |
* Syntax of requirement = version
* = version-version
* = version-
*/
char *dash = NULL, *buf;
dash = (char *)strchr(string, '-');
if (dash == NULL) {
/*
* No dash found, has to be a simple version.
*/
return CheckVersionAndConvert(interp, string, NULL, NULL);
}
|
| ︙ | ︙ | |||
2021 2022 2023 2024 2025 2026 2027 |
return TCL_ERROR;
}
/*
* Exactly one dash is present. Copy the string, split at the location of
* dash and check that both parts are versions. Note that the max part can
* be empty. Also note that the string allocated with strdup() must be
| | | | | 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 |
return TCL_ERROR;
}
/*
* Exactly one dash is present. Copy the string, split at the location of
* dash and check that both parts are versions. Note that the max part can
* be empty. Also note that the string allocated with strdup() must be
* freed with free() and not ckfree().
*/
DupString(buf, string);
dash = buf + (dash - string);
*dash = '\0'; /* buf now <=> min part */
dash++; /* dash now <=> max part */
if ((CheckVersionAndConvert(interp, buf, NULL, NULL) != TCL_OK) ||
((*dash != '\0') &&
(CheckVersionAndConvert(interp, dash, NULL, NULL) != TCL_OK))) {
ckfree(buf);
return TCL_ERROR;
}
ckfree(buf);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* AddRequirementsToResult --
|
| ︙ | ︙ | |||
2065 2066 2067 2068 2069 2070 2071 |
Tcl_Interp *interp,
int reqc, /* Requirements constraining the desired
* version. */
Tcl_Obj *const reqv[]) /* 0 means to use the latest version
* available. */
{
Tcl_Obj *result = Tcl_GetObjResult(interp);
| | < | 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 |
Tcl_Interp *interp,
int reqc, /* Requirements constraining the desired
* version. */
Tcl_Obj *const reqv[]) /* 0 means to use the latest version
* available. */
{
Tcl_Obj *result = Tcl_GetObjResult(interp);
int i, length;
for (i = 0; i < reqc; i++) {
const char *v = TclGetStringFromObj(reqv[i], &length);
if ((length & 0x1) && (v[length/2] == '-')
&& (strncmp(v, v+((length+1)/2), length/2) == 0)) {
Tcl_AppendPrintfToObj(result, " exactly %s", v+((length+1)/2));
|
| ︙ | ︙ | |||
2186 2187 2188 2189 2190 2191 2192 |
/*
* The have candidate is already in internal rep.
*/
int satisfied, res;
char *dash = NULL, *buf, *min, *max;
| | | | 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 |
/*
* The have candidate is already in internal rep.
*/
int satisfied, res;
char *dash = NULL, *buf, *min, *max;
dash = (char *)strchr(req, '-');
if (dash == NULL) {
/*
* No dash found, is a simple version, fallback to regular check. The
* 'CheckVersionAndConvert' cannot fail. We pad the requirement with
* 'a0', i.e '-2' before doing the comparison to properly accept
* unstables as well.
*/
char *reqi = NULL;
int thisIsMajor;
CheckVersionAndConvert(NULL, req, &reqi, NULL);
strcat(reqi, " -2");
res = CompareVersions(havei, reqi, &thisIsMajor);
satisfied = (res == 0) || ((res == 1) && !thisIsMajor);
ckfree(reqi);
return satisfied;
}
/*
* Exactly one dash is present (Assumption of valid syntax). Copy the req,
* split at the location of dash and check that both parts are versions.
* Note that the max part can be empty.
|
| ︙ | ︙ | |||
2226 2227 2228 2229 2230 2231 2232 | * We have a min, but no max. For the comparison we generate the * internal rep, padded with 'a0' i.e. '-2'. */ CheckVersionAndConvert(NULL, buf, &min, NULL); strcat(min, " -2"); satisfied = (CompareVersions(havei, min, NULL) >= 0); | | | | 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 |
* We have a min, but no max. For the comparison we generate the
* internal rep, padded with 'a0' i.e. '-2'.
*/
CheckVersionAndConvert(NULL, buf, &min, NULL);
strcat(min, " -2");
satisfied = (CompareVersions(havei, min, NULL) >= 0);
ckfree(min);
ckfree(buf);
return satisfied;
}
/*
* We have both min and max, and generate their internal reps. When
* identical we compare as is, otherwise we pad with 'a0' to ove the range
* a bit.
|
| ︙ | ︙ | |||
2249 2250 2251 2252 2253 2254 2255 |
} else {
strcat(min, " -2");
strcat(max, " -2");
satisfied = ((CompareVersions(min, havei, NULL) <= 0) &&
(CompareVersions(havei, max, NULL) < 0));
}
| | | | | 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 |
} else {
strcat(min, " -2");
strcat(max, " -2");
satisfied = ((CompareVersions(min, havei, NULL) <= 0) &&
(CompareVersions(havei, max, NULL) < 0));
}
ckfree(min);
ckfree(max);
ckfree(buf);
return satisfied;
}
/*
*----------------------------------------------------------------------
*
* Tcl_PkgInitStubsCheck --
|
| ︙ | ︙ | |||
2280 2281 2282 2283 2284 2285 2286 |
const char *
Tcl_PkgInitStubsCheck(
Tcl_Interp *interp,
const char * version,
int exact)
{
| | | | | 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 |
const char *
Tcl_PkgInitStubsCheck(
Tcl_Interp *interp,
const char * version,
int exact)
{
const char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0);
if ((exact&1) && actualVersion) {
const char *p = version;
int count = 0;
while (*p) {
count += !isdigit(UCHAR(*p++));
}
if (count == 1) {
if (0 != strncmp(version, actualVersion, strlen(version))) {
/* Construct error message */
Tcl_PkgPresent(interp, "Tcl", version, 1);
return NULL;
}
} else {
return Tcl_PkgPresent(interp, "Tcl", version, 1);
}
}
return actualVersion;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclPlatDecls.h.
| ︙ | ︙ | |||
48 49 50 51 52 53 54 | /* * Exported function declarations: */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ /* 0 */ | | | | | | | | | | 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 |
/*
* Exported function declarations:
*/
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
/* 0 */
EXTERN TCHAR * Tcl_WinUtfToTChar(const char *str, int len,
Tcl_DString *dsPtr);
/* 1 */
EXTERN char * Tcl_WinTCharToUtf(const TCHAR *str, int len,
Tcl_DString *dsPtr);
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
/* 0 */
EXTERN int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp,
const char *bundleName, int hasResourceFile,
int maxPathLen, char *libraryPath);
/* 1 */
EXTERN int Tcl_MacOSXOpenVersionedBundleResources(
Tcl_Interp *interp, const char *bundleName,
const char *bundleVersion,
int hasResourceFile, int maxPathLen,
char *libraryPath);
#endif /* MACOSX */
typedef struct TclPlatStubs {
int magic;
void *hooks;
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
TCHAR * (*tcl_WinUtfToTChar) (const char *str, int len, Tcl_DString *dsPtr); /* 0 */
char * (*tcl_WinTCharToUtf) (const TCHAR *str, int len, Tcl_DString *dsPtr); /* 1 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
int (*tcl_MacOSXOpenBundleResources) (Tcl_Interp *interp, const char *bundleName, int hasResourceFile, int maxPathLen, char *libraryPath); /* 0 */
int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, int maxPathLen, char *libraryPath); /* 1 */
#endif /* MACOSX */
} TclPlatStubs;
extern const TclPlatStubs *tclPlatStubsPtr;
#ifdef __cplusplus
}
|
| ︙ | ︙ | |||
109 110 111 112 113 114 115 116 117 118 119 | #define Tcl_MacOSXOpenVersionedBundleResources \ (tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */ #endif /* MACOSX */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT | > > > > > > > > > > > > > > | | > | 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 | #define Tcl_MacOSXOpenVersionedBundleResources \ (tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */ #endif /* MACOSX */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #ifdef MAC_OSX_TCL /* MACOSX */ #undef Tcl_MacOSXOpenBundleResources #define Tcl_MacOSXOpenBundleResources(a,b,c,d,e) Tcl_MacOSXOpenVersionedBundleResources(a,b,NULL,c,d,e) #endif #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #if defined(USE_TCL_STUBS) && (defined(_WIN32) || defined(__CYGWIN__))\ && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8) #undef Tcl_WinUtfToTChar #undef Tcl_WinTCharToUtf #ifdef _WIN32 #define Tcl_WinUtfToTChar(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \ (TCHAR *)Tcl_UtfToChar16DString((string), (len), (dsPtr))) #define Tcl_WinTCharToUtf(string, len, dsPtr) (Tcl_DStringInit(dsPtr), \ (char *)Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr))) #endif #endif #endif /* _TCLPLATDECLS */ |
Changes to generic/tclPreserve.c.
| ︙ | ︙ | |||
33 34 35 36 37 38 39 | /* * Global data structures used to hold the list of preserved data references. * These variables are protected by "preserveMutex". */ static Reference *refArray = NULL; /* First in array of references. */ | | | | | 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 |
/*
* Global data structures used to hold the list of preserved data references.
* These variables are protected by "preserveMutex".
*/
static Reference *refArray = NULL; /* First in array of references. */
static int spaceAvl = 0; /* Total number of structures available at
* *firstRefPtr. */
static int inUse = 0; /* Count of structures currently in use in
* refArray. */
TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */
#define INITIAL_SIZE 2 /* Initial number of reference slots to make */
/*
* The following data structure is used to keep track of whether an arbitrary
* block of memory has been deleted. This is used by the TclHandle code to
* avoid the more time-expensive algorithm of Tcl_Preserve(). This mechanism
* is mainly used when we have lots of references to a few big, expensive
* objects that we don't want to live any longer than necessary.
*/
typedef struct HandleStruct {
void *ptr; /* Pointer to the memory block being tracked.
* This field will become NULL when the memory
* block is deleted. This field must be the
* first in the structure. */
#ifdef TCL_MEM_DEBUG
void *ptr2; /* Backup copy of the above pointer used to
* ensure that the contents of the handle are
|
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | * * Side effects: * Frees the storage of the reference array. * *---------------------------------------------------------------------- */ | < | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 |
*
* Side effects:
* Frees the storage of the reference array.
*
*----------------------------------------------------------------------
*/
void
TclFinalizePreserve(void)
{
Tcl_MutexLock(&preserveMutex);
if (spaceAvl != 0) {
ckfree(refArray);
refArray = NULL;
inUse = 0;
spaceAvl = 0;
}
Tcl_MutexUnlock(&preserveMutex);
}
|
| ︙ | ︙ | |||
117 118 119 120 121 122 123 |
*/
void
Tcl_Preserve(
ClientData clientData) /* Pointer to malloc'ed block of memory. */
{
Reference *refPtr;
| | | 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 |
*/
void
Tcl_Preserve(
ClientData clientData) /* Pointer to malloc'ed block of memory. */
{
Reference *refPtr;
int i;
/*
* See if there is already a reference for this pointer. If so, just
* increment its reference count.
*/
Tcl_MutexLock(&preserveMutex);
|
| ︙ | ︙ | |||
140 141 142 143 144 145 146 |
/*
* Make a reference array if it doesn't already exist, or make it bigger
* if it is full.
*/
if (inUse == spaceAvl) {
spaceAvl = spaceAvl ? 2*spaceAvl : INITIAL_SIZE;
| | | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 |
/*
* Make a reference array if it doesn't already exist, or make it bigger
* if it is full.
*/
if (inUse == spaceAvl) {
spaceAvl = spaceAvl ? 2*spaceAvl : INITIAL_SIZE;
refArray = (Reference *)ckrealloc(refArray, spaceAvl * sizeof(Reference));
}
/*
* Make a new entry for the new reference.
*/
refPtr = &refArray[inUse];
|
| ︙ | ︙ | |||
180 181 182 183 184 185 186 |
*/
void
Tcl_Release(
ClientData clientData) /* Pointer to malloc'ed block of memory. */
{
Reference *refPtr;
| | | 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 |
*/
void
Tcl_Release(
ClientData clientData) /* Pointer to malloc'ed block of memory. */
{
Reference *refPtr;
int i;
Tcl_MutexLock(&preserveMutex);
for (i=0, refPtr=refArray ; i<inUse ; i++, refPtr++) {
int mustFree;
Tcl_FreeProc *freeProc;
if (refPtr->clientData != clientData) {
|
| ︙ | ︙ | |||
220 221 222 223 224 225 226 |
* Only then should we dabble around with potentially-slow memory
* managers...
*/
Tcl_MutexUnlock(&preserveMutex);
if (mustFree) {
if (freeProc == TCL_DYNAMIC) {
| | | | 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 |
* Only then should we dabble around with potentially-slow memory
* managers...
*/
Tcl_MutexUnlock(&preserveMutex);
if (mustFree) {
if (freeProc == TCL_DYNAMIC) {
ckfree(clientData);
} else {
freeProc((char *)clientData);
}
}
return;
}
Tcl_MutexUnlock(&preserveMutex);
/*
|
| ︙ | ︙ | |||
260 261 262 263 264 265 266 |
void
Tcl_EventuallyFree(
ClientData clientData, /* Pointer to malloc'ed block of memory. */
Tcl_FreeProc *freeProc) /* Function to actually do free. */
{
Reference *refPtr;
| | | 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 |
void
Tcl_EventuallyFree(
ClientData clientData, /* Pointer to malloc'ed block of memory. */
Tcl_FreeProc *freeProc) /* Function to actually do free. */
{
Reference *refPtr;
int i;
/*
* See if there is a reference for this pointer. If so, set its "mustFree"
* flag (the flag had better not be set already!).
*/
Tcl_MutexLock(&preserveMutex);
|
| ︙ | ︙ | |||
287 288 289 290 291 292 293 |
Tcl_MutexUnlock(&preserveMutex);
/*
* No reference for this block. Free it now.
*/
if (freeProc == TCL_DYNAMIC) {
| | | | 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 |
Tcl_MutexUnlock(&preserveMutex);
/*
* No reference for this block. Free it now.
*/
if (freeProc == TCL_DYNAMIC) {
ckfree(clientData);
} else {
freeProc((char *)clientData);
}
}
/*
*---------------------------------------------------------------------------
*
* TclHandleCreate --
|
| ︙ | ︙ | |||
323 324 325 326 327 328 329 |
TclHandle
TclHandleCreate(
void *ptr) /* Pointer to an arbitrary block of memory to
* be tracked for deletion. Must not be
* NULL. */
{
| | | 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 |
TclHandle
TclHandleCreate(
void *ptr) /* Pointer to an arbitrary block of memory to
* be tracked for deletion. Must not be
* NULL. */
{
HandleStruct *handlePtr = (HandleStruct *)ckalloc(sizeof(HandleStruct));
handlePtr->ptr = ptr;
#ifdef TCL_MEM_DEBUG
handlePtr->ptr2 = ptr;
#endif
handlePtr->refCount = 0;
return (TclHandle) handlePtr;
|
| ︙ | ︙ | |||
373 374 375 376 377 378 379 |
if (handlePtr->ptr2 != handlePtr->ptr) {
Tcl_Panic("someone has changed the block referenced by the handle %p\nfrom %p to %p",
handlePtr, handlePtr->ptr2, handlePtr->ptr);
}
#endif
handlePtr->ptr = NULL;
if (handlePtr->refCount == 0) {
| | | 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 |
if (handlePtr->ptr2 != handlePtr->ptr) {
Tcl_Panic("someone has changed the block referenced by the handle %p\nfrom %p to %p",
handlePtr, handlePtr->ptr2, handlePtr->ptr);
}
#endif
handlePtr->ptr = NULL;
if (handlePtr->refCount == 0) {
ckfree(handlePtr);
}
}
/*
*---------------------------------------------------------------------------
*
* TclHandlePreserve --
|
| ︙ | ︙ | |||
456 457 458 459 460 461 462 |
}
if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) {
Tcl_Panic("someone has changed the block referenced by the handle %p\nfrom %p to %p",
handlePtr, handlePtr->ptr2, handlePtr->ptr);
}
#endif
if ((handlePtr->refCount-- <= 1) && (handlePtr->ptr == NULL)) {
| | | 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 |
}
if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) {
Tcl_Panic("someone has changed the block referenced by the handle %p\nfrom %p to %p",
handlePtr, handlePtr->ptr2, handlePtr->ptr);
}
#endif
if ((handlePtr->refCount-- <= 1) && (handlePtr->ptr == NULL)) {
ckfree(handlePtr);
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclProc.c.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 | /* * Prototypes for static functions in this file */ static void DupLambdaInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void FreeLambdaInternalRep(Tcl_Obj *objPtr); | | < | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | /* * Prototypes for static functions in this file */ static void DupLambdaInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void FreeLambdaInternalRep(Tcl_Obj *objPtr); static int InitArgsAndLocals(Tcl_Interp *interp, int skip); static void InitResolvedLocals(Tcl_Interp *interp, ByteCode *codePtr, Var *defPtr, Namespace *nsPtr); static void InitLocalCache(Proc *procPtr); static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void ProcBodyFree(Tcl_Obj *objPtr); static int ProcWrongNumArgs(Tcl_Interp *interp, int skip); |
| ︙ | ︙ | |||
77 78 79 80 81 82 83 |
Tcl_StoreIntRep((objPtr), &tclProcBodyType, &ir); \
} while (0)
#define ProcGetIntRep(objPtr, procPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &tclProcBodyType); \
| | | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 |
Tcl_StoreIntRep((objPtr), &tclProcBodyType, &ir); \
} while (0)
#define ProcGetIntRep(objPtr, procPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &tclProcBodyType); \
(procPtr) = irPtr ? (Proc *)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
* The [upvar]/[uplevel] level reference type. Uses the longValue field
* to remember the integer value of a parsed #<integer> format.
*
* Uses the default behaviour throughout, and never disposes of the string
|
| ︙ | ︙ | |||
123 124 125 126 127 128 129 |
Tcl_StoreIntRep((objPtr), &lambdaType, &ir); \
} while (0)
#define LambdaGetIntRep(objPtr, procPtr, nsObjPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &lambdaType); \
| | | < | | | 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 |
Tcl_StoreIntRep((objPtr), &lambdaType, &ir); \
} while (0)
#define LambdaGetIntRep(objPtr, procPtr, nsObjPtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &lambdaType); \
(procPtr) = irPtr ? (Proc *)irPtr->twoPtrValue.ptr1 : NULL; \
(nsObjPtr) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr2 : NULL; \
} while (0)
/*
*----------------------------------------------------------------------
*
* Tcl_ProcObjCmd --
*
* This object-based function is invoked to process the "proc" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl object result value.
*
* Side effects:
* A new procedure gets created.
*
*----------------------------------------------------------------------
*/
int
Tcl_ProcObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr;
const char *procName;
const char *simpleName, *procArgs, *procBody;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
Tcl_Command cmd;
if (objc != 4) {
|
| ︙ | ︙ | |||
194 195 196 197 198 199 200 |
return TCL_ERROR;
}
/*
* Create the data structure to represent the procedure.
*/
| | | | 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 |
return TCL_ERROR;
}
/*
* Create the data structure to represent the procedure.
*/
if (TclCreateProc(interp, /*ignored nsPtr*/ NULL, simpleName, objv[2],
objv[3], &procPtr) != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (creating proc \"");
Tcl_AddErrorInfo(interp, simpleName);
Tcl_AddErrorInfo(interp, "\")");
return TCL_ERROR;
}
cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr,
|
| ︙ | ︙ | |||
228 229 230 231 232 233 234 |
* this file. The differences are the different index of the body in the
* line array of the context, and the lambda code requires some special
* processing. Find a way to factor the common elements into a single
* function.
*/
if (iPtr->cmdFramePtr) {
| | | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 |
* this file. The differences are the different index of the body in the
* line array of the context, and the lambda code requires some special
* processing. Find a way to factor the common elements into a single
* function.
*/
if (iPtr->cmdFramePtr) {
CmdFrame *contextPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
*contextPtr = *iPtr->cmdFramePtr;
if (contextPtr->type == TCL_LOCATION_BC) {
/*
* Retrieve source information from the bytecode, if possible. If
* the information is retrieved successfully, context.type will be
* TCL_LOCATION_SOURCE and the reference held by
|
| ︙ | ︙ | |||
259 260 261 262 263 264 265 |
* proc body was not created by substitution.
*/
if (contextPtr->line
&& (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) {
int isNew;
Tcl_HashEntry *hePtr;
| | | | 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 |
* proc body was not created by substitution.
*/
if (contextPtr->line
&& (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) {
int isNew;
Tcl_HashEntry *hePtr;
CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame));
cfPtr->level = -1;
cfPtr->type = contextPtr->type;
cfPtr->line = (int *)ckalloc(sizeof(int));
cfPtr->line[0] = contextPtr->line[3];
cfPtr->nline = 1;
cfPtr->framePtr = NULL;
cfPtr->nextPtr = NULL;
cfPtr->data.eval.path = contextPtr->data.eval.path;
Tcl_IncrRefCount(cfPtr->data.eval.path);
|
| ︙ | ︙ | |||
285 286 287 288 289 290 291 | /* * Get the old command frame and release it. See also * TclProcCleanupProc in this file. Currently it seems as * if only the procbodytest::proc command of the testsuite * is able to trigger this situation. */ | | | | | 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 |
/*
* Get the old command frame and release it. See also
* TclProcCleanupProc in this file. Currently it seems as
* if only the procbodytest::proc command of the testsuite
* is able to trigger this situation.
*/
CmdFrame *cfOldPtr = (CmdFrame *)Tcl_GetHashValue(hePtr);
if (cfOldPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(cfOldPtr->data.eval.path);
cfOldPtr->data.eval.path = NULL;
}
ckfree(cfOldPtr->line);
cfOldPtr->line = NULL;
ckfree(cfOldPtr);
}
Tcl_SetHashValue(hePtr, cfPtr);
}
/*
* 'contextPtr' is going out of scope; account for the reference
* that it's holding to the path name.
|
| ︙ | ︙ | |||
325 326 327 328 329 330 331 |
* seem to make a lot of sense to verify the number of arguments we
* are about to ignore ...
* - could be enhanced to handle also non-empty bodies that contain only
* comments; however, parsing the body will slow down the compilation
* of all procs whose argument list is just _args_
*/
| | | | 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 |
* seem to make a lot of sense to verify the number of arguments we
* are about to ignore ...
* - could be enhanced to handle also non-empty bodies that contain only
* comments; however, parsing the body will slow down the compilation
* of all procs whose argument list is just _args_
*/
if (TclHasIntRep(objv[3], &tclProcBodyType)) {
goto done;
}
procArgs = TclGetString(objv[2]);
while (*procArgs == ' ') {
procArgs++;
}
if ((procArgs[0] == 'a') && (strncmp(procArgs, "args", 4) == 0)) {
int numBytes;
procArgs +=4;
while (*procArgs != '\0') {
if (*procArgs != ' ') {
goto done;
}
procArgs++;
|
| ︙ | ︙ | |||
393 394 395 396 397 398 399 |
*
*----------------------------------------------------------------------
*/
int
TclCreateProc(
Tcl_Interp *interp, /* Interpreter containing proc. */
| | | | | 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 |
*
*----------------------------------------------------------------------
*/
int
TclCreateProc(
Tcl_Interp *interp, /* Interpreter containing proc. */
TCL_UNUSED(Namespace *) /*nsPtr*/,
const char *procName, /* Unqualified name of this proc. */
Tcl_Obj *argsPtr, /* Description of arguments. */
Tcl_Obj *bodyPtr, /* Command body. */
Proc **procPtrPtr) /* Returns: pointer to proc data. */
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr = NULL;
int i, result, numArgs;
CompiledLocal *localPtr = NULL;
Tcl_Obj **argArray;
int precompiled = 0;
ProcGetIntRep(bodyPtr, procPtr);
if (procPtr != NULL) {
/*
* Because the body is a TclProProcBody, the actual body is already
|
| ︙ | ︙ | |||
442 443 444 445 446 447 448 |
* have a different number of arguments, even if their bodies are
* identical. Note that we don't use Tcl_DuplicateObj since we would
* not want any bytecode internal representation.
*/
if (Tcl_IsShared(bodyPtr)) {
const char *bytes;
| | | 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 |
* have a different number of arguments, even if their bodies are
* identical. Note that we don't use Tcl_DuplicateObj since we would
* not want any bytecode internal representation.
*/
if (Tcl_IsShared(bodyPtr)) {
const char *bytes;
int length;
Tcl_Obj *sharedBodyPtr = bodyPtr;
bytes = TclGetStringFromObj(bodyPtr, &length);
bodyPtr = Tcl_NewStringObj(bytes, length);
/*
* TIP #280.
|
| ︙ | ︙ | |||
465 466 467 468 469 470 471 | * Create and initialize a Proc structure for the procedure. We * increment the ref count of the procedure's body object since there * will be a reference to it in the Proc structure. */ Tcl_IncrRefCount(bodyPtr); | | | 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 | * Create and initialize a Proc structure for the procedure. We * increment the ref count of the procedure's body object since there * will be a reference to it in the Proc structure. */ Tcl_IncrRefCount(bodyPtr); procPtr = (Proc *)ckalloc(sizeof(Proc)); procPtr->iPtr = iPtr; procPtr->refCount = 1; procPtr->bodyPtr = bodyPtr; procPtr->numArgs = 0; /* Actual argument count is set below. */ procPtr->numCompiledLocals = 0; procPtr->firstLocalPtr = NULL; procPtr->lastLocalPtr = NULL; |
| ︙ | ︙ | |||
505 506 507 508 509 510 511 |
} else {
procPtr->numArgs = numArgs;
procPtr->numCompiledLocals = numArgs;
}
for (i = 0; i < numArgs; i++) {
const char *argname, *argnamei, *argnamelast;
| | < | 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 |
} else {
procPtr->numArgs = numArgs;
procPtr->numCompiledLocals = numArgs;
}
for (i = 0; i < numArgs; i++) {
const char *argname, *argnamei, *argnamelast;
int fieldCount, nameLength;
Tcl_Obj **fieldValues;
/*
* Now divide the specifier up into name and default.
*/
result = Tcl_ListObjGetElements(interp, argArray[i], &fieldCount,
|
| ︙ | ︙ | |||
536 537 538 539 540 541 542 | Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument with no name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } | | | | | | 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 |
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"argument with no name", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
argname = Tcl_GetStringFromObj(fieldValues[0], &nameLength);
/*
* Check that the formal parameter name is a scalar.
*/
argnamei = argname;
argnamelast = (nameLength > 0) ? (argname + nameLength - 1) : argname;
while (argnamei < argnamelast) {
if (*argnamei == '(') {
if (*argnamelast == ')') { /* We have an array element. */
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"formal parameter \"%s\" is an array element",
Tcl_GetString(fieldValues[0])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
} else if (*argnamei == ':' && *(argnamei+1) == ':') {
Tcl_Obj *errorObj = Tcl_NewStringObj(
"formal parameter \"", -1);
Tcl_AppendObjToObj(errorObj, fieldValues[0]);
Tcl_AppendToObj(errorObj, "\" is not a simple name", -1);
Tcl_SetObjResult(interp, errorObj);
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
"FORMALARGUMENTFORMAT", NULL);
goto procError;
}
argnamei++;
}
if (precompiled) {
/*
* Compare the parsed argument with the stored one. Note that the
* only flag value that makes sense at this point is VAR_ARGUMENT
* (its value was kept the same as pre VarReform to simplify
|
| ︙ | ︙ | |||
598 599 600 601 602 603 604 |
}
/*
* Compare the default value if any.
*/
if (localPtr->defValuePtr != NULL) {
| < | > | > | 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 |
}
/*
* Compare the default value if any.
*/
if (localPtr->defValuePtr != NULL) {
const char *tmpPtr = TclGetString(localPtr->defValuePtr);
size_t tmpLength = localPtr->defValuePtr->length;
const char *value = TclGetString(fieldValues[1]);
size_t valueLength = fieldValues[1]->length;
if ((valueLength != tmpLength)
|| memcmp(value, tmpPtr, tmpLength) != 0
) {
Tcl_Obj *errorObj = Tcl_ObjPrintf(
"procedure \"%s\": formal parameter \"", procName);
Tcl_AppendObjToObj(errorObj, fieldValues[0]);
|
| ︙ | ︙ | |||
630 631 632 633 634 635 636 |
localPtr = localPtr->nextPtr;
} else {
/*
* Allocate an entry in the runtime procedure frame's array of
* local variables for the argument.
*/
| | | 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 |
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;
|
| ︙ | ︙ | |||
675 676 677 678 679 680 681 |
localPtr = procPtr->firstLocalPtr;
procPtr->firstLocalPtr = localPtr->nextPtr;
if (localPtr->defValuePtr != NULL) {
Tcl_DecrRefCount(localPtr->defValuePtr);
}
| | | | 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 |
localPtr = procPtr->firstLocalPtr;
procPtr->firstLocalPtr = localPtr->nextPtr;
if (localPtr->defValuePtr != NULL) {
Tcl_DecrRefCount(localPtr->defValuePtr);
}
ckfree(localPtr);
}
ckfree(procPtr);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
757 758 759 760 761 762 763 |
int
TclObjGetFrame(
Tcl_Interp *interp, /* Interpreter in which to find frame. */
Tcl_Obj *objPtr, /* Object describing frame. */
CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if
* global frame indicated). */
{
| | | 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 |
int
TclObjGetFrame(
Tcl_Interp *interp, /* Interpreter in which to find frame. */
Tcl_Obj *objPtr, /* Object describing frame. */
CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if
* global frame indicated). */
{
Interp *iPtr = (Interp *) interp;
int curLevel, level, result;
const Tcl_ObjIntRep *irPtr;
const char *name = NULL;
Tcl_WideInt w;
/*
* Parse object to figure out which level number to go to.
|
| ︙ | ︙ | |||
804 805 806 807 808 809 810 |
ir.wideValue = level;
Tcl_StoreIntRep(objPtr, &levelReferenceType, &ir);
result = 1;
}
} else {
result = -1;
}
| | > > | > > > > > | | < | | | 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 |
ir.wideValue = level;
Tcl_StoreIntRep(objPtr, &levelReferenceType, &ir);
result = 1;
}
} else {
result = -1;
}
} else if (TclGetWideBitsFromObj(NULL, objPtr, &w) == TCL_OK) {
/*
* If this were an integer, we'd have succeeded already.
* Docs say we have to treat this as a 'bad level' error.
*/
result = -1;
}
}
if (result != -1) {
/* if relative current level */
if (result == 0) {
if (!curLevel) {
/* we are in top-level, so simply generate bad level */
name = "1";
goto badLevel;
}
level = curLevel - 1;
}
if (level >= 0) {
CallFrame *framePtr;
for (framePtr = iPtr->varFramePtr; framePtr != NULL;
framePtr = framePtr->callerVarPtr) {
if (framePtr->level == level) {
*framePtrPtr = framePtr;
return result;
}
}
}
}
badLevel:
if (name == NULL) {
name = objPtr ? TclGetString(objPtr) : "1" ;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, NULL);
return -1;
}
/*
|
| ︙ | ︙ | |||
860 861 862 863 864 865 866 |
static int
Uplevel_Callback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | < | | | | | 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 |
static int
Uplevel_Callback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
CallFrame *savedVarFramePtr = (CallFrame *)data[0];
if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (\"uplevel\" body line %d)", Tcl_GetErrorLine(interp)));
}
/*
* Restore the variable frame, and return.
*/
((Interp *)interp)->varFramePtr = savedVarFramePtr;
return result;
}
int
Tcl_UplevelObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRUplevelObjCmd, clientData, objc, objv);
}
int
TclNRUplevelObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
CmdFrame *invoker = NULL;
int word = 0;
int result;
CallFrame *savedVarFramePtr, *framePtr;
Tcl_Obj *objPtr;
if (objc < 2) {
|
| ︙ | ︙ | |||
1023 1024 1025 1026 1027 1028 1029 |
{
Tcl_Command origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (origCmd != NULL) {
cmdPtr = (Command *) origCmd;
}
if (cmdPtr->deleteProc == TclProcDeleteProc) {
| | | | | > > > > | | 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 |
{
Tcl_Command origCmd = TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (origCmd != NULL) {
cmdPtr = (Command *) origCmd;
}
if (cmdPtr->deleteProc == TclProcDeleteProc) {
return (Proc *)cmdPtr->objClientData;
}
return NULL;
}
static int
ProcWrongNumArgs(
Tcl_Interp *interp,
int skip)
{
CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
Proc *procPtr = framePtr->procPtr;
int localCt = procPtr->numCompiledLocals, numArgs, i;
Tcl_Obj **desiredObjs;
const char *final = NULL;
/*
* Build up desired argument list for Tcl_WrongNumArgs
*/
numArgs = framePtr->procPtr->numArgs;
desiredObjs = (Tcl_Obj **)TclStackAlloc(interp,
sizeof(Tcl_Obj *) * (numArgs+1));
if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1);
} else {
#ifdef AVOID_HACKS_FOR_ITCL
desiredObjs[0] = framePtr->objv[skip-1];
#else
desiredObjs[0] = Tcl_NewListObj(1, framePtr->objv + skip - 1);
#endif /* AVOID_HACKS_FOR_ITCL */
}
Tcl_IncrRefCount(desiredObjs[0]);
if (localCt > 0) {
Var *defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt);
for (i=1 ; i<=numArgs ; i++, defPtr++) {
Tcl_Obj *argObj;
Tcl_Obj *namePtr = localName(framePtr, i-1);
if (defPtr->value.objPtr != NULL) {
TclNewObj(argObj);
|
| ︙ | ︙ | |||
1190 1191 1192 1193 1194 1195 1196 |
firstLocalPtr = localPtr;
for (; localPtr != NULL; localPtr = localPtr->nextPtr) {
if (localPtr->resolveInfo) {
if (localPtr->resolveInfo->deleteProc) {
localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
} else {
| | | 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 |
firstLocalPtr = localPtr;
for (; localPtr != NULL; localPtr = localPtr->nextPtr) {
if (localPtr->resolveInfo) {
if (localPtr->resolveInfo->deleteProc) {
localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
} else {
ckfree(localPtr->resolveInfo);
}
localPtr->resolveInfo = NULL;
}
localPtr->flags &= ~VAR_RESOLVED;
if (haveResolvers &&
!(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY))) {
|
| ︙ | ︙ | |||
1246 1247 1248 1249 1250 1251 1252 |
/*
* Now invoke the resolvers to determine the exact variables that
* should be used.
*/
resVarInfo = localPtr->resolveInfo;
if (resVarInfo && resVarInfo->fetchProc) {
| | | 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 |
/*
* Now invoke the resolvers to determine the exact variables that
* should be used.
*/
resVarInfo = localPtr->resolveInfo;
if (resVarInfo && resVarInfo->fetchProc) {
Var *resolvedVarPtr = (Var *)
resVarInfo->fetchProc(interp, resVarInfo);
if (resolvedVarPtr) {
if (TclIsVarInHash(resolvedVarPtr)) {
VarHashRefCount(resolvedVarPtr)++;
}
varPtr->flags = VAR_LINK;
|
| ︙ | ︙ | |||
1269 1270 1271 1272 1273 1274 1275 |
Tcl_Interp *interp,
LocalCache *localCachePtr)
{
int i;
Tcl_Obj **namePtrPtr = &localCachePtr->varName0;
for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) {
| | | | | | | | 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 |
Tcl_Interp *interp,
LocalCache *localCachePtr)
{
int i;
Tcl_Obj **namePtrPtr = &localCachePtr->varName0;
for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) {
Tcl_Obj *objPtr = *namePtrPtr;
if (objPtr) {
/* TclReleaseLiteral calls Tcl_DecrRefCount for us */
TclReleaseLiteral(interp, objPtr);
}
}
ckfree(localCachePtr);
}
static void
InitLocalCache(
Proc *procPtr)
{
Interp *iPtr = procPtr->iPtr;
ByteCode *codePtr;
int localCt = procPtr->numCompiledLocals;
int numArgs = procPtr->numArgs, i = 0;
Tcl_Obj **namePtr;
Var *varPtr;
LocalCache *localCachePtr;
CompiledLocal *localPtr;
int isNew;
ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
/*
* 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(sizeof(LocalCache)
+ (localCt - 1) * sizeof(Tcl_Obj *)
+ numArgs * sizeof(Var));
namePtr = &localCachePtr->varName0;
varPtr = (Var *) (namePtr + localCt);
localPtr = procPtr->firstLocalPtr;
while (localPtr) {
if (TclIsVarTemporary(localPtr)) {
*namePtr = NULL;
} else {
*namePtr = TclCreateLiteral(iPtr, localPtr->name,
localPtr->nameLength, /* hash */ (unsigned int) -1,
&isNew, /* nsPtr */ NULL, 0, NULL);
Tcl_IncrRefCount(*namePtr);
}
if (i < numArgs) {
varPtr->flags = (localPtr->flags & VAR_IS_ARGS);
varPtr->value.objPtr = localPtr->defValuePtr;
varPtr++;
|
| ︙ | ︙ | |||
1355 1356 1357 1358 1359 1360 1361 | * are being referenced at runtime. * *---------------------------------------------------------------------- */ static int InitArgsAndLocals( | | < | | | 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 |
* are being referenced at runtime.
*
*----------------------------------------------------------------------
*/
static int
InitArgsAndLocals(
Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
int skip) /* Number of initial arguments to be skipped,
* i.e., words in the "command name". */
{
CallFrame *framePtr = ((Interp *)interp)->varFramePtr;
Proc *procPtr = framePtr->procPtr;
ByteCode *codePtr;
Var *varPtr, *defPtr;
int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax;
Tcl_Obj *const *argObjs;
ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr);
/*
* Make sure that the local cache of variable names and initial values has
|
| ︙ | ︙ | |||
1392 1393 1394 1395 1396 1397 1398 |
/*
* Create the "compiledLocals" array. Make sure it is large enough to hold
* all the procedure's compiled local variables, including its formal
* parameters.
*/
| | | 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 |
/*
* Create the "compiledLocals" array. Make sure it is large enough to hold
* all the procedure's compiled local variables, including its formal
* parameters.
*/
varPtr = (Var *)TclStackAlloc(interp, localCt * sizeof(Var));
framePtr->compiledLocals = varPtr;
framePtr->numCompiledLocals = localCt;
/*
* Match and assign the call's actual parameters to the procedure's formal
* arguments. The formal arguments are described by the first numArgs
* entries in both the Proc structure's local variable list and the call
|
| ︙ | ︙ | |||
1522 1523 1524 1525 1526 1527 1528 |
*----------------------------------------------------------------------
*/
int
TclPushProcCallFrame(
ClientData clientData, /* Record describing procedure to be
* interpreted. */
| | | | 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 |
*----------------------------------------------------------------------
*/
int
TclPushProcCallFrame(
ClientData clientData, /* Record describing procedure to be
* interpreted. */
Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
int objc, /* Count of number of arguments to this
* procedure. */
Tcl_Obj *const objv[], /* Argument value objects. */
int isLambda) /* 1 if this is a call by ApplyObjCmd: it
* needs special rules for error msg */
{
Proc *procPtr = (Proc *)clientData;
Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
CallFrame *framePtr, **framePtrPtr;
int result;
ByteCode *codePtr;
/*
* If necessary (i.e. if we haven't got a suitable compilation already
|
| ︙ | ︙ | |||
1614 1615 1616 1617 1618 1619 1620 |
*----------------------------------------------------------------------
*/
int
TclObjInterpProc(
ClientData clientData, /* Record describing procedure to be
* interpreted. */
| | | | 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 |
*----------------------------------------------------------------------
*/
int
TclObjInterpProc(
ClientData clientData, /* Record describing procedure to be
* interpreted. */
Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
int objc, /* Count of number of arguments to this
* procedure. */
Tcl_Obj *const objv[]) /* Argument value objects. */
{
/*
* Not used much in the core; external interface for iTcl
*/
return Tcl_NRCallObjProc(interp, TclNRInterpProc, clientData, objc, objv);
}
int
TclNRInterpProc(
ClientData clientData, /* Record describing procedure to be
* interpreted. */
Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
int objc, /* Count of number of arguments to this
* procedure. */
Tcl_Obj *const objv[]) /* Argument value objects. */
{
int result = TclPushProcCallFrame(clientData, interp, objc, objv,
/*isLambda*/ 0);
|
| ︙ | ︙ | |||
1666 1667 1668 1669 1670 1671 1672 | * Nearly anything; depends on the commands in the procedure body. * *---------------------------------------------------------------------- */ int TclNRInterpProcCore( | | | | | | | 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 |
* Nearly anything; depends on the commands in the procedure body.
*
*----------------------------------------------------------------------
*/
int
TclNRInterpProcCore(
Tcl_Interp *interp,/* Interpreter in which procedure was
* invoked. */
Tcl_Obj *procNameObj, /* Procedure name for error reporting. */
int skip, /* Number of initial arguments to be skipped,
* i.e., words in the "command name". */
ProcErrorProc *errorProc) /* How to convert results from the script into
* results of the overall procedure. */
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr = iPtr->varFramePtr->procPtr;
int result;
CallFrame *freePtr;
ByteCode *codePtr;
result = InitArgsAndLocals(interp, skip);
if (result != TCL_OK) {
freePtr = iPtr->framePtr;
Tcl_PopCallFrame(interp); /* Pop but do not free. */
TclStackFree(interp, freePtr->compiledLocals);
/* Free compiledLocals. */
TclStackFree(interp, freePtr); /* Free CallFrame. */
return TCL_ERROR;
}
#if defined(TCL_COMPILE_DEBUG)
if (tclTraceExec >= 1) {
CallFrame *framePtr = iPtr->varFramePtr;
int i;
if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
fprintf(stdout, "Calling lambda ");
} else {
fprintf(stdout, "Calling proc ");
}
for (i = 0; i < framePtr->objc; i++) {
|
| ︙ | ︙ | |||
1770 1771 1772 1773 1774 1775 1776 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr = iPtr->varFramePtr->procPtr;
CallFrame *freePtr;
| | | 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 |
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
Proc *procPtr = iPtr->varFramePtr->procPtr;
CallFrame *freePtr;
Tcl_Obj *procNameObj = (Tcl_Obj *)data[0];
ProcErrorProc *errorProc = (ProcErrorProc *)data[1];
if (TCL_DTRACE_PROC_RETURN_ENABLED()) {
int l = iPtr->varFramePtr->isProcCallFrame & FRAME_IS_LAMBDA ? 1 : 0;
TCL_DTRACE_PROC_RETURN(l < iPtr->varFramePtr->objc ?
TclGetString(iPtr->varFramePtr->objv[l]) : NULL, result);
|
| ︙ | ︙ | |||
1839 1840 1841 1842 1843 1844 1845 | Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invoked \"%s\" outside of a loop", ((result == TCL_BREAK) ? "break" : "continue"))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL); result = TCL_ERROR; | | < < | 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"invoked \"%s\" outside of a loop",
((result == TCL_BREAK) ? "break" : "continue")));
Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL);
result = TCL_ERROR;
/* FALLTHRU */
case TCL_ERROR:
/*
* Now it _must_ be an error, so we need to log it as such. This means
* filling out the error trace. Luckily, we just hand this off to the
* function handed to us as an argument.
*/
|
| ︙ | ︙ | |||
1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 | TclNewLiteralStringObj(message, "Compiling "); Tcl_IncrRefCount(message); Tcl_AppendStringsToObj(message, description, " \"", NULL); Tcl_AppendLimitedToObj(message, procName, -1, 50, NULL); fprintf(stdout, "%s\"\n", TclGetString(message)); Tcl_DecrRefCount(message); } #endif /* * Plug the current procPtr into the interpreter and coerce the code * body to byte codes. The interpreter needs to know which proc it's * compiling so that it can access its list of compiled locals. * | > > > | 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 |
TclNewLiteralStringObj(message, "Compiling ");
Tcl_IncrRefCount(message);
Tcl_AppendStringsToObj(message, description, " \"", NULL);
Tcl_AppendLimitedToObj(message, procName, -1, 50, NULL);
fprintf(stdout, "%s\"\n", TclGetString(message));
Tcl_DecrRefCount(message);
}
#else
(void)description;
(void)procName;
#endif
/*
* Plug the current procPtr into the interpreter and coerce the code
* body to byte codes. The interpreter needs to know which proc it's
* compiling so that it can access its list of compiled locals.
*
|
| ︙ | ︙ | |||
1987 1988 1989 1990 1991 1992 1993 |
CompiledLocal *toFree = clPtr;
clPtr = clPtr->nextPtr;
if (toFree->resolveInfo) {
if (toFree->resolveInfo->deleteProc) {
toFree->resolveInfo->deleteProc(toFree->resolveInfo);
} else {
| | | | | 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 |
CompiledLocal *toFree = clPtr;
clPtr = clPtr->nextPtr;
if (toFree->resolveInfo) {
if (toFree->resolveInfo->deleteProc) {
toFree->resolveInfo->deleteProc(toFree->resolveInfo);
} else {
ckfree(toFree->resolveInfo);
}
}
ckfree(toFree);
}
procPtr->numCompiledLocals = procPtr->numArgs;
}
(void) TclPushStackFrame(interp, &framePtr, (Tcl_Namespace *) nsPtr,
/* isProcCallFrame */ 0);
/*
* TIP #280: We get the invoking context from the cmdFrame which
* was saved by 'Tcl_ProcObjCmd' (using linePBodyPtr).
*/
hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr);
/*
* Constructed saved frame has body as word 0. See Tcl_ProcObjCmd.
*/
iPtr->invokeWord = 0;
iPtr->invokeCmdFramePtr = hePtr ? (CmdFrame *)Tcl_GetHashValue(hePtr) : NULL;
TclSetByteCodeFromAny(interp, bodyPtr, NULL, NULL);
iPtr->invokeCmdFramePtr = NULL;
TclPopStackFrame(interp);
} else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
/*
* The resolver epoch has changed, but we only need to invalidate the
* resolver cache.
|
| ︙ | ︙ | |||
2051 2052 2053 2054 2055 2056 2057 |
static void
MakeProcError(
Tcl_Interp *interp, /* The interpreter in which the procedure was
* called. */
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
| | < | | 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 |
static void
MakeProcError(
Tcl_Interp *interp, /* The interpreter in which the procedure was
* called. */
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
int overflow, limit = 60, nameLen;
const char *procName = TclGetStringFromObj(procNameObj, &nameLen);
overflow = (nameLen > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (procedure \"%.*s%s\" line %d)",
(overflow ? limit : nameLen), procName,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
/*
*----------------------------------------------------------------------
*
* TclProcDeleteProc --
|
| ︙ | ︙ | |||
2086 2087 2088 2089 2090 2091 2092 |
*----------------------------------------------------------------------
*/
void
TclProcDeleteProc(
ClientData clientData) /* Procedure to be deleted. */
{
| | | 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 |
*----------------------------------------------------------------------
*/
void
TclProcDeleteProc(
ClientData clientData) /* Procedure to be deleted. */
{
Proc *procPtr = (Proc *)clientData;
if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
}
}
/*
|
| ︙ | ︙ | |||
2112 2113 2114 2115 2116 2117 2118 | * Memory gets freed. * *---------------------------------------------------------------------- */ void TclProcCleanupProc( | | | | | | | | | | 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 |
* Memory gets freed.
*
*----------------------------------------------------------------------
*/
void
TclProcCleanupProc(
Proc *procPtr) /* Procedure to be deleted. */
{
CompiledLocal *localPtr;
Tcl_Obj *bodyPtr = procPtr->bodyPtr;
Tcl_Obj *defPtr;
Tcl_ResolvedVarInfo *resVarInfo;
Tcl_HashEntry *hePtr = NULL;
CmdFrame *cfPtr = NULL;
Interp *iPtr = procPtr->iPtr;
if (bodyPtr != NULL) {
Tcl_DecrRefCount(bodyPtr);
}
for (localPtr = procPtr->firstLocalPtr; localPtr != NULL; ) {
CompiledLocal *nextPtr = localPtr->nextPtr;
resVarInfo = localPtr->resolveInfo;
if (resVarInfo) {
if (resVarInfo->deleteProc) {
resVarInfo->deleteProc(resVarInfo);
} else {
ckfree(resVarInfo);
}
}
if (localPtr->defValuePtr != NULL) {
defPtr = localPtr->defValuePtr;
Tcl_DecrRefCount(defPtr);
}
ckfree(localPtr);
localPtr = nextPtr;
}
ckfree(procPtr);
/*
* TIP #280: Release the location data associated with this Proc
* structure, if any. The interpreter may not exist (For example for
* procbody structures created by tbcload.
*/
if (iPtr == NULL) {
return;
}
hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, (char *) procPtr);
if (!hePtr) {
return;
}
cfPtr = (CmdFrame *)Tcl_GetHashValue(hePtr);
if (cfPtr) {
if (cfPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount(cfPtr->data.eval.path);
cfPtr->data.eval.path = NULL;
}
ckfree(cfPtr->line);
cfPtr->line = NULL;
ckfree(cfPtr);
}
Tcl_DeleteHashEntry(hePtr);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2363 2364 2365 2366 2367 2368 2369 |
*
*----------------------------------------------------------------------
*/
static void
DupLambdaInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
| | | | | 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 |
*
*----------------------------------------------------------------------
*/
static void
DupLambdaInternalRep(
Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
Proc *procPtr;
Tcl_Obj *nsObjPtr;
LambdaGetIntRep(srcPtr, procPtr, nsObjPtr);
assert(procPtr != NULL);
procPtr->refCount++;
LambdaSetIntRep(copyPtr, procPtr, nsObjPtr);
}
static void
FreeLambdaInternalRep(
Tcl_Obj *objPtr) /* CmdName object with internal representation
* to free. */
{
Proc *procPtr;
Tcl_Obj *nsObjPtr;
LambdaGetIntRep(objPtr, procPtr, nsObjPtr);
assert(procPtr != NULL);
if (procPtr->refCount-- <= 1) {
TclProcCleanupProc(procPtr);
}
TclDecrRefCount(nsObjPtr);
}
static int
SetLambdaFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
Interp *iPtr = (Interp *) interp;
const char *name;
Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv;
int isNew, objc, result;
CmdFrame *cfPtr = NULL;
Proc *procPtr;
|
| ︙ | ︙ | |||
2418 2419 2420 2421 2422 2423 2424 |
* length is not 2, then it cannot be converted to lambdaType.
*/
result = TclListObjGetElements(NULL, objPtr, &objc, &objv);
if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't interpret \"%s\" as a lambda expression",
| | | 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 |
* length is not 2, then it cannot be converted to lambdaType.
*/
result = TclListObjGetElements(NULL, objPtr, &objc, &objv);
if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't interpret \"%s\" as a lambda expression",
Tcl_GetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL);
return TCL_ERROR;
}
argsPtr = objv[0];
bodyPtr = objv[1];
|
| ︙ | ︙ | |||
2468 2469 2470 2471 2472 2473 2474 |
* this file. The differences are the different index of the body in the
* line array of the context, and the special processing mentioned in the
* previous paragraph to track into the list. Find a way to factor the
* common elements into a single function.
*/
if (iPtr->cmdFramePtr) {
| | | 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 |
* this file. The differences are the different index of the body in the
* line array of the context, and the special processing mentioned in the
* previous paragraph to track into the list. Find a way to factor the
* common elements into a single function.
*/
if (iPtr->cmdFramePtr) {
CmdFrame *contextPtr = (CmdFrame *)TclStackAlloc(interp, sizeof(CmdFrame));
*contextPtr = *iPtr->cmdFramePtr;
if (contextPtr->type == TCL_LOCATION_BC) {
/*
* Retrieve the source context from the bytecode. This call
* accounts for the reference to the source file, if any, held in
* 'context.data.eval.path'.
|
| ︙ | ︙ | |||
2504 2505 2506 2507 2508 2509 2510 | int buf[2]; /* * Move from approximation (line of list cmd word) to actual * location (line of 2nd list element). */ | | | | 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 | int buf[2]; /* * Move from approximation (line of list cmd word) to actual * location (line of 2nd list element). */ cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame)); TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL); cfPtr->level = -1; cfPtr->type = contextPtr->type; cfPtr->line = (int *)ckalloc(sizeof(int)); cfPtr->line[0] = buf[1]; cfPtr->nline = 1; cfPtr->framePtr = NULL; cfPtr->nextPtr = NULL; cfPtr->data.eval.path = contextPtr->data.eval.path; Tcl_IncrRefCount(cfPtr->data.eval.path); |
| ︙ | ︙ | |||
2608 2609 2610 2611 2612 2613 2614 | * Depends on the content of the lambda term (i.e., objv[1]). * *---------------------------------------------------------------------- */ int Tcl_ApplyObjCmd( | | | | | 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 |
* Depends on the content of the lambda term (i.e., objv[1]).
*
*----------------------------------------------------------------------
*/
int
Tcl_ApplyObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, TclNRApplyObjCmd, clientData, objc, objv);
}
int
TclNRApplyObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Proc *procPtr = NULL;
Tcl_Obj *lambdaPtr, *nsObjPtr;
int result;
|
| ︙ | ︙ | |||
2656 2657 2658 2659 2660 2661 2662 |
*/
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
if (result != TCL_OK) {
return TCL_ERROR;
}
| | | 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 |
*/
result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
if (result != TCL_OK) {
return TCL_ERROR;
}
extraPtr = (ApplyExtraData *)TclStackAlloc(interp, sizeof(ApplyExtraData));
memset(&extraPtr->cmd, 0, sizeof(Command));
procPtr->cmdPtr = &extraPtr->cmd;
extraPtr->cmd.nsPtr = (Namespace *) nsPtr;
/*
* TIP#280 (semi-)HACK!
*
|
| ︙ | ︙ | |||
2691 2692 2693 2694 2695 2696 2697 |
static int
ApplyNR2(
ClientData data[],
Tcl_Interp *interp,
int result)
{
| | | 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 |
static int
ApplyNR2(
ClientData data[],
Tcl_Interp *interp,
int result)
{
ApplyExtraData *extraPtr = (ApplyExtraData *)data[0];
TclStackFree(interp, extraPtr);
return result;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
2722 2723 2724 2725 2726 2727 2728 |
static void
MakeLambdaError(
Tcl_Interp *interp, /* The interpreter in which the procedure was
* called. */
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
| | < | | 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 |
static void
MakeLambdaError(
Tcl_Interp *interp, /* The interpreter in which the procedure was
* called. */
Tcl_Obj *procNameObj) /* Name of the procedure. Used for error
* messages and trace information. */
{
int overflow, limit = 60, nameLen;
const char *procName = TclGetStringFromObj(procNameObj, &nameLen);
overflow = (nameLen > limit);
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (lambda term \"%.*s%s\" line %d)",
(overflow ? limit : nameLen), procName,
(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
}
/*
*----------------------------------------------------------------------
*
* TclGetCmdFrameForProcedure --
|
| ︙ | ︙ |
Changes to generic/tclProcess.c.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | * Prototypes for functions defined later in this file: */ static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid, int resolvedPid); static void FreeProcessInfo(ProcessInfo *info); static int RefreshProcessInfo(ProcessInfo *info, int options); | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | * Prototypes for functions defined later in this file: */ static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid, int resolvedPid); static void FreeProcessInfo(ProcessInfo *info); static int RefreshProcessInfo(ProcessInfo *info, int options); static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid, int options, int *codePtr, Tcl_Obj **msgPtr, Tcl_Obj **errorObjPtr); static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info); static int ProcessListObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int ProcessStatusObjCmd(ClientData clientData, |
| ︙ | ︙ | |||
126 127 128 129 130 131 132 |
Tcl_DecrRefCount(info->error);
}
/*
* Free allocated structure.
*/
| | | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 |
Tcl_DecrRefCount(info->error);
}
/*
* Free allocated structure.
*/
ckfree(info);
}
/*
*----------------------------------------------------------------------
*
* RefreshProcessInfo --
*
|
| ︙ | ︙ | |||
189 190 191 192 193 194 195 |
*
*----------------------------------------------------------------------
*/
TclProcessWaitStatus
WaitProcessStatus(
Tcl_Pid pid, /* Process id. */
| | | 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 |
*
*----------------------------------------------------------------------
*/
TclProcessWaitStatus
WaitProcessStatus(
Tcl_Pid pid, /* Process id. */
int resolvedPid, /* Resolved process id. */
int options, /* Options passed to Tcl_WaitPid. */
int *codePtr, /* If non-NULL, will receive either:
* - 0 for normal exit.
* - errno in case of error.
* - non-zero exit code for abormal exit.
* - signal number if killed or suspended.
* - Tcl_WaitPid status in all other cases.
|
| ︙ | ︙ | |||
398 399 400 401 402 403 404 | * Access to the internal structures is protected by infoTablesMutex. * *---------------------------------------------------------------------- */ static int ProcessListObjCmd( | | | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 |
* Access to the internal structures is protected by infoTablesMutex.
*
*----------------------------------------------------------------------
*/
static int
ProcessListObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *list;
Tcl_HashEntry *entry;
Tcl_HashSearch search;
|
| ︙ | ︙ | |||
449 450 451 452 453 454 455 | * Calls RefreshProcessInfo, which can block if -wait switch is given. * *---------------------------------------------------------------------- */ static int ProcessStatusObjCmd( | | | 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 |
* Calls RefreshProcessInfo, which can block if -wait switch is given.
*
*----------------------------------------------------------------------
*/
static int
ProcessStatusObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *dict;
int index, options = WNOHANG;
Tcl_HashEntry *entry;
|
| ︙ | ︙ | |||
597 598 599 600 601 602 603 | * Frees all ProcessInfo structures with their purge flag set. * *---------------------------------------------------------------------- */ static int ProcessPurgeObjCmd( | | | 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 |
* Frees all ProcessInfo structures with their purge flag set.
*
*----------------------------------------------------------------------
*/
static int
ProcessPurgeObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_HashEntry *entry;
Tcl_HashSearch search;
ProcessInfo *info;
|
| ︙ | ︙ | |||
697 698 699 700 701 702 703 | * Alters detached process handling by Tcl_ReapDetachedProcs(). * *---------------------------------------------------------------------- */ static int ProcessAutopurgeObjCmd( | | > | 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 |
* Alters detached process handling by Tcl_ReapDetachedProcs().
*
*----------------------------------------------------------------------
*/
static int
ProcessAutopurgeObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 1 && objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?flag?");
return TCL_ERROR;
}
if (objc == 2) {
/*
|
| ︙ | ︙ | |||
795 796 797 798 799 800 801 |
*----------------------------------------------------------------------
*/
void
TclProcessCreated(
Tcl_Pid pid) /* Process id. */
{
| | | 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 |
*----------------------------------------------------------------------
*/
void
TclProcessCreated(
Tcl_Pid pid) /* Process id. */
{
int resolvedPid;
Tcl_HashEntry *entry, *entry2;
int isNew;
ProcessInfo *info;
/*
* Get resolved pid first.
*/
|
| ︙ | ︙ | |||
829 830 831 832 833 834 835 |
FreeProcessInfo(info);
}
/*
* Allocate and initialize info structure.
*/
| | | 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 |
FreeProcessInfo(info);
}
/*
* Allocate and initialize info structure.
*/
info = (ProcessInfo *) ckalloc(sizeof(ProcessInfo));
InitProcessInfo(info, pid, resolvedPid);
/*
* Add entry to tables.
*/
Tcl_SetHashValue(entry, info);
|
| ︙ | ︙ |
Changes to generic/tclRegexp.c.
| ︙ | ︙ | |||
66 67 68 69 70 71 72 |
#define NUM_REGEXPS 30
typedef struct {
int initialized; /* Set to 1 when the module is initialized. */
char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled regular
* expression patterns. NULL means that this
* slot isn't used. Malloc-ed. */
| | | | | | 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 |
#define NUM_REGEXPS 30
typedef struct {
int initialized; /* Set to 1 when the module is initialized. */
char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled regular
* expression patterns. NULL means that this
* slot isn't used. Malloc-ed. */
int patLengths[NUM_REGEXPS];/* Number of non-null characters in
* corresponding entry in patterns. -1 means
* entry isn't used. */
struct TclRegexp *regexps[NUM_REGEXPS];
/* Compiled forms of above strings. Also
* malloc-ed, or NULL if not in use yet. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* Declarations for functions used only in this file.
*/
static TclRegexp * CompileRegexp(Tcl_Interp *interp, const char *pattern,
int length, int flags);
static void DupRegexpInternalRep(Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr);
static void FinalizeRegexp(ClientData clientData);
static void FreeRegexp(TclRegexp *regexpPtr);
static void FreeRegexpInternalRep(Tcl_Obj *objPtr);
static int RegExpExecUniChar(Tcl_Interp *interp, Tcl_RegExp re,
const Tcl_UniChar *uniString, int numChars,
int nmatches, int flags);
static int SetRegexpFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
/*
* The regular expression Tcl object type. This serves as a cache of the
* compiled form of the regular expression.
*/
|
| ︙ | ︙ | |||
118 119 120 121 122 123 124 |
Tcl_StoreIntRep((objPtr), &tclRegexpType, &ir); \
} while (0)
#define RegexpGetIntRep(objPtr, rePtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &tclRegexpType); \
| | | 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 |
Tcl_StoreIntRep((objPtr), &tclRegexpType, &ir); \
} while (0)
#define RegexpGetIntRep(objPtr, rePtr) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &tclRegexpType); \
(rePtr) = irPtr ? (TclRegexp *)irPtr->twoPtrValue.ptr1 : NULL; \
} while (0)
/*
*----------------------------------------------------------------------
*
* Tcl_RegExpCompile --
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 |
* returned by previous call to
* Tcl_GetRegExpFromObj. */
const char *text, /* Text against which to match re. */
const char *start) /* If text is part of a larger string, this
* identifies beginning of larger string, so
* that "^" won't match. */
{
| | < | 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 |
* returned by previous call to
* Tcl_GetRegExpFromObj. */
const char *text, /* Text against which to match re. */
const char *start) /* If text is part of a larger string, this
* identifies beginning of larger string, so
* that "^" won't match. */
{
int flags, result, numChars;
TclRegexp *regexp = (TclRegexp *) re;
Tcl_DString ds;
const Tcl_UniChar *ustr;
/*
* If the starting point is offset from the beginning of the buffer, then
* we need to tell the regexp engine not to match "^".
|
| ︙ | ︙ | |||
247 248 249 250 251 252 253 |
*---------------------------------------------------------------------------
*/
void
Tcl_RegExpRange(
Tcl_RegExp re, /* Compiled regular expression that has been
* passed to Tcl_RegExpExec. */
| | | | 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 |
*---------------------------------------------------------------------------
*/
void
Tcl_RegExpRange(
Tcl_RegExp re, /* Compiled regular expression that has been
* passed to Tcl_RegExpExec. */
int index, /* 0 means give the range of the entire match,
* > 0 means give the range of a matching
* subrange. */
const char **startPtr, /* Store address of first character in
* (sub-)range here. */
const char **endPtr) /* Store address of character just after last
* in (sub-)range here. */
{
TclRegexp *regexpPtr = (TclRegexp *) re;
const char *string;
if ((size_t) index > regexpPtr->re.re_nsub) {
*startPtr = *endPtr = NULL;
} else if (regexpPtr->matches[index].rm_so == TCL_INDEX_NONE) {
*startPtr = *endPtr = NULL;
} else {
if (regexpPtr->objPtr) {
string = TclGetString(regexpPtr->objPtr);
} else {
|
| ︙ | ︙ | |||
299 300 301 302 303 304 305 |
static int
RegExpExecUniChar(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
Tcl_RegExp re, /* Compiled regular expression; returned by a
* previous call to Tcl_GetRegExpFromObj */
const Tcl_UniChar *wString, /* String against which to match re. */
| | > | > | | | | 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 |
static int
RegExpExecUniChar(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
Tcl_RegExp re, /* Compiled regular expression; returned by a
* previous call to Tcl_GetRegExpFromObj */
const Tcl_UniChar *wString, /* String against which to match re. */
int numChars, /* Length of Tcl_UniChar string (must be
* >=0). */
int nmatches, /* How many subexpression matches (counting
* the whole match as subexpression 0) are of
* interest. -1 means "don't know". */
int flags) /* Regular expression flags. */
{
int status;
TclRegexp *regexpPtr = (TclRegexp *) re;
size_t last = regexpPtr->re.re_nsub + 1;
size_t nm = last;
if (nmatches >= 0 && (size_t) nmatches < nm) {
nm = (size_t) nmatches;
}
status = TclReExec(®expPtr->re, wString, (size_t) numChars,
®expPtr->details, nm, regexpPtr->matches, flags);
/*
* Check for errors.
*/
if (status != REG_OKAY) {
|
| ︙ | ︙ | |||
357 358 359 360 361 362 363 |
*---------------------------------------------------------------------------
*/
void
TclRegExpRangeUniChar(
Tcl_RegExp re, /* Compiled regular expression that has been
* passed to Tcl_RegExpExec. */
| | | | | | 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 |
*---------------------------------------------------------------------------
*/
void
TclRegExpRangeUniChar(
Tcl_RegExp re, /* Compiled regular expression that has been
* passed to Tcl_RegExpExec. */
int index, /* 0 means give the range of the entire match,
* > 0 means give the range of a matching
* subrange, TCL_INDEX_NONE means the range of the
* rm_extend field. */
int *startPtr, /* Store address of first character in
* (sub-)range here. */
int *endPtr) /* Store address of character just after last
* in (sub-)range here. */
{
TclRegexp *regexpPtr = (TclRegexp *) re;
if ((regexpPtr->flags®_EXPECT) && (index == TCL_INDEX_NONE)) {
*startPtr = regexpPtr->details.rm_extend.rm_so;
*endPtr = regexpPtr->details.rm_extend.rm_eo;
} else if ((size_t) index > regexpPtr->re.re_nsub) {
*startPtr = TCL_INDEX_NONE;
*endPtr = TCL_INDEX_NONE;
} else {
*startPtr = regexpPtr->matches[index].rm_so;
*endPtr = regexpPtr->matches[index].rm_eo;
}
}
|
| ︙ | ︙ | |||
437 438 439 440 441 442 443 |
int
Tcl_RegExpExecObj(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
Tcl_RegExp re, /* Compiled regular expression; must have been
* returned by previous call to
* Tcl_GetRegExpFromObj. */
Tcl_Obj *textObj, /* Text against which to match re. */
| | | | | 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 |
int
Tcl_RegExpExecObj(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
Tcl_RegExp re, /* Compiled regular expression; must have been
* returned by previous call to
* Tcl_GetRegExpFromObj. */
Tcl_Obj *textObj, /* Text against which to match re. */
int offset, /* Character index that marks where matching
* should begin. */
int nmatches, /* How many subexpression matches (counting
* the whole match as subexpression 0) are of
* interest. -1 means all of them. */
int flags) /* Regular expression execution flags. */
{
TclRegexp *regexpPtr = (TclRegexp *) re;
Tcl_UniChar *udata;
int length;
int reflags = regexpPtr->flags;
#define TCL_REG_GLOBOK_FLAGS \
(TCL_REG_ADVANCED | TCL_REG_NOSUB | TCL_REG_NOCASE)
/*
* Take advantage of the equivalent glob pattern, if one exists.
* This is possible based only on the right mix of incoming flags (0)
|
| ︙ | ︙ | |||
477 478 479 480 481 482 483 |
/*
* Save the target object so we can extract strings from it later.
*/
regexpPtr->string = NULL;
regexpPtr->objPtr = textObj;
| | | 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 |
/*
* Save the target object so we can extract strings from it later.
*/
regexpPtr->string = NULL;
regexpPtr->objPtr = textObj;
udata = Tcl_GetUnicodeFromObj(textObj, &length);
if (offset > length) {
offset = length;
}
udata += offset;
length -= offset;
|
| ︙ | ︙ | |||
589 590 591 592 593 594 595 |
* the interp regexp cache. */
Tcl_Obj *objPtr, /* Object whose string rep contains regular
* expression pattern. Internal rep will be
* changed to compiled form of this regular
* expression. */
int flags) /* Regular expression compilation flags. */
{
| | | 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 |
* the interp regexp cache. */
Tcl_Obj *objPtr, /* Object whose string rep contains regular
* expression pattern. Internal rep will be
* changed to compiled form of this regular
* expression. */
int flags) /* Regular expression compilation flags. */
{
int length;
TclRegexp *regexpPtr;
const char *pattern;
RegexpGetIntRep(objPtr, regexpPtr);
if ((regexpPtr == NULL) || (regexpPtr->flags != flags)) {
pattern = TclGetStringFromObj(objPtr, &length);
|
| ︙ | ︙ | |||
673 674 675 676 677 678 679 |
* 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...
*/
resultObj = Tcl_NewObj();
Tcl_ListObjAppendElement(NULL, resultObj,
| | | 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...
*/
resultObj = Tcl_NewObj();
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewWideIntObj((Tcl_WideInt) regexpPtr->re.re_nsub));
/*
* Now append a list of all the bit-flags set for the RE.
*/
TclNewObj(infoObj);
for (inf=infonames ; inf->bit != 0 ; inf++) {
|
| ︙ | ︙ | |||
720 721 722 723 724 725 726 |
{
char buf[100]; /* ample in practice */
char cbuf[TCL_INTEGER_SPACE];
size_t n;
const char *p;
Tcl_ResetResult(interp);
| | | | 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 |
{
char buf[100]; /* ample in practice */
char cbuf[TCL_INTEGER_SPACE];
size_t n;
const char *p;
Tcl_ResetResult(interp);
n = TclReError(status, buf, sizeof(buf));
p = (n > sizeof(buf)) ? "..." : "";
Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s%s%s", msg, buf, p));
sprintf(cbuf, "%d", status);
(void) TclReError(REG_ITOA, cbuf, sizeof(cbuf));
Tcl_SetErrorCode(interp, "REGEXP", cbuf, buf, NULL);
}
/*
*----------------------------------------------------------------------
*
* FreeRegexpInternalRep --
|
| ︙ | ︙ | |||
853 854 855 856 857 858 859 |
*----------------------------------------------------------------------
*/
static TclRegexp *
CompileRegexp(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
const char *string, /* The regexp to compile (UTF-8). */
| | | 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 |
*----------------------------------------------------------------------
*/
static TclRegexp *
CompileRegexp(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
const char *string, /* The regexp to compile (UTF-8). */
int length, /* The length of the string in bytes. */
int flags) /* Compilation flags. */
{
TclRegexp *regexpPtr;
const Tcl_UniChar *uniString;
int numChars, status, i, exact;
Tcl_DString stringBuf;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
911 912 913 914 915 916 917 |
}
}
/*
* This is a new expression, so compile it and add it to the cache.
*/
| | | 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 |
}
}
/*
* This is a new expression, so compile it and add it to the cache.
*/
regexpPtr = (TclRegexp*)ckalloc(sizeof(TclRegexp));
regexpPtr->objPtr = NULL;
regexpPtr->string = NULL;
regexpPtr->details.rm_extend.rm_so = -1;
regexpPtr->details.rm_extend.rm_eo = -1;
/*
* Get the up-to-date string representation and map to unicode.
|
| ︙ | ︙ | |||
938 939 940 941 942 943 944 |
Tcl_DStringFree(&stringBuf);
if (status != REG_OKAY) {
/*
* Clean up and report errors in the interpreter, if possible.
*/
| | | 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 |
Tcl_DStringFree(&stringBuf);
if (status != REG_OKAY) {
/*
* Clean up and report errors in the interpreter, if possible.
*/
ckfree(regexpPtr);
if (interp) {
TclRegError(interp,
"couldn't compile regular expression pattern: ", status);
}
return NULL;
}
|
| ︙ | ︙ | |||
966 967 968 969 970 971 972 |
/*
* Allocate enough space for all of the subexpressions, plus one extra for
* the entire pattern.
*/
regexpPtr->matches =
| | | | | 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 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 |
/*
* Allocate enough space for all of the subexpressions, plus one extra for
* the entire pattern.
*/
regexpPtr->matches =
(regmatch_t*)ckalloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1));
/*
* Initialize the refcount to one initially, since it is in the cache.
*/
regexpPtr->refCount = 1;
/*
* Free the last regexp, if necessary, and make room at the head of the
* list for the new regexp.
*/
if (tsdPtr->patterns[NUM_REGEXPS-1] != NULL) {
TclRegexp *oldRegexpPtr = tsdPtr->regexps[NUM_REGEXPS-1];
if (oldRegexpPtr->refCount-- <= 1) {
FreeRegexp(oldRegexpPtr);
}
ckfree(tsdPtr->patterns[NUM_REGEXPS-1]);
}
for (i = NUM_REGEXPS - 2; i >= 0; i--) {
tsdPtr->patterns[i+1] = tsdPtr->patterns[i];
tsdPtr->patLengths[i+1] = tsdPtr->patLengths[i];
tsdPtr->regexps[i+1] = tsdPtr->regexps[i];
}
tsdPtr->patterns[0] = (char *)ckalloc(length + 1);
memcpy(tsdPtr->patterns[0], string, length + 1);
tsdPtr->patLengths[0] = length;
tsdPtr->regexps[0] = regexpPtr;
return regexpPtr;
}
|
| ︙ | ︙ | |||
1025 1026 1027 1028 1029 1030 1031 |
TclRegexp *regexpPtr) /* Compiled regular expression to free. */
{
TclReFree(®expPtr->re);
if (regexpPtr->globObjPtr) {
TclDecrRefCount(regexpPtr->globObjPtr);
}
if (regexpPtr->matches) {
| | | | | | 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 |
TclRegexp *regexpPtr) /* Compiled regular expression to free. */
{
TclReFree(®expPtr->re);
if (regexpPtr->globObjPtr) {
TclDecrRefCount(regexpPtr->globObjPtr);
}
if (regexpPtr->matches) {
ckfree(regexpPtr->matches);
}
ckfree(regexpPtr);
}
/*
*----------------------------------------------------------------------
*
* FinalizeRegexp --
*
* Release the storage associated with the per-thread regexp cache.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
FinalizeRegexp(
TCL_UNUSED(ClientData))
{
int i;
TclRegexp *regexpPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
for (i = 0; (i < NUM_REGEXPS) && (tsdPtr->patterns[i] != NULL); i++) {
regexpPtr = tsdPtr->regexps[i];
if (regexpPtr->refCount-- <= 1) {
FreeRegexp(regexpPtr);
}
ckfree(tsdPtr->patterns[i]);
tsdPtr->patterns[i] = NULL;
}
/*
* We may find ourselves reinitialized if another finalization routine
* invokes regexps.
*/
|
| ︙ | ︙ |
Changes to generic/tclResolve.c.
| ︙ | ︙ | |||
97 98 99 100 101 102 103 |
}
/*
* Otherwise, this is a new scheme. Add it to the FRONT of the linked
* list, so that it overrides existing schemes.
*/
| | | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
}
/*
* Otherwise, this is a new scheme. Add it to the FRONT of the linked
* list, so that it overrides existing schemes.
*/
resPtr = (ResolverScheme *)ckalloc(sizeof(ResolverScheme));
len = strlen(name) + 1;
resPtr->name = (char *)ckalloc(len);
memcpy(resPtr->name, name, len);
resPtr->cmdResProc = cmdProc;
resPtr->varResProc = varProc;
resPtr->compiledVarResProc = compiledVarProc;
resPtr->nextPtr = iPtr->resolverPtr;
iPtr->resolverPtr = resPtr;
}
|
| ︙ | ︙ | |||
221 222 223 224 225 226 227 |
iPtr->compileEpoch++;
}
if (resPtr->cmdResProc) {
BumpCmdRefEpochs(iPtr->globalNsPtr);
}
*prevPtrPtr = resPtr->nextPtr;
| | | | 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 |
iPtr->compileEpoch++;
}
if (resPtr->cmdResProc) {
BumpCmdRefEpochs(iPtr->globalNsPtr);
}
*prevPtrPtr = resPtr->nextPtr;
ckfree(resPtr->name);
ckfree(resPtr);
return 1;
}
return 0;
}
/*
|
| ︙ | ︙ | |||
261 262 263 264 265 266 267 |
Tcl_HashSearch search;
nsPtr->cmdRefEpoch++;
#ifndef BREAK_NAMESPACE_COMPAT
for (entry = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
entry != NULL; entry = Tcl_NextHashEntry(&search)) {
| | | 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 |
Tcl_HashSearch search;
nsPtr->cmdRefEpoch++;
#ifndef BREAK_NAMESPACE_COMPAT
for (entry = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
entry != NULL; entry = Tcl_NextHashEntry(&search)) {
Namespace *childNsPtr = (Namespace *)Tcl_GetHashValue(entry);
BumpCmdRefEpochs(childNsPtr);
}
#else
if (nsPtr->childTablePtr != NULL) {
for (entry = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
entry != NULL; entry = Tcl_NextHashEntry(&search)) {
|
| ︙ | ︙ |
Changes to generic/tclResult.c.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 30 31 32 33 34 35 36 | /* * Function prototypes for local functions in this file: */ static Tcl_Obj ** GetKeys(void); static void ReleaseKeys(ClientData clientData); static void ResetObjResult(Interp *iPtr); /* * This structure is used to take a snapshot of the interpreter state in * Tcl_SaveInterpState. You can snapshot the state, execute a command, and * then back up to the result or the error that was previously in progress. */ | > > > | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | /* * Function prototypes for local functions in this file: */ static Tcl_Obj ** GetKeys(void); static void ReleaseKeys(ClientData clientData); static void ResetObjResult(Interp *iPtr); #ifndef TCL_NO_DEPRECATED static void SetupAppendBuffer(Interp *iPtr, int newSpace); #endif /* !TCL_NO_DEPRECATED */ /* * This structure is used to take a snapshot of the interpreter state in * Tcl_SaveInterpState. You can snapshot the state, execute a command, and * then back up to the result or the error that was previously in progress. */ |
| ︙ | ︙ | |||
70 71 72 73 74 75 76 |
Tcl_InterpState
Tcl_SaveInterpState(
Tcl_Interp *interp, /* Interpreter's state to be saved */
int status) /* status code for current operation */
{
Interp *iPtr = (Interp *) interp;
| | | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 |
Tcl_InterpState
Tcl_SaveInterpState(
Tcl_Interp *interp, /* Interpreter's state to be saved */
int status) /* status code for current operation */
{
Interp *iPtr = (Interp *) interp;
InterpState *statePtr = (InterpState *)ckalloc(sizeof(InterpState));
statePtr->status = status;
statePtr->flags = iPtr->flags & ERR_ALREADY_LOGGED;
statePtr->returnLevel = iPtr->returnLevel;
statePtr->returnCode = iPtr->returnCode;
statePtr->errorInfo = iPtr->errorInfo;
statePtr->errorStack = iPtr->errorStack;
|
| ︙ | ︙ | |||
200 201 202 203 204 205 206 |
if (statePtr->returnOpts) {
Tcl_DecrRefCount(statePtr->returnOpts);
}
if (statePtr->errorStack) {
Tcl_DecrRefCount(statePtr->errorStack);
}
Tcl_DecrRefCount(statePtr->objResult);
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 |
if (statePtr->returnOpts) {
Tcl_DecrRefCount(statePtr->returnOpts);
}
if (statePtr->errorStack) {
Tcl_DecrRefCount(statePtr->errorStack);
}
Tcl_DecrRefCount(statePtr->objResult);
ckfree(statePtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SaveResult --
*
* Takes a snapshot of the current result state of the interpreter. The
* snapshot can be restored at any point by Tcl_RestoreResult. Note that
* this routine does not preserve the errorCode, errorInfo, or flags
* fields so it should not be used if an error is in progress.
*
* Once a snapshot is saved, it must be restored by calling
* Tcl_RestoreResult, or discarded by calling Tcl_DiscardResult.
*
* Results:
* None.
*
* Side effects:
* Resets the interpreter result.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
#undef Tcl_SaveResult
void
Tcl_SaveResult(
Tcl_Interp *interp, /* Interpreter to save. */
Tcl_SavedResult *statePtr) /* Pointer to state structure. */
{
Interp *iPtr = (Interp *) interp;
/*
* 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;
iPtr->objResultPtr = Tcl_NewObj();
Tcl_IncrRefCount(iPtr->objResultPtr);
/*
* Save the string result.
*/
statePtr->freeProc = iPtr->freeProc;
if (iPtr->result == iPtr->resultSpace) {
/*
* Copy the static string data out of the interp buffer.
*/
statePtr->result = statePtr->resultSpace;
strcpy(statePtr->result, iPtr->result);
statePtr->appendResult = NULL;
} else if (iPtr->result == iPtr->appendResult) {
/*
* Move the append buffer out of the interp.
*/
statePtr->appendResult = iPtr->appendResult;
statePtr->appendAvl = iPtr->appendAvl;
statePtr->appendUsed = iPtr->appendUsed;
statePtr->result = statePtr->appendResult;
iPtr->appendResult = NULL;
iPtr->appendAvl = 0;
iPtr->appendUsed = 0;
} else {
/*
* Move the dynamic or static string out of the interpreter.
*/
statePtr->result = iPtr->result;
statePtr->appendResult = NULL;
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
iPtr->freeProc = 0;
}
/*
*----------------------------------------------------------------------
*
* Tcl_RestoreResult --
*
* Restores the state of the interpreter to a snapshot taken by
* Tcl_SaveResult. After this call, the token for the interpreter state
* is no longer valid.
*
* Results:
* None.
*
* Side effects:
* Restores the interpreter result.
*
*----------------------------------------------------------------------
*/
#undef Tcl_RestoreResult
void
Tcl_RestoreResult(
Tcl_Interp *interp, /* Interpreter being restored. */
Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */
{
Interp *iPtr = (Interp *) interp;
Tcl_ResetResult(interp);
/*
* Restore the string result.
*/
iPtr->freeProc = statePtr->freeProc;
if (statePtr->result == statePtr->resultSpace) {
/*
* Copy the static string data into the interp buffer.
*/
iPtr->result = iPtr->resultSpace;
strcpy(iPtr->result, statePtr->result);
} else if (statePtr->result == statePtr->appendResult) {
/*
* Move the append buffer back into the interp.
*/
if (iPtr->appendResult != NULL) {
ckfree(iPtr->appendResult);
}
iPtr->appendResult = statePtr->appendResult;
iPtr->appendAvl = statePtr->appendAvl;
iPtr->appendUsed = statePtr->appendUsed;
iPtr->result = iPtr->appendResult;
} else {
/*
* Move the dynamic or static string back into the interpreter.
*/
iPtr->result = statePtr->result;
}
/*
* Restore the object result.
*/
Tcl_DecrRefCount(iPtr->objResultPtr);
iPtr->objResultPtr = statePtr->objResultPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DiscardResult --
*
* Frees the memory associated with an interpreter snapshot taken by
* Tcl_SaveResult. If the snapshot is not restored, this function must be
* called to discard it, or the memory will be lost.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#undef Tcl_DiscardResult
void
Tcl_DiscardResult(
Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */
{
TclDecrRefCount(statePtr->objResultPtr);
if (statePtr->result == statePtr->appendResult) {
ckfree(statePtr->appendResult);
} else if (statePtr->freeProc == TCL_DYNAMIC) {
ckfree(statePtr->result);
} else if (statePtr->freeProc) {
statePtr->freeProc(statePtr->result);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetResult --
*
* Arrange for "result" to be the Tcl return value.
*
* Results:
* None.
*
* Side effects:
* interp->result is left pointing either to "result" or to a copy of it.
* Also, the object result is reset.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetResult(
Tcl_Interp *interp, /* Interpreter with which to associate the
* return value. */
char *result, /* Value to be returned. If NULL, the result
* is set to an empty string. */
Tcl_FreeProc *freeProc) /* Gives information about the string:
* TCL_STATIC, TCL_VOLATILE, or the address of
* a Tcl_FreeProc such as free. */
{
Interp *iPtr = (Interp *) interp;
Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
char *oldResult = iPtr->result;
if (result == NULL) {
iPtr->resultSpace[0] = 0;
iPtr->result = iPtr->resultSpace;
iPtr->freeProc = 0;
} else if (freeProc == TCL_VOLATILE) {
int length = strlen(result);
if (length > TCL_RESULT_SIZE) {
iPtr->result = (char *)ckalloc(length + 1);
iPtr->freeProc = TCL_DYNAMIC;
} else {
iPtr->result = iPtr->resultSpace;
iPtr->freeProc = 0;
}
memcpy(iPtr->result, result, length+1);
} else {
iPtr->result = (char *) result;
iPtr->freeProc = freeProc;
}
/*
* If the old result was dynamically-allocated, free it up. Do it here,
* rather than at the beginning, in case the new result value was part of
* the old result value.
*/
if (oldFreeProc != 0) {
if (oldFreeProc == TCL_DYNAMIC) {
ckfree(oldResult);
} else {
oldFreeProc(oldResult);
}
}
/*
* Reset the object result since we just set the string result.
*/
ResetObjResult(iPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetStringResult --
*
* Returns an interpreter's result value as a string.
*
* Results:
* The interpreter's result as a string.
*
* Side effects:
* If the string result is empty, the object result is moved to the
* string result, then the object result is reset.
*
*----------------------------------------------------------------------
*/
const char *
Tcl_GetStringResult(
Tcl_Interp *interp)/* Interpreter whose result to return. */
{
Interp *iPtr = (Interp *) interp;
/*
* If the string result is empty, move the object result to the string
* result, then reset the object result.
*/
if (*(iPtr->result) == 0) {
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
return iPtr->result;
}
#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_SetObjResult --
*
* Arrange for objPtr to be an interpreter's result value.
|
| ︙ | ︙ | |||
226 227 228 229 230 231 232 |
*----------------------------------------------------------------------
*/
void
Tcl_SetObjResult(
Tcl_Interp *interp, /* Interpreter with which to associate the
* return object value. */
| | | | > > > > > > > > > > > > > > > > > | 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 |
*----------------------------------------------------------------------
*/
void
Tcl_SetObjResult(
Tcl_Interp *interp, /* Interpreter with which to associate the
* return object value. */
Tcl_Obj *objPtr) /* Tcl object to be returned. If NULL, the obj
* result is made an empty string object. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *oldObjResult = iPtr->objResultPtr;
iPtr->objResultPtr = objPtr;
Tcl_IncrRefCount(objPtr); /* since interp result is a reference */
/*
* We wait until the end to release the old object result, in case we are
* setting the result to itself.
*/
TclDecrRefCount(oldObjResult);
#ifndef TCL_NO_DEPRECATED
/*
* Reset the string result since we just set the result object.
*/
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
iPtr->freeProc(iPtr->result);
}
iPtr->freeProc = 0;
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
#endif
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetObjResult --
*
|
| ︙ | ︙ | |||
268 269 270 271 272 273 274 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_GetObjResult(
Tcl_Interp *interp) /* Interpreter whose result to return. */
{
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_GetObjResult(
Tcl_Interp *interp) /* Interpreter whose result to return. */
{
Interp *iPtr = (Interp *) interp;
#ifndef TCL_NO_DEPRECATED
Tcl_Obj *objResultPtr;
int length;
/*
* If the string result is non-empty, move the string result to the object
* result, then reset the string result.
*/
if (iPtr->result[0] != 0) {
ResetObjResult(iPtr);
objResultPtr = iPtr->objResultPtr;
length = strlen(iPtr->result);
TclInitStringRep(objResultPtr, iPtr->result, length);
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
iPtr->freeProc(iPtr->result);
}
iPtr->freeProc = 0;
}
iPtr->result = iPtr->resultSpace;
iPtr->result[0] = 0;
}
#endif /* !TCL_NO_DEPRECATED */
return iPtr->objResultPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendResultVA --
*
* Append a variable number of strings onto the interpreter's result.
*
* Results:
* None.
*
* Side effects:
* The result of the interpreter given by the first argument is extended
* by the strings in the va_list (up to a terminating NULL argument).
*
* If the string result is non-empty, the object result forced to be a
* duplicate of it first. There will be a string result afterwards.
*
*----------------------------------------------------------------------
*/
void
Tcl_AppendResultVA(
Tcl_Interp *interp, /* Interpreter with which to associate the
* return value. */
va_list argList) /* Variable argument list. */
{
Tcl_Obj *objPtr = Tcl_GetObjResult(interp);
if (Tcl_IsShared(objPtr)) {
objPtr = Tcl_DuplicateObj(objPtr);
}
Tcl_AppendStringsToObjVA(objPtr, argList);
Tcl_SetObjResult(interp, objPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendResult --
*
* Append a variable number of strings onto the interpreter's result.
|
| ︙ | ︙ | |||
299 300 301 302 303 304 305 |
*/
void
Tcl_AppendResult(
Tcl_Interp *interp, ...)
{
va_list argList;
| < < | < < < < < < < < < < < < | 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 |
*/
void
Tcl_AppendResult(
Tcl_Interp *interp, ...)
{
va_list argList;
va_start(argList, interp);
Tcl_AppendResultVA(interp, argList);
va_end(argList);
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendElement --
|
| ︙ | ︙ | |||
350 351 352 353 354 355 356 357 358 359 |
Tcl_AppendElement(
Tcl_Interp *interp, /* Interpreter whose result is to be
* extended. */
const char *element) /* String to convert to list element and add
* to result. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *elementPtr = Tcl_NewStringObj(element, -1);
Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr);
const char *bytes;
| > < | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | > | | | > > > > > > > > > > | | 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 |
Tcl_AppendElement(
Tcl_Interp *interp, /* Interpreter whose result is to be
* extended. */
const char *element) /* String to convert to list element and add
* to result. */
{
Interp *iPtr = (Interp *) interp;
#ifdef TCL_NO_DEPRECATED
Tcl_Obj *elementPtr = Tcl_NewStringObj(element, -1);
Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr);
const char *bytes;
if (Tcl_IsShared(iPtr->objResultPtr)) {
Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr));
}
bytes = TclGetString(iPtr->objResultPtr);
if (TclNeedSpace(bytes, bytes+iPtr->objResultPtr->length)) {
Tcl_AppendToObj(iPtr->objResultPtr, " ", 1);
}
Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr);
Tcl_DecrRefCount(listPtr);
#else
char *dst;
int size;
int flags;
int quoteHash = 1;
/*
* If the string result is empty, move the object result to the string
* result, then reset the object result.
*/
(void) Tcl_GetStringResult(interp);
/*
* See how much space is needed, and grow the append buffer if needed to
* accommodate the list element.
*/
size = Tcl_ScanElement(element, &flags) + 1;
if ((iPtr->result != iPtr->appendResult)
|| (iPtr->appendResult[iPtr->appendUsed] != 0)
|| ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
}
/*
* Convert the string into a list element and copy it to the buffer that's
* forming, with a space separator if needed.
*/
dst = iPtr->appendResult + iPtr->appendUsed;
if (TclNeedSpace(iPtr->appendResult, dst)) {
iPtr->appendUsed++;
*dst = ' ';
dst++;
/*
* If we need a space to separate this element from preceding stuff,
* then this element will not lead a list, and need not have it's
* leading '#' quoted.
*/
quoteHash = 0;
} else {
while ((--dst >= iPtr->appendResult) && TclIsSpaceProcM(*dst)) {
}
quoteHash = !TclNeedSpace(iPtr->appendResult, dst+1);
}
dst = iPtr->appendResult + iPtr->appendUsed;
if (!quoteHash) {
flags |= TCL_DONT_QUOTE_HASH;
}
iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags);
#endif /* !TCL_NO_DEPRECATED */
}
/*
*----------------------------------------------------------------------
*
* SetupAppendBuffer --
*
* This function makes sure that there is an append buffer properly
* initialized, if necessary, from the interpreter's result, and that it
* has at least enough room to accommodate newSpace new bytes of
* information.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
static void
SetupAppendBuffer(
Interp *iPtr, /* Interpreter whose result is being set up. */
int newSpace) /* Make sure that at least this many bytes of
* new information may be added. */
{
int totalSpace;
/*
* Make the append buffer larger, if that's necessary, then copy the
* result into the append buffer and make the append buffer the official
* Tcl result.
*/
if (iPtr->result != iPtr->appendResult) {
/*
* If an oversized buffer was used recently, then free it up so we go
* back to a smaller buffer. This avoids tying up memory forever after
* a large operation.
*/
if (iPtr->appendAvl > 500) {
ckfree(iPtr->appendResult);
iPtr->appendResult = NULL;
iPtr->appendAvl = 0;
}
iPtr->appendUsed = strlen(iPtr->result);
} else if (iPtr->result[iPtr->appendUsed] != 0) {
/*
* Most likely someone has modified a result created by
* Tcl_AppendResult et al. so that it has a different size. Just
* recompute the size.
*/
iPtr->appendUsed = strlen(iPtr->result);
}
totalSpace = newSpace + iPtr->appendUsed;
if (totalSpace >= iPtr->appendAvl) {
char *newSpace;
if (totalSpace < 100) {
totalSpace = 200;
} else {
totalSpace *= 2;
}
newSpace = (char *)ckalloc(totalSpace);
strcpy(newSpace, iPtr->result);
if (iPtr->appendResult != NULL) {
ckfree(iPtr->appendResult);
}
iPtr->appendResult = newSpace;
iPtr->appendAvl = totalSpace;
} else if (iPtr->result != iPtr->appendResult) {
strcpy(iPtr->appendResult, iPtr->result);
}
Tcl_FreeResult((Tcl_Interp *) iPtr);
iPtr->result = iPtr->appendResult;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FreeResult --
*
* This function frees up the memory associated with an interpreter's
* string result. It also resets the interpreter's result object.
* Tcl_FreeResult is most commonly used when a function is about to
* replace one result value with another.
*
* Results:
* None.
*
* Side effects:
* Frees the memory associated with interp's string result and sets
* interp->freeProc to zero, but does not change interp->result or clear
* error state. Resets interp's result object to an unshared empty
* object.
*
*----------------------------------------------------------------------
*/
void
Tcl_FreeResult(
Tcl_Interp *interp)/* Interpreter for which to free result. */
{
Interp *iPtr = (Interp *) interp;
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
iPtr->freeProc(iPtr->result);
}
iPtr->freeProc = 0;
}
ResetObjResult(iPtr);
}
#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_ResetResult --
*
* This function resets both the interpreter's string and object results.
*
|
| ︙ | ︙ | |||
417 418 419 420 421 422 423 | * It also clears any error information for the interpreter. * *---------------------------------------------------------------------- */ void Tcl_ResetResult( | | | > > > > > > > > > > > > | 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 |
* It also clears any error information for the interpreter.
*
*----------------------------------------------------------------------
*/
void
Tcl_ResetResult(
Tcl_Interp *interp)/* Interpreter for which to clear result. */
{
Interp *iPtr = (Interp *) interp;
ResetObjResult(iPtr);
#ifndef TCL_NO_DEPRECATED
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
} else {
iPtr->freeProc(iPtr->result);
}
iPtr->freeProc = 0;
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
#endif /* !TCL_NO_DEPRECATED */
if (iPtr->errorCode) {
/* Legacy support */
if (iPtr->flags & ERR_LEGACY_COPY) {
Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL,
iPtr->errorCode, TCL_GLOBAL_ONLY);
}
Tcl_DecrRefCount(iPtr->errorCode);
|
| ︙ | ︙ | |||
470 471 472 473 474 475 476 | * the interpreter. * *---------------------------------------------------------------------- */ static void ResetObjResult( | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
* the interpreter.
*
*----------------------------------------------------------------------
*/
static void
ResetObjResult(
Interp *iPtr) /* Points to the interpreter whose result
* object should be reset. */
{
Tcl_Obj *objResultPtr = iPtr->objResultPtr;
if (Tcl_IsShared(objResultPtr)) {
TclDecrRefCount(objResultPtr);
TclNewObj(objResultPtr);
Tcl_IncrRefCount(objResultPtr);
iPtr->objResultPtr = objResultPtr;
} else {
if (objResultPtr->bytes != &tclEmptyString) {
if (objResultPtr->bytes) {
ckfree(objResultPtr->bytes);
}
objResultPtr->bytes = &tclEmptyString;
objResultPtr->length = 0;
}
TclFreeIntRep(objResultPtr);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetErrorCodeVA --
*
* This function is called to record machine-readable information about
* an error that is about to be returned.
*
* Results:
* None.
*
* Side effects:
* The errorCode field of the interp is modified to hold all of the
* arguments to this function, in a list form with each argument becoming
* one element of the list.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetErrorCodeVA(
Tcl_Interp *interp, /* Interpreter in which to set errorCode */
va_list argList) /* Variable argument list. */
{
Tcl_Obj *errorObj = Tcl_NewObj();
/*
* Scan through the arguments one at a time, appending them to the
* errorCode field as list elements.
*/
while (1) {
char *elem = va_arg(argList, char *);
if (elem == NULL) {
break;
}
Tcl_ListObjAppendElement(NULL, errorObj, Tcl_NewStringObj(elem, -1));
}
Tcl_SetObjErrorCode(interp, errorObj);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetErrorCode --
*
* This function is called to record machine-readable information about
|
| ︙ | ︙ | |||
516 517 518 519 520 521 522 |
*/
void
Tcl_SetErrorCode(
Tcl_Interp *interp, ...)
{
va_list argList;
| < < | < < < < < < < < < < < < < < | 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 |
*/
void
Tcl_SetErrorCode(
Tcl_Interp *interp, ...)
{
va_list argList;
/*
* Scan through the arguments one at a time, appending them to the
* errorCode field as list elements.
*/
va_start(argList, interp);
Tcl_SetErrorCodeVA(interp, argList);
va_end(argList);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetObjErrorCode --
|
| ︙ | ︙ | |||
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 |
* Tcl_GetErrorLine --
*
* Returns the line number associated with the current error.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetErrorLine(
Tcl_Interp *interp)
{
return ((Interp *) interp)->errorLine;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetErrorLine --
*
* Sets the line number associated with the current error.
*
*----------------------------------------------------------------------
*/
void
Tcl_SetErrorLine(
Tcl_Interp *interp,
int value)
{
((Interp *) interp)->errorLine = value;
}
| > > | 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 |
* Tcl_GetErrorLine --
*
* Returns the line number associated with the current error.
*
*----------------------------------------------------------------------
*/
#undef Tcl_GetErrorLine
int
Tcl_GetErrorLine(
Tcl_Interp *interp)
{
return ((Interp *) interp)->errorLine;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetErrorLine --
*
* Sets the line number associated with the current error.
*
*----------------------------------------------------------------------
*/
#undef Tcl_SetErrorLine
void
Tcl_SetErrorLine(
Tcl_Interp *interp,
int value)
{
((Interp *) interp)->errorLine = value;
}
|
| ︙ | ︙ | |||
635 636 637 638 639 640 641 |
*----------------------------------------------------------------------
*/
static Tcl_Obj **
GetKeys(void)
{
static Tcl_ThreadDataKey returnKeysKey;
| | | | 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 |
*----------------------------------------------------------------------
*/
static Tcl_Obj **
GetKeys(void)
{
static Tcl_ThreadDataKey returnKeysKey;
Tcl_Obj **keys = (Tcl_Obj **)Tcl_GetThreadData(&returnKeysKey,
KEY_LAST * sizeof(Tcl_Obj *));
if (keys[0] == NULL) {
/*
* First call in this thread, create the keys...
*/
int i;
|
| ︙ | ︙ | |||
687 688 689 690 691 692 693 |
*----------------------------------------------------------------------
*/
static void
ReleaseKeys(
ClientData clientData)
{
| | | 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 |
*----------------------------------------------------------------------
*/
static void
ReleaseKeys(
ClientData clientData)
{
Tcl_Obj **keys = (Tcl_Obj **)clientData;
int i;
for (i = KEY_CODE; i < KEY_LAST; i++) {
Tcl_DecrRefCount(keys[i]);
keys[i] = NULL;
}
}
|
| ︙ | ︙ | |||
747 748 749 750 751 752 753 |
if (iPtr->errorInfo) {
Tcl_DecrRefCount(iPtr->errorInfo);
iPtr->errorInfo = NULL;
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO],
&valuePtr);
if (valuePtr != NULL) {
| < < | | | 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 |
if (iPtr->errorInfo) {
Tcl_DecrRefCount(iPtr->errorInfo);
iPtr->errorInfo = NULL;
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO],
&valuePtr);
if (valuePtr != NULL) {
(void) TclGetString(valuePtr);
if (valuePtr->length) {
iPtr->errorInfo = valuePtr;
Tcl_IncrRefCount(iPtr->errorInfo);
iPtr->flags |= ERR_ALREADY_LOGGED;
}
}
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK],
&valuePtr);
|
| ︙ | ︙ | |||
1151 1152 1153 1154 1155 1156 1157 | } /* *------------------------------------------------------------------------- * * Tcl_TransferResult -- * | | < < < < < < < | < > | < | | | > > | | | | | 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 |
}
/*
*-------------------------------------------------------------------------
*
* Tcl_TransferResult --
*
* Transfer the result (and error information) from one interp to another.
* Used when one interp has caused another interp to evaluate a script
* and then wants to transfer the results back to itself.
*
* Results:
* The result of targetInterp is set to the result read from sourceInterp.
* The return options dictionary of sourceInterp is transferred to
* targetInterp as appropriate for the return code value code.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
void
Tcl_TransferResult(
Tcl_Interp *sourceInterp, /* Interp whose result and return options
* should be moved to the target interp.
* After moving result, this interp's result
* is reset. */
int code, /* The return code value active in
* sourceInterp. Controls how the return options
* dictionary is retrieved from sourceInterp,
* same as in Tcl_GetReturnOptions, to then be
* transferred to targetInterp. */
Tcl_Interp *targetInterp) /* Interp where result and return options
* should be stored. If source and target are
* the same, nothing is done. */
{
Interp *tiPtr = (Interp *) targetInterp;
Interp *siPtr = (Interp *) sourceInterp;
if (sourceInterp == targetInterp) {
return;
}
if (code == TCL_OK && siPtr->returnOpts == NULL) {
/*
* Special optimization for the common case of normal command return
* code and no explicit return options.
*/
if (tiPtr->returnOpts) {
Tcl_DecrRefCount(tiPtr->returnOpts);
tiPtr->returnOpts = NULL;
}
} else {
Tcl_SetReturnOptions(targetInterp,
Tcl_GetReturnOptions(sourceInterp, code));
tiPtr->flags &= ~(ERR_ALREADY_LOGGED);
}
Tcl_SetObjResult(targetInterp, Tcl_GetObjResult(sourceInterp));
Tcl_ResetResult(sourceInterp);
}
/*
|
| ︙ | ︙ |
Changes to generic/tclScan.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclScan.c -- * * This file contains the implementation of the "scan" command. * * Copyright (c) 1998 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" | | > > > > > < < < | | 1 2 3 4 5 6 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 |
/*
* tclScan.c --
*
* This file contains the implementation of the "scan" command.
*
* Copyright (c) 1998 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tclTomMath.h"
/*
* Flag values used by Tcl_ScanObjCmd.
*/
#define SCAN_NOSKIP 0x1 /* Don't skip blanks. */
#define SCAN_SUPPRESS 0x2 /* Suppress assignment. */
#define SCAN_UNSIGNED 0x4 /* Read an unsigned value. */
#define SCAN_WIDTH 0x8 /* A width value was supplied. */
#define SCAN_LONGER 0x400 /* Asked for a wide value. */
#define SCAN_BIG 0x800 /* Asked for a bignum value. */
/*
* The following structure contains the information associated with a
* character set.
*/
typedef struct {
Tcl_UniChar start;
Tcl_UniChar end;
} Range;
typedef struct CharSet {
int exclude; /* 1 if this is an exclusion set. */
int nchars;
Tcl_UniChar *chars;
int nranges;
Range *ranges;
} CharSet;
/*
* Declarations for functions used only in this file.
*/
static const char * BuildCharSet(CharSet *cset, const char *format);
|
| ︙ | ︙ | |||
98 99 100 101 102 103 104 |
while (ch != ']') {
if (ch == '-') {
nranges++;
}
end += TclUtfToUniChar(end, &ch);
}
| | | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 |
while (ch != ']') {
if (ch == '-') {
nranges++;
}
end += TclUtfToUniChar(end, &ch);
}
cset->chars = (Tcl_UniChar *)ckalloc(sizeof(Tcl_UniChar) * (end - format - 1));
if (nranges > 0) {
cset->ranges = (Range *)ckalloc(sizeof(Range) * nranges);
} else {
cset->ranges = NULL;
}
/*
* Now build the character set.
*/
|
| ︙ | ︙ | |||
220 221 222 223 224 225 226 |
*----------------------------------------------------------------------
*/
static void
ReleaseCharSet(
CharSet *cset)
{
| | | | 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 |
*----------------------------------------------------------------------
*/
static void
ReleaseCharSet(
CharSet *cset)
{
ckfree(cset->chars);
if (cset->ranges) {
ckfree(cset->ranges);
}
}
/*
*----------------------------------------------------------------------
*
* ValidateFormat --
|
| ︙ | ︙ | |||
256 257 258 259 260 261 262 |
int *totalSubs) /* The number of variables that will be
* required. */
{
int gotXpg, gotSequential, value, i, flags;
char *end;
Tcl_UniChar ch = 0;
int objIndex, xpgSize, nspace = numVars;
| | < > | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 |
int *totalSubs) /* The number of variables that will be
* required. */
{
int gotXpg, gotSequential, value, i, flags;
char *end;
Tcl_UniChar ch = 0;
int objIndex, xpgSize, nspace = numVars;
int *nassign = (int *)TclStackAlloc(interp, nspace * sizeof(int));
Tcl_Obj *errorMsg; /* Place to build an error messages. Note that
* these are messy operations because we do
* not want to use the formatting engine;
* we're inside there! */
char buf[5] = "";
/*
* Initialize an array that records the number of times a variable is
* assigned to by the format string. We use this to detect if a variable
* is multiply assigned or left unassigned.
*/
|
| ︙ | ︙ | |||
359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 |
case 'l':
if (*format == 'l') {
flags |= SCAN_BIG;
format += 1;
format += TclUtfToUniChar(format, &ch);
break;
}
case 'L':
flags |= SCAN_LONGER;
case 'h':
format += TclUtfToUniChar(format, &ch);
}
if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) {
goto badIndex;
}
| > > | 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 |
case 'l':
if (*format == 'l') {
flags |= SCAN_BIG;
format += 1;
format += TclUtfToUniChar(format, &ch);
break;
}
/* FALLTHRU */
case 'L':
flags |= SCAN_LONGER;
/* FALLTHRU */
case 'h':
format += TclUtfToUniChar(format, &ch);
}
if (!(flags & SCAN_SUPPRESS) && numVars && (objIndex >= numVars)) {
goto badIndex;
}
|
| ︙ | ︙ | |||
382 383 384 385 386 387 388 |
if (flags & SCAN_WIDTH) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"field width may not be specified in %c conversion",
-1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", NULL);
goto error;
}
| | < < | 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 |
if (flags & SCAN_WIDTH) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"field width may not be specified in %c conversion",
-1));
Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", NULL);
goto error;
}
/* FALLTHRU */
case 'n':
case 's':
if (flags & (SCAN_LONGER|SCAN_BIG)) {
invalidFieldSize:
buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
errorMsg = Tcl_NewStringObj(
"field size modifier may not be specified in %", -1);
|
| ︙ | ︙ | |||
473 474 475 476 477 478 479 |
value = nspace;
if (xpgSize) {
nspace = xpgSize;
} else {
nspace += 16; /* formerly STATIC_LIST_SIZE */
}
| | | 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 |
value = nspace;
if (xpgSize) {
nspace = xpgSize;
} else {
nspace += 16; /* formerly STATIC_LIST_SIZE */
}
nassign = (int *)TclStackRealloc(interp, nassign,
nspace * sizeof(int));
for (i = value; i < nspace; i++) {
nassign[i] = 0;
}
}
nassign[objIndex]++;
objIndex++;
|
| ︙ | ︙ | |||
556 557 558 559 560 561 562 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | < < < | | | | 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 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 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_ScanObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *format;
int numVars, nconversions, totalVars = -1;
int objIndex, offset, i, result, code;
long value;
const char *string, *end, *baseString;
char op = 0;
int width, underflow = 0;
Tcl_WideInt wideValue;
Tcl_UniChar ch = 0, sch = 0;
Tcl_Obj **objs = NULL, *objPtr = NULL;
int flags;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
"string format ?varName ...?");
return TCL_ERROR;
}
format = Tcl_GetString(objv[2]);
numVars = objc-3;
/*
* Check for errors in the format string.
*/
if (ValidateFormat(interp, format, numVars, &totalVars) == TCL_ERROR) {
return TCL_ERROR;
}
/*
* Allocate space for the result objects.
*/
if (totalVars > 0) {
objs = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * totalVars);
for (i = 0; i < totalVars; i++) {
objs[i] = NULL;
}
}
string = Tcl_GetString(objv[1]);
baseString = string;
/*
* Iterate over the format string filling in the result objects until we
* reach the end of input, the end of the format string, or there is a
* mismatch.
*/
|
| ︙ | ︙ | |||
699 700 701 702 703 704 705 706 707 |
case 'l':
if (*format == 'l') {
flags |= SCAN_BIG;
format += 1;
format += TclUtfToUniChar(format, &ch);
break;
}
case 'L':
flags |= SCAN_LONGER;
| > | < < | 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 |
case 'l':
if (*format == 'l') {
flags |= SCAN_BIG;
format += 1;
format += TclUtfToUniChar(format, &ch);
break;
}
/* FALLTHRU */
case 'L':
flags |= SCAN_LONGER;
/* FALLTHRU */
case 'h':
format += TclUtfToUniChar(format, &ch);
}
/*
* Handle the various field types.
*/
|
| ︙ | ︙ | |||
875 876 877 878 879 880 881 | break; } case 'c': /* * Scan a single Unicode character. */ | | < < < < < < < | | 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 |
break;
}
case 'c':
/*
* Scan a single Unicode character.
*/
offset = TclUtfToUCS4(string, &i);
string += offset;
if (!(flags & SCAN_SUPPRESS)) {
objPtr = Tcl_NewWideIntObj(i);
Tcl_IncrRefCount(objPtr);
CLANG_ASSERT(objs);
objs[objIndex++] = objPtr;
}
break;
case 'i':
/*
* Scan an unsigned or signed integer.
*/
objPtr = Tcl_NewWideIntObj(0);
Tcl_IncrRefCount(objPtr);
if (width == 0) {
width = ~0;
}
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
&end, TCL_PARSE_INTEGER_ONLY | TCL_PARSE_NO_UNDERSCORE | parseFlag)) {
Tcl_DecrRefCount(objPtr);
if (width < 0) {
if (*end == '\0') {
underflow = 1;
}
} else {
if (end == string + width) {
|
| ︙ | ︙ | |||
928 929 930 931 932 933 934 |
if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) {
wideValue = WIDE_MAX;
if (TclGetString(objPtr)[0] == '-') {
wideValue = WIDE_MIN;
}
}
if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
| > | > > > > > | > | | > > | > > > > > | > > > > | | 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 |
if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) {
wideValue = WIDE_MAX;
if (TclGetString(objPtr)[0] == '-') {
wideValue = WIDE_MIN;
}
}
if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
mp_int big;
if (mp_init_u64(&big, (Tcl_WideUInt)wideValue) != MP_OKAY) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"insufficient memory to create bignum", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
} else {
Tcl_SetBignumObj(objPtr, &big);
}
} else {
TclSetIntObj(objPtr, wideValue);
}
} else if (flags & SCAN_BIG) {
if (flags & SCAN_UNSIGNED) {
mp_int big;
int code = Tcl_GetBignumFromObj(interp, objPtr, &big);
if (code == TCL_OK) {
if (mp_isneg(&big)) {
code = TCL_ERROR;
}
mp_clear(&big);
}
if (code == 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",
"BADUNSIGNED",NULL);
return TCL_ERROR;
}
}
} else {
if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
if (TclGetString(objPtr)[0] == '-') {
value = LONG_MIN;
} else {
value = LONG_MAX;
}
}
if ((flags & SCAN_UNSIGNED) && (value < 0)) {
#ifdef TCL_WIDE_INT_IS_LONG
mp_int big;
if (mp_init_u64(&big, (unsigned long)value) != MP_OKAY) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"insufficient memory to create bignum", -1));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
return TCL_ERROR;
} else {
Tcl_SetBignumObj(objPtr, &big);
}
#else
Tcl_SetWideIntObj(objPtr, (unsigned long)value);
#endif
} else {
TclSetIntObj(objPtr, value);
}
}
objs[objIndex++] = objPtr;
break;
case 'f':
/*
* Scan a floating point number
*/
objPtr = Tcl_NewDoubleObj(0.0);
Tcl_IncrRefCount(objPtr);
if (width == 0) {
width = ~0;
}
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width,
&end, TCL_PARSE_DECIMAL_ONLY | TCL_PARSE_NO_WHITESPACE | TCL_PARSE_NO_UNDERSCORE)) {
Tcl_DecrRefCount(objPtr);
if (width < 0) {
if (*end == '\0') {
underflow = 1;
}
} else {
if (end == string + width) {
|
| ︙ | ︙ | |||
1072 1073 1074 1075 1076 1077 1078 |
*/
Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewObj());
}
}
}
if (objs != NULL) {
| | | 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 |
*/
Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewObj());
}
}
}
if (objs != NULL) {
ckfree(objs);
}
if (code == TCL_OK) {
if (underflow && (nconversions == 0)) {
if (numVars) {
objPtr = Tcl_NewWideIntObj(-1);
} else {
if (objPtr) {
|
| ︙ | ︙ |
Changes to generic/tclStrToD.c.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | * Copyright (c) 2005 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. */ #include "tclInt.h" | | > > > > > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | * Copyright (c) 2005 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. */ #include "tclInt.h" #include "tclTomMath.h" #include <float.h> #include <math.h> #ifdef _WIN32 #define copysign _copysign #endif /* * This code supports (at least hypothetically), IBM, Cray, VAX and IEEE-754 * floating point; of these, only IEEE-754 can represent NaN. IEEE-754 can be * uniquely determined by radix and by the widths of significand and exponent. */ |
| ︙ | ︙ | |||
41 42 43 44 45 46 47 |
*/
#if defined(__GNUC__)
typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__)));
#define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw))
#define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw))
| | | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
*/
#if defined(__GNUC__)
typedef unsigned int fpu_control_t __attribute__ ((__mode__ (__HI__)));
#define _FPU_GETCW(cw) __asm__ __volatile__ ("fnstcw %0" : "=m" (*&cw))
#define _FPU_SETCW(cw) __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw))
# define FPU_IEEE_ROUNDING 0x027F
# define ADJUST_FPU_CONTROL_WORD
#define TCL_IEEE_DOUBLE_ROUNDING \
fpu_control_t roundTo53Bits = FPU_IEEE_ROUNDING; \
fpu_control_t oldRoundingMode; \
_FPU_GETCW(oldRoundingMode); \
_FPU_SETCW(roundTo53Bits)
#define TCL_DEFAULT_DOUBLE_ROUNDING \
|
| ︙ | ︙ | |||
90 91 92 93 94 95 96 | /* * HP's PA_RISC architecture uses 7ff4000000000000 to represent a quiet NaN. * Everyone else uses 7ff8000000000000. (Why, HP, why?) */ #ifdef __hppa | | | | 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 | /* * HP's PA_RISC architecture uses 7ff4000000000000 to represent a quiet NaN. * Everyone else uses 7ff8000000000000. (Why, HP, why?) */ #ifdef __hppa # define NAN_START 0x7FF4 # define NAN_MASK (((Tcl_WideUInt) 1) << 50) #else # define NAN_START 0x7FF8 # define NAN_MASK (((Tcl_WideUInt) 1) << 51) #endif /* * Constants used by this file (most of which are only ever calculated at * runtime). */ |
| ︙ | ︙ | |||
115 116 117 118 119 120 121 | /* * Definitions of the parts of an IEEE754-format floating point number. */ #define SIGN_BIT 0x80000000 /* Mask for the sign bit in the first word of * a double. */ | | | | | | | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 |
/*
* Definitions of the parts of an IEEE754-format floating point number.
*/
#define SIGN_BIT 0x80000000
/* Mask for the sign bit in the first word of
* a double. */
#define EXP_MASK 0x7FF00000
/* Mask for the exponent field in the first
* word of a double. */
#define EXP_SHIFT 20 /* Shift count to make the exponent an
* integer. */
#define HIDDEN_BIT (((Tcl_WideUInt) 0x00100000) << 32)
/* Hidden 1 bit for the significand. */
#define HI_ORDER_SIG_MASK 0x000FFFFF
/* Mask for the high-order part of the
* significand in the first word of a
* double. */
#define SIG_MASK (((Tcl_WideUInt) HI_ORDER_SIG_MASK << 32) \
| 0xFFFFFFFF)
/* Mask for the 52-bit significand. */
#define FP_PRECISION 53 /* Number of bits of significand plus the
* hidden bit. */
#define EXPONENT_BIAS 0x3FF /* Bias of the exponent 0. */
/*
* Derived quantities.
*/
#define TEN_PMAX 22 /* floor(FP_PRECISION*log(2)/log(5)) */
#define QUICK_MAX 14 /* floor((FP_PRECISION-1)*log(2)/log(10))-1 */
#define BLETCH 0x10 /* Highest power of two that is greater than
* DBL_MAX_10_EXP, divided by 16. */
#define DIGIT_GROUP 8 /* floor(MP_DIGIT_BIT*log(2)/log(10)) */
/*
* Union used to dismantle floating point numbers.
*/
typedef union Double {
struct {
|
| ︙ | ︙ | |||
285 286 287 288 289 290 291 | /* * Static functions defined in this file. */ static int AccumulateDecimalDigit(unsigned, int, Tcl_WideUInt *, mp_int *, int); static double MakeHighPrecisionDouble(int signum, | | | | | 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 | /* * Static functions defined in this file. */ static int AccumulateDecimalDigit(unsigned, int, Tcl_WideUInt *, mp_int *, int); static double MakeHighPrecisionDouble(int signum, mp_int *significand, int nSigDigs, long exponent); static double MakeLowPrecisionDouble(int signum, Tcl_WideUInt significand, int nSigDigs, long exponent); #ifdef IEEE_FLOATING_POINT static double MakeNaN(int signum, Tcl_WideUInt tag); #endif static double RefineApproximation(double approx, mp_int *exactSignificand, int exponent); static mp_err MulPow5(mp_int *, unsigned, mp_int *) MP_WUR; static int NormalizeRightward(Tcl_WideUInt *); static int RequiredPrecision(Tcl_WideUInt); static void DoubleToExpAndSig(double, Tcl_WideUInt *, int *, int *); static void TakeAbsoluteValue(Double *, int *); static char * FormatInfAndNaN(Double *, int *, char **); static char * FormatZero(int *, char **); |
| ︙ | ︙ | |||
319 320 321 322 323 324 325 | char *, int *); static char * QuickConversion(double, int, int, int, int, int, int, int *, char **); static void CastOutPowersOf2(int *, int *, int *); static char * ShorteningInt64Conversion(Double *, Tcl_WideUInt, int, int, int, int, int, int, int, int, int, int, int, int *, char **); | | | | | 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 | char *, int *); static char * QuickConversion(double, int, int, int, int, int, int, int *, char **); static void CastOutPowersOf2(int *, int *, int *); static char * ShorteningInt64Conversion(Double *, Tcl_WideUInt, int, int, int, int, int, int, int, int, int, int, int, int *, char **); static char * StrictInt64Conversion(Tcl_WideUInt, int, int, int, int, int, int, int, int, int *, char **); static int ShouldBankerRoundUpPowD(mp_int *, int, int); static int ShouldBankerRoundUpToNextPowD(mp_int *, mp_int *, int, int, mp_int *); static char * ShorteningBignumConversionPowD(Double *dPtr, Tcl_WideUInt bw, int b2, int b5, int m2plus, int m2minus, int m5, int sd, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); static char * StrictBignumConversionPowD( Tcl_WideUInt bw, int b2, int b5, int sd, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); static int ShouldBankerRoundUp(mp_int *, mp_int *, int); static int ShouldBankerRoundUpToNext(mp_int *, mp_int *, mp_int *, int); static char * ShorteningBignumConversion(Double *dPtr, Tcl_WideUInt bw, int b2, int m2plus, int m2minus, int s2, int s5, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); static char * StrictBignumConversion( Tcl_WideUInt bw, int b2, int s2, int s5, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); static double BignumToBiasedFrExp(const mp_int *big, int *machexp); static double Pow10TimesFrExp(int exponent, double fraction, int *machexp); |
| ︙ | ︙ | |||
470 471 472 473 474 475 476 |
Tcl_Interp *interp, /* Used for error reporting. May be NULL. */
Tcl_Obj *objPtr, /* Object to receive the internal rep. */
const char *expected, /* Description of the type of number the
* caller expects to be able to parse
* ("integer", "boolean value", etc.). */
const char *bytes, /* Pointer to the start of the string to
* scan. */
| | | | 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 |
Tcl_Interp *interp, /* Used for error reporting. May be NULL. */
Tcl_Obj *objPtr, /* Object to receive the internal rep. */
const char *expected, /* Description of the type of number the
* caller expects to be able to parse
* ("integer", "boolean value", etc.). */
const char *bytes, /* Pointer to the start of the string to
* scan. */
int numBytes, /* Maximum number of bytes to scan, see
* above. */
const char **endPtrPtr, /* Place to store pointer to the character
* that terminated the scan. */
int flags) /* Flags governing the parse. */
{
enum State {
INITIAL, SIGNUM, ZERO, ZERO_X,
ZERO_O, ZERO_B, ZERO_D, BINARY,
HEXADECIMAL, OCTAL, BAD_OCTAL, DECIMAL,
LEADING_RADIX_POINT, FRACTION,
EXPONENT_START, EXPONENT_SIGNUM, EXPONENT,
sI, sIN, sINF, sINFI, sINFIN, sINFINI, sINFINIT, sINFINITY
#ifdef IEEE_FLOATING_POINT
, sN, sNA, sNAN, sNANPAREN, sNANHEX, sNANFINISH
#endif
} state = INITIAL;
|
| ︙ | ︙ | |||
524 525 526 527 528 529 530 531 532 533 534 535 536 537 |
* an acceptable number. */
size_t acceptLen; /* Number of characters following that
* point. */
int status = TCL_OK; /* Status to return to caller. */
char d = 0; /* Last hexadecimal digit scanned; initialized
* to avoid a compiler warning. */
int shift = 0; /* Amount to shift when accumulating binary */
#define ALL_BITS ((Tcl_WideUInt)-1)
#define MOST_BITS (ALL_BITS >> 1)
/*
* Initialize bytes to start of the object's string rep if the caller
* didn't pass anything else.
| > > > > | 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 |
* an acceptable number. */
size_t acceptLen; /* Number of characters following that
* point. */
int status = TCL_OK; /* Status to return to caller. */
char d = 0; /* Last hexadecimal digit scanned; initialized
* to avoid a compiler warning. */
int shift = 0; /* Amount to shift when accumulating binary */
int explicitOctal = 0;
mp_err err = MP_OKAY;
int under = 0; /* Flag trailing '_' as error if true once
* number is accepted. */
#define ALL_BITS ((Tcl_WideUInt)-1)
#define MOST_BITS (ALL_BITS >> 1)
/*
* Initialize bytes to start of the object's string rep if the caller
* didn't pass anything else.
|
| ︙ | ︙ | |||
565 566 567 568 569 570 571 | case INITIAL: /* * Initial state. Acceptable characters are +, -, digits, period, * I, N, and whitespace. */ | | | 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 |
case INITIAL:
/*
* Initial state. Acceptable characters are +, -, digits, period,
* I, N, and whitespace.
*/
if (TclIsSpaceProcM(c)) {
if (flags & TCL_PARSE_NO_WHITESPACE) {
goto endgame;
}
break;
} else if (c == '+') {
state = SIGNUM;
break;
|
| ︙ | ︙ | |||
632 633 634 635 636 637 638 |
* OCTAL state differ only in whether they recognize 'X' and 'b'.
*/
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (c == 'x' || c == 'X') {
| | | > > > > > > > > > > > > | > | | > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > | | > > > > > > > > > > | | | > | | > > > > > > > > > > > > > > > > > > > > > | 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 |
* OCTAL state differ only in whether they recognize 'X' and 'b'.
*/
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (c == 'x' || c == 'X') {
if (flags & (TCL_PARSE_OCTAL_ONLY|TCL_PARSE_BINARY_ONLY) || under) {
goto endgame;
}
state = ZERO_X;
break;
}
if (flags & TCL_PARSE_HEXADECIMAL_ONLY) {
goto zerox;
}
if (flags & TCL_PARSE_SCAN_PREFIXES) {
goto zeroo;
}
if (c == 'b' || c == 'B') {
if ((flags & TCL_PARSE_OCTAL_ONLY) || under) {
goto endgame;
}
state = ZERO_B;
break;
}
if (flags & TCL_PARSE_BINARY_ONLY) {
goto zerob;
}
if (c == 'o' || c == 'O') {
if (under) {
goto endgame;
}
explicitOctal = 1;
state = ZERO_O;
break;
}
if (c == 'd' || c == 'D') {
if (under) {
goto endgame;
}
state = ZERO_D;
break;
}
#ifdef TCL_NO_DEPRECATED
goto decimal;
#endif
/* FALLTHROUGH */
case OCTAL:
/*
* Scanned an optional + or -, followed by a string of octal
* digits. Acceptable inputs are more digits, period, or E. If 8
* or 9 is encountered, commit to floating point.
*/
acceptState = state;
acceptPoint = p;
acceptLen = len;
/* FALLTHROUGH */
case ZERO_O:
zeroo:
if (c == '0') {
numTrailZeros++;
under = 0;
state = OCTAL;
break;
} else if (c >= '1' && c <= '7') {
under = 0;
if (objPtr != NULL) {
shift = 3 * (numTrailZeros + 1);
significandOverflow = AccumulateDecimalDigit(
(unsigned)(c-'0'), numTrailZeros,
&significandWide, &significandBig,
significandOverflow);
if (!octalSignificandOverflow) {
/*
* Shifting by more bits than are in the value being
* shifted is at least de facto nonportable. Check for
* too large shifts first.
*/
if ((octalSignificandWide != 0)
&& (((size_t)shift >=
CHAR_BIT*sizeof(Tcl_WideUInt))
|| (octalSignificandWide >
((Tcl_WideUInt)-1 >> shift)))) {
octalSignificandOverflow = 1;
err = mp_init_u64(&octalSignificandBig,
octalSignificandWide);
}
}
if (!octalSignificandOverflow) {
octalSignificandWide =
(octalSignificandWide << shift) + (c - '0');
} else {
if (err == MP_OKAY) {
err = mp_mul_2d(&octalSignificandBig, shift,
&octalSignificandBig);
}
if (err == MP_OKAY) {
err = mp_add_d(&octalSignificandBig, (mp_digit)(c - '0'),
&octalSignificandBig);
}
}
if (err != MP_OKAY) {
return TCL_ERROR;
}
}
if (numSigDigs != 0) {
numSigDigs += numTrailZeros+1;
} else {
numSigDigs = 1;
}
numTrailZeros = 0;
state = OCTAL;
break;
} else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
}
/* FALLTHROUGH */
case BAD_OCTAL:
if (explicitOctal) {
/*
* No forgiveness for bad digits in explicitly octal numbers.
*/
goto endgame;
}
if (flags & TCL_PARSE_INTEGER_ONLY) {
/*
* No seeking floating point when parsing only integer.
*/
goto endgame;
}
#ifndef TCL_NO_DEPRECATED
/*
* Scanned a number with a leading zero that contains an 8, 9,
* radix point or E. This is an invalid octal number, but might
* still be floating point.
*/
if (c == '0') {
numTrailZeros++;
under = 0;
state = BAD_OCTAL;
break;
} else if (isdigit(UCHAR(c))) {
if (objPtr != NULL) {
significandOverflow = AccumulateDecimalDigit(
(unsigned)(c-'0'), numTrailZeros,
&significandWide, &significandBig,
significandOverflow);
}
if (numSigDigs != 0) {
numSigDigs += (numTrailZeros + 1);
} else {
numSigDigs = 1;
}
numTrailZeros = 0;
under = 0;
state = BAD_OCTAL;
break;
} else if (c == '.') {
under = 0;
state = FRACTION;
break;
} else if (c == 'E' || c == 'e') {
under = 0;
state = EXPONENT_START;
break;
}
#endif
goto endgame;
/*
* Scanned 0x. If state is HEXADECIMAL, scanned at least one
* character following the 0x. The only acceptable inputs are
* hexadecimal digits.
*/
case HEXADECIMAL:
acceptState = state;
acceptPoint = p;
acceptLen = len;
/* FALLTHROUGH */
case ZERO_X:
zerox:
if (c == '0') {
numTrailZeros++;
under = 0;
state = HEXADECIMAL;
break;
} else if (isdigit(UCHAR(c))) {
under = 0;
d = (c-'0');
} else if (c >= 'A' && c <= 'F') {
under = 0;
d = (c-'A'+10);
} else if (c >= 'a' && c <= 'f') {
under = 0;
d = (c-'a'+10);
} else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
} else {
goto endgame;
}
if (objPtr != NULL) {
shift = 4 * (numTrailZeros + 1);
if (!significandOverflow) {
/*
* Shifting by more bits than are in the value being
* shifted is at least de facto nonportable. Check for too
* large shifts first.
*/
if (significandWide != 0 &&
((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
significandWide > ((Tcl_WideUInt)-1 >> shift))) {
significandOverflow = 1;
err = mp_init_u64(&significandBig,
significandWide);
}
}
if (!significandOverflow) {
significandWide = (significandWide << shift) + d;
} else if (err == MP_OKAY) {
err = mp_mul_2d(&significandBig, shift, &significandBig);
if (err == MP_OKAY) {
err = mp_add_d(&significandBig, (mp_digit) d, &significandBig);
}
}
}
if (err != MP_OKAY) {
return TCL_ERROR;
}
numTrailZeros = 0;
state = HEXADECIMAL;
break;
case BINARY:
acceptState = state;
acceptPoint = p;
acceptLen = len;
/* FALLTHRU */
case ZERO_B:
zerob:
if (c == '0') {
numTrailZeros++;
under = 0;
state = BINARY;
break;
} else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
} else if (c != '1') {
goto endgame;
}
if (objPtr != NULL) {
shift = numTrailZeros + 1;
if (!significandOverflow) {
/*
* Shifting by more bits than are in the value being
* shifted is at least de facto nonportable. Check for too
* large shifts first.
*/
if (significandWide != 0 &&
((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
significandWide > ((Tcl_WideUInt)-1 >> shift))) {
significandOverflow = 1;
err = mp_init_u64(&significandBig,
significandWide);
}
}
if (!significandOverflow) {
significandWide = (significandWide << shift) + 1;
} else if (err == MP_OKAY) {
err = mp_mul_2d(&significandBig, shift, &significandBig);
if (err == MP_OKAY) {
err = mp_add_d(&significandBig, (mp_digit) 1, &significandBig);
}
}
}
if (err != MP_OKAY) {
return TCL_ERROR;
}
numTrailZeros = 0;
state = BINARY;
break;
case ZERO_D:
if (c == '0') {
under = 0;
numTrailZeros++;
} else if ( ! isdigit(UCHAR(c))) {
if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
}
goto endgame;
}
under = 0;
state = DECIMAL;
flags |= TCL_PARSE_INTEGER_ONLY;
/* FALLTHROUGH */
case DECIMAL:
/*
* Scanned an optional + or - followed by a string of decimal
* digits.
*/
#ifdef TCL_NO_DEPRECATED
decimal:
#endif
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (c == '0') {
numTrailZeros++;
under = 0;
state = DECIMAL;
break;
} else if (isdigit(UCHAR(c))) {
if (objPtr != NULL) {
significandOverflow = AccumulateDecimalDigit(
(unsigned)(c - '0'), numTrailZeros,
&significandWide, &significandBig,
significandOverflow);
}
numSigDigs += numTrailZeros+1;
numTrailZeros = 0;
under = 0;
state = DECIMAL;
break;
} else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
} else if (flags & TCL_PARSE_INTEGER_ONLY) {
goto endgame;
} else if (c == '.') {
under = 0;
state = FRACTION;
break;
} else if (c == 'E' || c == 'e') {
under = 0;
state = EXPONENT_START;
break;
}
goto endgame;
/*
* Found a decimal point. If no digits have yet been scanned, E is
|
| ︙ | ︙ | |||
889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 |
}
/* FALLTHROUGH */
case LEADING_RADIX_POINT:
if (c == '0') {
numDigitsAfterDp++;
numTrailZeros++;
state = FRACTION;
break;
} else if (isdigit(UCHAR(c))) {
numDigitsAfterDp++;
if (objPtr != NULL) {
significandOverflow = AccumulateDecimalDigit(
(unsigned)(c-'0'), numTrailZeros,
&significandWide, &significandBig,
significandOverflow);
}
if (numSigDigs != 0) {
numSigDigs += numTrailZeros+1;
} else {
numSigDigs = 1;
}
numTrailZeros = 0;
state = FRACTION;
break;
}
goto endgame;
case EXPONENT_START:
/*
* Scanned the E at the start of an exponent. Make sure a legal
* character follows before using the C library strtol routine,
* which allows whitespace.
*/
if (c == '+') {
state = EXPONENT_SIGNUM;
break;
} else if (c == '-') {
exponentSignum = 1;
state = EXPONENT_SIGNUM;
break;
}
/* FALLTHROUGH */
case EXPONENT_SIGNUM:
/*
* Found the E at the start of the exponent, followed by a sign
* character.
*/
if (isdigit(UCHAR(c))) {
exponent = c - '0';
state = EXPONENT;
break;
}
goto endgame;
case EXPONENT:
/*
* Found an exponent with at least one digit. Accumulate it,
* making sure to hard-pin it to LONG_MAX on overflow.
*/
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (isdigit(UCHAR(c))) {
if (exponent < (LONG_MAX - 9) / 10) {
exponent = 10 * exponent + (c - '0');
} else {
exponent = LONG_MAX;
}
state = EXPONENT;
break;
}
goto endgame;
/*
* Parse out INFINITY by simply spelling it out. INF is accepted
* as an abbreviation; other prefices are not.
*/
case sI:
if (c == 'n' || c == 'N') {
state = sIN;
break;
}
goto endgame;
case sIN:
if (c == 'f' || c == 'F') {
state = sINF;
break;
}
goto endgame;
case sINF:
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (c == 'i' || c == 'I') {
state = sINFI;
break;
}
goto endgame;
case sINFI:
if (c == 'n' || c == 'N') {
state = sINFIN;
break;
}
goto endgame;
case sINFIN:
if (c == 'i' || c == 'I') {
state = sINFINI;
break;
}
goto endgame;
case sINFINI:
if (c == 't' || c == 'T') {
state = sINFINIT;
break;
}
goto endgame;
case sINFINIT:
if (c == 'y' || c == 'Y') {
state = sINFINITY;
break;
}
goto endgame;
/*
* Parse NaN's.
*/
#ifdef IEEE_FLOATING_POINT
case sN:
if (c == 'a' || c == 'A') {
state = sNA;
break;
}
goto endgame;
case sNA:
if (c == 'n' || c == 'N') {
state = sNAN;
break;
}
goto endgame;
case sNAN:
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (c == '(') {
state = sNANPAREN;
break;
}
goto endgame;
/*
* Parse NaN(hexdigits)
*/
case sNANHEX:
if (c == ')') {
state = sNANFINISH;
break;
}
/* FALLTHROUGH */
case sNANPAREN:
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > | | > | | > | 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 |
}
/* FALLTHROUGH */
case LEADING_RADIX_POINT:
if (c == '0') {
numDigitsAfterDp++;
numTrailZeros++;
under = 0;
state = FRACTION;
break;
} else if (isdigit(UCHAR(c))) {
numDigitsAfterDp++;
if (objPtr != NULL) {
significandOverflow = AccumulateDecimalDigit(
(unsigned)(c-'0'), numTrailZeros,
&significandWide, &significandBig,
significandOverflow);
}
if (numSigDigs != 0) {
numSigDigs += numTrailZeros+1;
} else {
numSigDigs = 1;
}
numTrailZeros = 0;
under = 0;
state = FRACTION;
break;
} else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
}
goto endgame;
case EXPONENT_START:
/*
* Scanned the E at the start of an exponent. Make sure a legal
* character follows before using the C library strtol routine,
* which allows whitespace.
*/
if (c == '+') {
under = 0;
state = EXPONENT_SIGNUM;
break;
} else if (c == '-') {
exponentSignum = 1;
under = 0;
state = EXPONENT_SIGNUM;
break;
}
/* FALLTHROUGH */
case EXPONENT_SIGNUM:
/*
* Found the E at the start of the exponent, followed by a sign
* character.
*/
if (isdigit(UCHAR(c))) {
exponent = c - '0';
under = 0;
state = EXPONENT;
break;
} else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
}
goto endgame;
case EXPONENT:
/*
* Found an exponent with at least one digit. Accumulate it,
* making sure to hard-pin it to LONG_MAX on overflow.
*/
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (isdigit(UCHAR(c))) {
if (exponent < (LONG_MAX - 9) / 10) {
exponent = 10 * exponent + (c - '0');
} else {
exponent = LONG_MAX;
}
under = 0;
state = EXPONENT;
break;
} else if (c == '_' && !(flags & TCL_PARSE_NO_UNDERSCORE)) {
/* Ignore numeric "white space" */
under = 1;
break;
}
goto endgame;
/*
* Parse out INFINITY by simply spelling it out. INF is accepted
* as an abbreviation; other prefices are not.
*/
case sI:
if (c == 'n' || c == 'N') {
under = 0;
state = sIN;
break;
}
goto endgame;
case sIN:
if (c == 'f' || c == 'F') {
under = 0;
state = sINF;
break;
}
goto endgame;
case sINF:
acceptState = state;
acceptPoint = p;
acceptLen = len;
under = 0;
if (c == 'i' || c == 'I') {
state = sINFI;
break;
}
goto endgame;
case sINFI:
if (c == 'n' || c == 'N') {
under = 0;
state = sINFIN;
break;
}
goto endgame;
case sINFIN:
if (c == 'i' || c == 'I') {
under = 0;
state = sINFINI;
break;
}
goto endgame;
case sINFINI:
if (c == 't' || c == 'T') {
under = 0;
state = sINFINIT;
break;
}
goto endgame;
case sINFINIT:
if (c == 'y' || c == 'Y') {
under = 0;
state = sINFINITY;
break;
}
goto endgame;
/*
* Parse NaN's.
*/
#ifdef IEEE_FLOATING_POINT
case sN:
if (c == 'a' || c == 'A') {
under = 0;
state = sNA;
break;
}
goto endgame;
case sNA:
if (c == 'n' || c == 'N') {
under = 0;
state = sNAN;
break;
}
goto endgame;
case sNAN:
acceptState = state;
acceptPoint = p;
acceptLen = len;
if (c == '(') {
under = 0;
state = sNANPAREN;
break;
}
goto endgame;
/*
* Parse NaN(hexdigits)
*/
case sNANHEX:
if (c == ')') {
under = 0;
state = sNANFINISH;
break;
}
/* FALLTHROUGH */
case sNANPAREN:
if (TclIsSpaceProcM(c)) {
under = 0;
break;
}
if (numSigDigs < 13) {
if (c >= '0' && c <= '9') {
d = c - '0';
} else if (c >= 'a' && c <= 'f') {
d = 10 + c - 'a';
} else if (c >= 'A' && c <= 'F') {
d = 10 + c - 'A';
} else {
goto endgame;
}
numSigDigs++;
significandWide = (significandWide << 4) + d;
under = 0;
state = sNANHEX;
break;
}
goto endgame;
case sNANFINISH:
#endif
case sINFINITY:
acceptState = state;
acceptPoint = p;
acceptLen = len;
goto endgame;
}
p++;
len--;
}
endgame:
if (acceptState == INITIAL) {
/*
* No numeric string at all found.
*/
status = TCL_ERROR;
if (endPtrPtr != NULL) {
*endPtrPtr = p;
}
} else {
/*
* Back up to the last accepting state in the lexer.
* If the last char seen is the numeric whitespace character '_',
* backup to that.
*/
p = under ? acceptPoint-1 : acceptPoint;
len = under ? acceptLen-1 : acceptLen;
if (!(flags & TCL_PARSE_NO_WHITESPACE)) {
/*
* Accept trailing whitespace.
*/
while (len != 0 && TclIsSpaceProcM(*p)) {
p++;
len--;
}
}
if (endPtrPtr == NULL) {
if ((len != 0) && ((numBytes > 0) || (*p != '\0'))) {
status = TCL_ERROR;
}
} else {
*endPtrPtr = p;
}
}
/*
* Generate and store the appropriate internal rep.
*/
if (status == TCL_OK && objPtr != NULL) {
TclFreeIntRep(objPtr);
switch (acceptState) {
case SIGNUM:
case BAD_OCTAL:
case ZERO_X:
case ZERO_O:
case ZERO_B:
case ZERO_D:
case LEADING_RADIX_POINT:
case EXPONENT_START:
case EXPONENT_SIGNUM:
|
| ︙ | ︙ | |||
1150 1151 1152 1153 1154 1155 1156 |
acceptState, bytes);
case BINARY:
shift = numTrailZeros;
if (!significandOverflow && significandWide != 0 &&
((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
significandWide > (MOST_BITS + signum) >> shift)) {
significandOverflow = 1;
| | | | > > > | | | > > > | | | | | | | > > > | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < | < | > > > | 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 |
acceptState, bytes);
case BINARY:
shift = numTrailZeros;
if (!significandOverflow && significandWide != 0 &&
((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
significandWide > (MOST_BITS + signum) >> shift)) {
significandOverflow = 1;
err = mp_init_u64(&significandBig, significandWide);
}
if (shift) {
if (!significandOverflow) {
significandWide <<= shift;
} else if (err == MP_OKAY) {
err = mp_mul_2d(&significandBig, shift, &significandBig);
}
}
if (err != MP_OKAY) {
return TCL_ERROR;
}
goto returnInteger;
case HEXADECIMAL:
/*
* Returning a hex integer. Final scaling step.
*/
shift = 4 * numTrailZeros;
if (!significandOverflow && significandWide !=0 &&
((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
significandWide > (MOST_BITS + signum) >> shift)) {
significandOverflow = 1;
err = mp_init_u64(&significandBig, significandWide);
}
if (shift) {
if (!significandOverflow) {
significandWide <<= shift;
} else if (err == MP_OKAY) {
err = mp_mul_2d(&significandBig, shift, &significandBig);
}
}
if (err != MP_OKAY) {
return TCL_ERROR;
}
goto returnInteger;
case OCTAL:
/*
* Returning an octal integer. Final scaling step.
*/
shift = 3 * numTrailZeros;
if (!octalSignificandOverflow && octalSignificandWide != 0 &&
((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) ||
octalSignificandWide > (MOST_BITS + signum) >> shift)) {
octalSignificandOverflow = 1;
err = mp_init_u64(&octalSignificandBig,
octalSignificandWide);
}
if (shift) {
if (!octalSignificandOverflow) {
octalSignificandWide <<= shift;
} else if (err == MP_OKAY) {
err = mp_mul_2d(&octalSignificandBig, shift,
&octalSignificandBig);
}
}
if (!octalSignificandOverflow) {
if ((err == MP_OKAY) && (octalSignificandWide > (MOST_BITS + signum))) {
err = mp_init_u64(&octalSignificandBig,
octalSignificandWide);
octalSignificandOverflow = 1;
} else {
objPtr->typePtr = &tclIntType;
if (signum) {
objPtr->internalRep.wideValue =
- (Tcl_WideInt) octalSignificandWide;
} else {
objPtr->internalRep.wideValue =
(Tcl_WideInt) octalSignificandWide;
}
}
}
if ((err == MP_OKAY) && octalSignificandOverflow) {
if (signum) {
err = mp_neg(&octalSignificandBig, &octalSignificandBig);
}
TclSetBignumIntRep(objPtr, &octalSignificandBig);
}
if (err != MP_OKAY) {
return TCL_ERROR;
}
break;
case ZERO:
case DECIMAL:
significandOverflow = AccumulateDecimalDigit(0, numTrailZeros-1,
&significandWide, &significandBig, significandOverflow);
if ((err == MP_OKAY) && !significandOverflow && (significandWide > MOST_BITS+signum)) {
significandOverflow = 1;
err = mp_init_u64(&significandBig, significandWide);
}
returnInteger:
if (!significandOverflow) {
if ((err == MP_OKAY) && (significandWide > MOST_BITS+signum)) {
err = mp_init_u64(&significandBig,
significandWide);
significandOverflow = 1;
} else {
objPtr->typePtr = &tclIntType;
if (signum) {
objPtr->internalRep.wideValue =
- (Tcl_WideInt) significandWide;
} else {
objPtr->internalRep.wideValue =
(Tcl_WideInt) significandWide;
}
}
}
if ((err == MP_OKAY) && significandOverflow) {
if (signum) {
err = mp_neg(&significandBig, &significandBig);
}
TclSetBignumIntRep(objPtr, &significandBig);
}
if (err != MP_OKAY) {
return TCL_ERROR;
}
break;
case FRACTION:
case EXPONENT:
/*
* Here, we're parsing a floating-point number. 'significandWide'
* or 'significandBig' contains the exact significand, according
* to whether 'significandOverflow' is set. The desired floating
* point value is significand * 10**k, where
* k = numTrailZeros+exponent-numDigitsAfterDp.
*/
objPtr->typePtr = &tclDoubleType;
if (exponentSignum) {
/*
* At this point exponent>=0, so the following calculation
* cannot underflow.
*/
exponent = -exponent;
}
/*
* Adjust the exponent for the number of trailing zeros that
* have not been accumulated, and the number of digits after
* the decimal point. Pin any overflow to LONG_MAX/LONG_MIN
* respectively.
*/
if (exponent >= 0) {
if (exponent - numDigitsAfterDp > LONG_MAX - numTrailZeros) {
exponent = LONG_MAX;
} else {
exponent = exponent - numDigitsAfterDp + numTrailZeros;
}
} else {
if (exponent + numTrailZeros < LONG_MIN + numDigitsAfterDp) {
exponent = LONG_MIN;
} else {
exponent = exponent + numTrailZeros - numDigitsAfterDp;
}
}
/*
* The desired number is now significandWide * 10**exponent
* or significandBig * 10**exponent, depending on whether
* the significand has overflowed a wide int.
*/
if (!significandOverflow) {
objPtr->internalRep.doubleValue = MakeLowPrecisionDouble(
signum, significandWide, numSigDigs, exponent);
} else {
objPtr->internalRep.doubleValue = MakeHighPrecisionDouble(
signum, &significandBig, numSigDigs, exponent);
}
break;
case sINF:
case sINFINITY:
if (signum) {
objPtr->internalRep.doubleValue = -HUGE_VAL;
} else {
objPtr->internalRep.doubleValue = HUGE_VAL;
}
objPtr->typePtr = &tclDoubleType;
break;
#ifdef IEEE_FLOATING_POINT
case sNAN:
case sNANFINISH:
objPtr->internalRep.doubleValue = MakeNaN(signum, significandWide);
objPtr->typePtr = &tclDoubleType;
break;
#endif
case INITIAL:
/* This case only to silence compiler warning. */
Tcl_Panic("TclParseNumber: state INITIAL can't happen here");
}
}
/*
* Format an error message when an invalid number is encountered.
*/
if (status != TCL_OK) {
if (interp != NULL) {
Tcl_Obj *msg = Tcl_ObjPrintf("expected %s but got \"",
expected);
Tcl_AppendLimitedToObj(msg, bytes, numBytes, 50, "");
Tcl_AppendToObj(msg, "\"", -1);
if (state == BAD_OCTAL) {
Tcl_AppendToObj(msg, " (looks like invalid octal number)", -1);
}
Tcl_SetObjResult(interp, msg);
Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL);
}
}
/*
* Free memory.
|
| ︙ | ︙ | |||
1390 1391 1392 1393 1394 1395 1396 |
} else if (numZeros >= maxpow10_wide
|| w > ((Tcl_WideUInt)-1-digit)/pow10_wide[numZeros+1]) {
/*
* Wide multiplication will overflow. Expand the number to a
* bignum and fall through into the bignum case.
*/
| | > > | | | > > | | | | | | | > | | > > | 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 |
} else if (numZeros >= maxpow10_wide
|| w > ((Tcl_WideUInt)-1-digit)/pow10_wide[numZeros+1]) {
/*
* Wide multiplication will overflow. Expand the number to a
* bignum and fall through into the bignum case.
*/
if (mp_init_u64(bignumRepPtr, w) != MP_OKAY) {
return 0;
}
} else {
/*
* Wide multiplication.
*/
*wideRepPtr = w * pow10_wide[numZeros+1] + digit;
return 0;
}
}
/*
* Bignum multiplication.
*/
if (numZeros < log10_DIGIT_MAX) {
/*
* Up to about 8 zeros - single digit multiplication.
*/
if ((mp_mul_d(bignumRepPtr, (mp_digit) pow10_wide[numZeros+1],
bignumRepPtr) != MP_OKAY)
|| (mp_add_d(bignumRepPtr, (mp_digit) digit, bignumRepPtr) != MP_OKAY))
return 0;
} else {
mp_err err;
/*
* More than single digit multiplication. Multiply by the appropriate
* small powers of 5, and then shift. Large strings of zeroes are
* eaten 256 at a time; this is less efficient than it could be, but
* seems implausible. We presume that MP_DIGIT_BIT is at least 27. The
* first multiplication, by up to 10**7, is done with a one-DIGIT
* multiply (this presumes that MP_DIGIT_BIT >= 24).
*/
n = numZeros + 1;
err = mp_mul_d(bignumRepPtr, (mp_digit) pow10_wide[n&0x7], bignumRepPtr);
for (i = 3; (err == MP_OKAY) && (i <= 7); ++i) {
if (n & (1 << i)) {
err = mp_mul(bignumRepPtr, pow5+i, bignumRepPtr);
}
}
while ((err == MP_OKAY) && (n >= 256)) {
err = mp_mul(bignumRepPtr, pow5+8, bignumRepPtr);
n -= 256;
}
if ((err != MP_OKAY)
|| (mp_mul_2d(bignumRepPtr, (int)(numZeros+1)&~0x7, bignumRepPtr) != MP_OKAY)
|| (mp_add_d(bignumRepPtr, (mp_digit) digit, bignumRepPtr) != MP_OKAY)) {
return 0;
}
}
return 1;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1463 1464 1465 1466 1467 1468 1469 |
*
*----------------------------------------------------------------------
*/
static double
MakeLowPrecisionDouble(
int signum, /* 1 if the number is negative, 0 otherwise */
| | | | > > > | 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 |
*
*----------------------------------------------------------------------
*/
static double
MakeLowPrecisionDouble(
int signum, /* 1 if the number is negative, 0 otherwise */
Tcl_WideUInt significand, /* Significand of the number */
int numSigDigs, /* Number of digits in the significand */
long exponent) /* Power of ten */
{
double retval; /* Value of the number. */
mp_int significandBig; /* Significand expressed as a bignum. */
/*
* With gcc on x86, the floating point rounding mode is double-extended.
* This causes the result of double-precision calculations to be rounded
* twice: once to the precision of double-extended and then again to the
* precision of double. Double-rounding introduces gratuitous errors of 1
* ulp, so we need to change rounding mode to 53-bits.
*/
TCL_IEEE_DOUBLE_ROUNDING;
/*
* Test for the easy cases.
*/
if (significand == 0) {
return copysign(0.0, -signum);
}
if (numSigDigs <= QUICK_MAX) {
if (exponent >= 0) {
if (exponent <= mmaxpow) {
/*
* The significand is an exact integer, and so is
* 10**exponent. The product will be correct to within 1/2 ulp
* without special handling.
|
| ︙ | ︙ | |||
1533 1534 1535 1536 1537 1538 1539 |
}
/*
* All the easy cases have failed. Promote ths significand to bignum and
* call MakeHighPrecisionDouble to do it the hard way.
*/
| | > > | 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 |
}
/*
* All the easy cases have failed. Promote ths significand to bignum and
* call MakeHighPrecisionDouble to do it the hard way.
*/
if (mp_init_u64(&significandBig, significand) != MP_OKAY) {
return 0.0;
}
retval = MakeHighPrecisionDouble(0, &significandBig, numSigDigs,
exponent);
mp_clear(&significandBig);
/*
* Come here to return the computed value.
*/
|
| ︙ | ︙ | |||
1576 1577 1578 1579 1580 1581 1582 | * the answer in high precision. * *---------------------------------------------------------------------- */ static double MakeHighPrecisionDouble( | | | | | | | > > > > | < | | | 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 |
* the answer in high precision.
*
*----------------------------------------------------------------------
*/
static double
MakeHighPrecisionDouble(
int signum, /* 1=negative, 0=nonnegative */
mp_int *significand, /* Exact significand of the number */
int numSigDigs, /* Number of significant digits */
long exponent) /* Power of 10 by which to multiply */
{
double retval;
int machexp = 0; /* Machine exponent of a power of 10. */
/*
* With gcc on x86, the floating point rounding mode is double-extended.
* This causes the result of double-precision calculations to be rounded
* twice: once to the precision of double-extended and then again to the
* precision of double. Double-rounding introduces gratuitous errors of 1
* ulp, so we need to change rounding mode to 53-bits.
*/
TCL_IEEE_DOUBLE_ROUNDING;
/*
* Quick checks for zero, and over/underflow. Be careful to avoid
* integer overflow when calculating with 'exponent'.
*/
if (mp_iszero(significand)) {
return copysign(0.0, -signum);
}
if (exponent >= 0 && exponent-1 > maxDigits-numSigDigs) {
retval = HUGE_VAL;
goto returnValue;
} else if (exponent < 0 && numSigDigs+exponent < minDigits+1) {
retval = 0.0;
goto returnValue;
}
/*
* Develop a first approximation to the significand. It is tempting simply
* to force bignum to double, but that will overflow on input numbers like
* 1.[string repeat 0 1000]1; while this is a not terribly likely
|
| ︙ | ︙ | |||
1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 |
double quot; /* Correction term. */
double minincr; /* Lower bound on the absolute value of the
* correction term. */
int roundToEven = 0; /* Flag == TRUE if we need to invoke
* "round to even" functionality */
double rteSignificand; /* Significand of the round-to-even result */
int rteExponent; /* Exponent of the round-to-even result */
Tcl_WideInt rteSigWide; /* Wide integer version of the significand
* for testing evenness */
int i;
/*
* The first approximation is always low. If we find that it's HUGE_VAL,
* we're done.
*/
if (approxResult == HUGE_VAL) {
return approxResult;
}
/*
| > > > > > < > > > > > > > > > | > < | < | < < | | > > | | > | | < | | > > > | | > | > > > > > > > > | > | > < | | | > > > > | | | > > > > > > > > > > < | | > > > > > > > > > > > > > > > > > > > > > > > > | 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 |
double quot; /* Correction term. */
double minincr; /* Lower bound on the absolute value of the
* correction term. */
int roundToEven = 0; /* Flag == TRUE if we need to invoke
* "round to even" functionality */
double rteSignificand; /* Significand of the round-to-even result */
int rteExponent; /* Exponent of the round-to-even result */
int shift; /* Shift count for converting numerator
* and denominator of corrector to floating
* point */
Tcl_WideInt rteSigWide; /* Wide integer version of the significand
* for testing evenness */
int i;
mp_err err = MP_OKAY;
/*
* The first approximation is always low. If we find that it's HUGE_VAL,
* we're done.
*/
if (approxResult == HUGE_VAL) {
return approxResult;
}
significand = frexp(approxResult, &binExponent);
/*
* We are trying to compute a corrector term that, when added to the
* approximate result, will yield close to the exact result.
* The exact result is exactSignificand * 10**exponent.
* The approximate result is significand * 2**binExponent
* If exponent<0, we need to multiply the exact value by 10**-exponent
* to make it an integer, plus another factor of 2 to decide on rounding.
* Similarly if binExponent<FP_PRECISION, we need
* to multiply by 2**FP_PRECISION to make the approximate value an integer.
*
* Let M = 2**M2 * 5**M5 be the least common multiple of these two
* multipliers.
*/
i = mantBits - binExponent;
if (i < 0) {
M2 = 0;
} else {
M2 = i;
}
if (exponent > 0) {
M5 = 0;
} else {
M5 = -exponent;
if (M5 - 1 > M2) {
M2 = M5 - 1;
}
}
/*
* Compute twoMv as 2*M*v, where v is the approximate value.
* This is done by bit-whacking to calculate 2**(M2+1)*significand,
* and then multiplying by 5**M5.
*/
msb = binExponent + M2; /* 1008 */
nDigits = msb / MP_DIGIT_BIT + 1;
if (mp_init_size(&twoMv, nDigits) != MP_OKAY) {
return approxResult;
}
i = (msb % MP_DIGIT_BIT + 1);
twoMv.used = nDigits;
significand *= SafeLdExp(1.0, i);
while (--nDigits >= 0) {
twoMv.dp[nDigits] = (mp_digit) significand;
significand -= (mp_digit) significand;
significand = SafeLdExp(significand, MP_DIGIT_BIT);
}
for (i = 0; i <= 8; ++i) {
if (M5 & (1 << i) && (mp_mul(&twoMv, pow5+i, &twoMv) != MP_OKAY)) {
mp_clear(&twoMv);
return approxResult;
}
}
/*
* Compute twoMd as 2*M*d, where d is the exact value.
* This is done by multiplying by 5**(M5+exponent) and then multiplying
* by 2**(M5+exponent+1), which is, of couse, a left shift.
*/
if (mp_init_copy(&twoMd, exactSignificand) != MP_OKAY) {
mp_clear(&twoMv);
return approxResult;
}
for (i = 0; (i <= 8); ++i) {
if ((M5 + exponent) & (1 << i)) {
err = mp_mul(&twoMd, pow5+i, &twoMd);
}
}
if (err == MP_OKAY) {
err = mp_mul_2d(&twoMd, M2+exponent+1, &twoMd);
}
/*
* Now let twoMd = twoMd - twoMv, the difference between the exact and
* approximate values.
*/
if (err == MP_OKAY) {
err = mp_sub(&twoMd, &twoMv, &twoMd);
}
/*
* The result, 2Mv-2Md, needs to be divided by 2M to yield a correction
* term. Because 2M may well overflow a double, we need to scale the
* denominator by a factor of 2**binExponent-mantBits. Place that factor
* times 1/2 ULP into twoMd.
*/
scale = binExponent - mantBits - 1;
mp_set_u64(&twoMv, 1);
for (i = 0; (i <= 8) && (err == MP_OKAY); ++i) {
if (M5 & (1 << i)) {
err = mp_mul(&twoMv, pow5+i, &twoMv);
}
}
multiplier = M2 + scale + 1;
if (err != MP_OKAY) {
mp_clear(&twoMd);
mp_clear(&twoMv);
return approxResult;
} else if (multiplier > 0) {
err = mp_mul_2d(&twoMv, multiplier, &twoMv);
} else if (multiplier < 0) {
err = mp_div_2d(&twoMv, -multiplier, &twoMv, NULL);
}
if (err != MP_OKAY) {
mp_clear(&twoMd);
mp_clear(&twoMv);
return approxResult;
}
/*
* Will the eventual correction term be less than, equal to, or
* greater than 1/2 ULP?
*/
switch (mp_cmp_mag(&twoMd, &twoMv)) {
case MP_LT:
/*
* If the error is less than 1/2 ULP, there's no correction to make.
*/
mp_clear(&twoMd);
mp_clear(&twoMv);
return approxResult;
case MP_EQ:
/*
* If the error is exactly 1/2 ULP, we need to round to even.
*/
roundToEven = 1;
break;
case MP_GT:
/*
* We need to correct the result if the error exceeds 1/2 ULP.
*/
break;
}
/*
* If we're in the 'round to even' case, and the significand is already
* even, we're done. Return the approximate result.
*/
if (roundToEven) {
rteSignificand = frexp(approxResult, &rteExponent);
rteSigWide = (Tcl_WideInt) ldexp(rteSignificand, FP_PRECISION);
if ((rteSigWide & 1) == 0) {
mp_clear(&twoMd);
mp_clear(&twoMv);
return approxResult;
}
}
/*
* Reduce the numerator and denominator of the corrector term so that
* they will fit in the floating point precision.
*/
shift = mp_count_bits(&twoMv) - FP_PRECISION - 1;
if (shift > 0) {
err = mp_div_2d(&twoMv, shift, &twoMv, NULL);
if (err == MP_OKAY) {
err = mp_div_2d(&twoMd, shift, &twoMd, NULL);
}
}
if (err != MP_OKAY) {
mp_clear(&twoMd);
mp_clear(&twoMv);
return approxResult;
}
/*
* Convert the numerator and denominator of the corrector term accurately
* to floating point numbers.
*/
num = TclBignumToDouble(&twoMd);
|
| ︙ | ︙ | |||
1900 1901 1902 1903 1904 1905 1906 | * * Side effects: * Stores base*5**n in result. * *---------------------------------------------------------------------- */ | | > | | | | | > | 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 |
*
* Side effects:
* Stores base*5**n in result.
*
*----------------------------------------------------------------------
*/
static inline mp_err
MulPow5(
mp_int *base, /* Number to multiply. */
unsigned n, /* Power of 5 to multiply by. */
mp_int *result) /* Place to store the result. */
{
mp_int *p = base;
int n13 = n / 13;
int r = n % 13;
mp_err err = MP_OKAY;
if (r != 0) {
err = mp_mul_d(p, dpow5[r], result);
p = result;
}
r = 0;
while ((err == MP_OKAY) && (n13 != 0)) {
if (n13 & 1) {
err = mp_mul(p, pow5_13+r, result);
p = result;
}
n13 >>= 1;
++r;
}
if ((err == MP_OKAY) && (p != result)) {
err = mp_copy(p, result);
}
return err;
}
/*
*----------------------------------------------------------------------
*
* NormalizeRightward --
*
|
| ︙ | ︙ | |||
1952 1953 1954 1955 1956 1957 1958 |
static inline int
NormalizeRightward(
Tcl_WideUInt *wPtr) /* INOUT: Number to shift. */
{
int rv = 0;
Tcl_WideUInt w = *wPtr;
| | | | | | 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 |
static inline int
NormalizeRightward(
Tcl_WideUInt *wPtr) /* INOUT: Number to shift. */
{
int rv = 0;
Tcl_WideUInt w = *wPtr;
if (!(w & (Tcl_WideUInt) 0xFFFFFFFF)) {
w >>= 32; rv += 32;
}
if (!(w & (Tcl_WideUInt) 0xFFFF)) {
w >>= 16; rv += 16;
}
if (!(w & (Tcl_WideUInt) 0xFF)) {
w >>= 8; rv += 8;
}
if (!(w & (Tcl_WideUInt) 0xF)) {
w >>= 4; rv += 4;
}
if (!(w & 0x3)) {
w >>= 2; rv += 2;
}
if (!(w & 0x1)) {
w >>= 1; ++rv;
|
| ︙ | ︙ | |||
1995 1996 1997 1998 1999 2000 2001 |
static int
RequiredPrecision(
Tcl_WideUInt w) /* Number to interrogate. */
{
int rv;
unsigned long wi;
| | | | | | | 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 |
static int
RequiredPrecision(
Tcl_WideUInt w) /* Number to interrogate. */
{
int rv;
unsigned long wi;
if (w & ((Tcl_WideUInt) 0xFFFFFFFF << 32)) {
wi = (unsigned long) (w >> 32); rv = 32;
} else {
wi = (unsigned long) w; rv = 0;
}
if (wi & 0xFFFF0000) {
wi >>= 16; rv += 16;
}
if (wi & 0xFF00) {
wi >>= 8; rv += 8;
}
if (wi & 0xF0) {
wi >>= 4; rv += 4;
}
if (wi & 0xC) {
wi >>= 2; rv += 2;
}
if (wi & 0x2) {
wi >>= 1; ++rv;
}
if (wi & 0x1) {
++rv;
|
| ︙ | ︙ | |||
2106 2107 2108 2109 2110 2111 2112 | * * FormatInfAndNaN -- * * Bailout for formatting infinities and Not-A-Number. * * Results: * Returns one of the strings 'Infinity' and 'NaN'. The string returned | | | | | 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 |
*
* FormatInfAndNaN --
*
* Bailout for formatting infinities and Not-A-Number.
*
* Results:
* Returns one of the strings 'Infinity' and 'NaN'. The string returned
* must be freed by the caller using 'ckfree'.
*
* Side effects:
* Stores 9999 in *decpt, and sets '*endPtr' to designate the terminating
* NUL byte of the string if 'endPtr' is not NULL.
*
*----------------------------------------------------------------------
*/
static inline char *
FormatInfAndNaN(
Double *d, /* Exceptional number to format. */
int *decpt, /* Decimal point to set to a bogus value. */
char **endPtr) /* Pointer to the end of the formatted data */
{
char *retval;
*decpt = 9999;
if (!(d->w.word1) && !(d->w.word0 & HI_ORDER_SIG_MASK)) {
retval = (char *)ckalloc(9);
strcpy(retval, "Infinity");
if (endPtr) {
*endPtr = retval + 8;
}
} else {
retval = (char *)ckalloc(4);
strcpy(retval, "NaN");
if (endPtr) {
*endPtr = retval + 3;
}
}
return retval;
}
|
| ︙ | ︙ | |||
2162 2163 2164 2165 2166 2167 2168 |
*/
static inline char *
FormatZero(
int *decpt, /* Location of the decimal point. */
char **endPtr) /* Pointer to the end of the formatted data */
{
| | | 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 |
*/
static inline char *
FormatZero(
int *decpt, /* Location of the decimal point. */
char **endPtr) /* Pointer to the end of the formatted data */
{
char *retval = (char *)ckalloc(2);
strcpy(retval, "0");
if (endPtr) {
*endPtr = retval+1;
}
*decpt = 0;
return retval;
|
| ︙ | ︙ | |||
2447 2448 2449 2450 2451 2452 2453 |
ieps = 2;
if (k > 0) {
/*
* The number must be reduced to bring it into range.
*/
| | | | 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 |
ieps = 2;
if (k > 0) {
/*
* The number must be reduced to bring it into range.
*/
ds = tens[k & 0xF];
j = k >> 4;
if (j & BLETCH) {
j &= (BLETCH-1);
d /= bigtens[N_BIGTENS - 1];
ieps++;
}
i = 0;
for (; j != 0; j>>=1) {
if (j & 1) {
ds *= bigtens[i];
++ieps;
}
++i;
}
d /= ds;
} else if ((j1 = -k) != 0) {
/*
* The number must be increased to bring it into range.
*/
d *= tens[j1 & 0xF];
i = 0;
for (j = j1>>4; j; j>>=1) {
if (j & 1) {
ieps++;
d *= bigtens[i];
}
++i;
|
| ︙ | ︙ | |||
2657 2658 2659 2660 2661 2662 2663 |
static inline char *
QuickConversion(
double e, /* Number to format. */
int k, /* floor(log10(d)), approximately. */
int k_check, /* 0 if k is exact, 1 if it may be too high */
int flags, /* Flags passed to dtoa:
| | | 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 |
static inline char *
QuickConversion(
double e, /* Number to format. */
int k, /* floor(log10(d)), approximately. */
int k_check, /* 0 if k is exact, 1 if it may be too high */
int flags, /* Flags passed to dtoa:
* TCL_DD_SHORTEST */
int len, /* Length of the return value. */
int ilim, /* Number of digits to store. */
int ilim1, /* Number of digits to store if we misguessed
* k. */
int *decpt, /* OUTPUT: Location of the decimal point. */
char **endPtr) /* OUTPUT: Pointer to the terminal null
* byte. */
|
| ︙ | ︙ | |||
2708 2709 2710 2711 2712 2713 2714 |
eps.d = ieps * d + 7.;
eps.w.word0 -= (FP_PRECISION-1) << EXP_SHIFT;
/*
* Handle the peculiar case where the result has no significant digits.
*/
| | | | | | 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 |
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 -= 5.;
if (d > eps.d) {
*retval = '1';
*decpt = k;
return retval;
} else if (d < -eps.d) {
*decpt = k;
return retval;
} else {
ckfree(retval);
return NULL;
}
}
/*
* Format the digit string.
*/
if (flags & TCL_DD_SHORTEST) {
end = ShorteningQuickFormat(d, k, ilim, eps.d, retval, decpt);
} else {
end = StrictQuickFormat(d, k, ilim, eps.d, retval, decpt);
}
if (end == NULL) {
ckfree(retval);
return NULL;
}
*end = '\0';
if (endPtr != NULL) {
*endPtr = end;
}
return retval;
|
| ︙ | ︙ | |||
2819 2820 2821 2822 2823 2824 2825 |
int len, /* Number of digits to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
| | | 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 |
int len, /* Number of digits to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
char *retval = (char *)ckalloc(len + 1);
/* Output buffer. */
Tcl_WideUInt b = (bw * wuipow5[b5]) << b2;
/* Numerator of the fraction being
* converted. */
Tcl_WideUInt S = wuipow5[s5] << s2;
/* Denominator of the fraction being
* converted. */
|
| ︙ | ︙ | |||
2969 2970 2971 2972 2973 2974 2975 | * of the terminal null byte in '*endPtr'. * *---------------------------------------------------------------------- */ static inline char * StrictInt64Conversion( | < | | 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 |
* of the terminal null byte in '*endPtr'.
*
*----------------------------------------------------------------------
*/
static inline char *
StrictInt64Conversion(
Tcl_WideUInt bw, /* Integer significand. */
int b2, int b5, /* Scale factor for the significand in the
* numerator. */
int s2, int s5, /* Scale factors for the denominator. */
int k, /* Number of output digits before the decimal
* point. */
int len, /* Number of digits to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
char *retval = (char *)ckalloc(len + 1);
/* Output buffer. */
Tcl_WideUInt b = (bw * wuipow5[b5]) << b2;
/* Numerator of the fraction being
* converted. */
Tcl_WideUInt S = wuipow5[s5] << s2;
/* Denominator of the fraction being
* converted. */
|
| ︙ | ︙ | |||
3062 3063 3064 3065 3066 3067 3068 | /* *---------------------------------------------------------------------- * * ShouldBankerRoundUpPowD -- * * Test whether bankers' rounding should round a digit up. Assumption is * made that the denominator of the fraction being tested is a power of | | | | 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 |
/*
*----------------------------------------------------------------------
*
* ShouldBankerRoundUpPowD --
*
* Test whether bankers' rounding should round a digit up. Assumption is
* made that the denominator of the fraction being tested is a power of
* 2**MP_DIGIT_BIT.
*
* Results:
* Returns 1 iff the fraction is more than 1/2, or if the fraction is
* exactly 1/2 and the digit is odd.
*
*----------------------------------------------------------------------
*/
static inline int
ShouldBankerRoundUpPowD(
mp_int *b, /* Numerator of the fraction. */
int sd, /* Denominator is 2**(sd*MP_DIGIT_BIT). */
int isodd) /* 1 if the digit is odd, 0 if even. */
{
int i;
static const mp_digit topbit = ((mp_digit)1) << (MP_DIGIT_BIT - 1);
if (b->used < sd || (b->dp[sd-1] & topbit) == 0) {
return 0;
|
| ︙ | ︙ | |||
3113 3114 3115 3116 3117 3118 3119 |
*----------------------------------------------------------------------
*/
static inline int
ShouldBankerRoundUpToNextPowD(
mp_int *b, /* Numerator of the fraction. */
mp_int *m, /* Numerator of the rounding tolerance. */
| | | < | | 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 |
*----------------------------------------------------------------------
*/
static inline int
ShouldBankerRoundUpToNextPowD(
mp_int *b, /* Numerator of the fraction. */
mp_int *m, /* Numerator of the rounding tolerance. */
int sd, /* Common denominator is 2**(sd*MP_DIGIT_BIT). */
int isodd, /* 1 if the integer significand is odd. */
mp_int *temp) /* Work area for the calculation. */
{
int i;
/*
* Compare B and S-m - which is the same as comparing B+m and S - which we
* do by computing b+m and doing a bitwhack compare against
* 2**(MP_DIGIT_BIT*sd)
*/
if ((mp_add(b, m, temp) != MP_OKAY) || (temp->used <= sd)) { /* Too few digits to be > s */
return 0;
}
if (temp->used > sd+1 || temp->dp[sd] > 1) {
/* >= 2s */
return 1;
}
for (i = sd-1; i >= 0; --i) {
|
| ︙ | ︙ | |||
3150 3151 3152 3153 3154 3155 3156 | *---------------------------------------------------------------------- * * ShorteningBignumConversionPowD -- * * Converts a double-precision number to the shortest string of digits * that reconverts exactly to the given number, or to 'ilim' digits if * that will yield a shorter result. The denominator in David Gay's | | | 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 | *---------------------------------------------------------------------- * * ShorteningBignumConversionPowD -- * * Converts a double-precision number to the shortest string of digits * that reconverts exactly to the given number, or to 'ilim' digits if * that will yield a shorter result. The denominator in David Gay's * conversion algorithm is known to be a power of 2**MP_DIGIT_BIT, and hence * the division in the main loop may be replaced by a digit shift and * mask. * * Results: * Returns the string of significant decimal digits, in newly allocated * memory * |
| ︙ | ︙ | |||
3184 3185 3186 3187 3188 3189 3190 |
int len, /* Number of digits to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
| | > | > > | > > > | > | > | | > | > > | > | | > | | > > | | > | | 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 |
int len, /* Number of digits to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
char *retval = (char *)ckalloc(len + 1);
/* Output buffer. */
mp_int b; /* Numerator of the fraction being
* converted. */
mp_int mplus, mminus; /* Bounds for roundoff. */
mp_digit digit; /* Current output digit. */
char *s = retval; /* Cursor in the output buffer. */
int i; /* Index in the output buffer. */
mp_int temp;
int r1;
mp_err err = MP_OKAY;
/*
* b = bw * 2**b2 * 5**b5
* mminus = 5**m5
*/
if ((retval == NULL) || (mp_init_u64(&b, bw) != MP_OKAY)) {
return NULL;
}
if (mp_init_set(&mminus, 1) != MP_OKAY) {
mp_clear(&b);
return NULL;
}
err = MulPow5(&b, b5, &b);
if (err == MP_OKAY) {
err = mp_mul_2d(&b, b2, &b);
}
/*
* Adjust if the logarithm was guessed wrong.
*/
if ((err == MP_OKAY) && (b.used <= sd)) {
err = mp_mul_d(&b, 10, &b);
++m2plus; ++m2minus; ++m5;
ilim = ilim1;
--k;
}
/*
* mminus = 5**m5 * 2**m2minus
* mplus = 5**m5 * 2**m2plus
*/
if (err == MP_OKAY) {
err = mp_mul_2d(&mminus, m2minus, &mminus);
}
if (err == MP_OKAY) {
err = MulPow5(&mminus, m5, &mminus);
}
if ((err == MP_OKAY) && (m2plus > m2minus)) {
err = mp_init_copy(&mplus, &mminus);
if (err == MP_OKAY) {
err = mp_mul_2d(&mplus, m2plus-m2minus, &mplus);
}
}
if (err == MP_OKAY) {
err = mp_init(&temp);
}
/*
* Loop through the digits. Do division and mod by s == 2**(sd*MP_DIGIT_BIT)
* by mp_digit extraction.
*/
i = 0;
for (;;) {
if (b.used <= sd) {
digit = 0;
|
| ︙ | ︙ | |||
3309 3310 3311 3312 3313 3314 3315 | break; } /* * Advance to the next digit. */ | > | > > | > | | | | < | > | > > | > | > | | | | | 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 |
break;
}
/*
* Advance to the next digit.
*/
if (err == MP_OKAY) {
err = mp_mul_d(&b, 10, &b);
}
if (err == MP_OKAY) {
err = mp_mul_d(&mminus, 10, &mminus);
}
if ((err == MP_OKAY) && (m2plus > m2minus)) {
err = mp_mul_2d(&mminus, m2plus-m2minus, &mplus);
}
++i;
}
/*
* Endgame - store the location of the decimal point and the end of the
* string.
*/
if (m2plus > m2minus) {
mp_clear(&mplus);
}
mp_clear_multi(&b, &mminus, &temp, NULL);
*s = '\0';
*decpt = k;
if (endPtr) {
*endPtr = s;
}
return (err == MP_OKAY) ? retval : NULL;
}
/*
*----------------------------------------------------------------------
*
* StrictBignumConversionPowD --
*
* Converts a double-precision number to a fixed-lengt string of 'ilim'
* digits (or 'ilim1' if log10(d) has been overestimated). The
* denominator in David Gay's conversion algorithm is known to be a power
* of 2**MP_DIGIT_BIT, and hence the division in the main loop may be
* replaced by a digit shift and mask.
*
* Results:
* Returns the string of significant decimal digits, in newly allocated
* memory.
*
* Side effects:
* Stores the location of the decimal point in '*decpt' and the location
* of the terminal null byte in '*endPtr'.
*
*----------------------------------------------------------------------
*/
static inline char *
StrictBignumConversionPowD(
Tcl_WideUInt bw, /* Integer significand. */
int b2, int b5, /* Scale factor for the significand in the
* numerator. */
int sd, /* Scale factor for the denominator. */
int k, /* Number of output digits before the decimal
* point. */
int len, /* Number of digits to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Position of the terminal '\0' at
* the end of the returned string. */
{
char *retval = (char *)ckalloc(len + 1);
/* Output buffer. */
mp_int b; /* Numerator of the fraction being
* converted. */
mp_digit digit; /* Current output digit. */
char *s = retval; /* Cursor in the output buffer. */
int i; /* Index in the output buffer. */
mp_err err;
/*
* b = bw * 2**b2 * 5**b5
*/
if (mp_init_u64(&b, bw) != MP_OKAY) {
return NULL;
}
err = MulPow5(&b, b5, &b);
if (err == MP_OKAY) {
err = mp_mul_2d(&b, b2, &b);
}
/*
* Adjust if the logarithm was guessed wrong.
*/
if ((err == MP_OKAY) && (b.used <= sd)) {
err = mp_mul_d(&b, 10, &b);
ilim = ilim1;
--k;
}
/*
* Loop through the digits. Do division and mod by s == 2**(sd*MP_DIGIT_BIT)
* by mp_digit extraction.
*/
i = 1;
while (err == MP_OKAY) {
if (b.used <= sd) {
digit = 0;
} else {
digit = b.dp[sd];
if (b.used > sd+1 || digit >= 10) {
Tcl_Panic("wrong digit!");
}
|
| ︙ | ︙ | |||
3436 3437 3438 3439 3440 3441 3442 | break; } /* * Advance to the next digit. */ | | | 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 |
break;
}
/*
* Advance to the next digit.
*/
err = mp_mul_d(&b, 10, &b);
++i;
}
/*
* Endgame - store the location of the decimal point and the end of the
* string.
*/
|
| ︙ | ︙ | |||
3518 3519 3520 3521 3522 3523 3524 |
int r;
mp_int temp;
/*
* Compare b and S-m: this is the same as comparing B+m and S.
*/
| | | > | 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 |
int r;
mp_int temp;
/*
* Compare b and S-m: this is the same as comparing B+m and S.
*/
if ((mp_init(&temp) != MP_OKAY) || (mp_add(b, m, &temp) != MP_OKAY)) {
return 0;
}
r = mp_cmp_mag(&temp, S);
mp_clear(&temp);
switch(r) {
case MP_LT:
return 0;
case MP_EQ:
return isodd;
|
| ︙ | ︙ | |||
3566 3567 3568 3569 3570 3571 3572 |
int k, /* Guessed position of the decimal point. */
int len, /* Size of the digit buffer to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Pointer to the end of the number */
{
| | > | > > | > | > > > > > | > | | > | > > | > | | > | > > | > | | | | 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 |
int k, /* Guessed position of the decimal point. */
int len, /* Size of the digit buffer to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Pointer to the end of the number */
{
char *retval = (char *)ckalloc(len+1);
/* Buffer of digits to return. */
char *s = retval; /* Cursor in the return value. */
mp_int b; /* Numerator of the result. */
mp_int mminus; /* 1/2 ulp below the result. */
mp_int mplus; /* 1/2 ulp above the result. */
mp_int S; /* Denominator of the result. */
mp_int dig; /* Current digit of the result. */
int digit; /* Current digit of the result. */
int minit = 1; /* Fudge factor for when we misguess k. */
int i;
int r1;
mp_err err;
/*
* b = bw * 2**b2 * 5**b5
* S = 2**s2 * 5*s5
*/
if ((retval == NULL) || (mp_init_u64(&b, bw) != MP_OKAY)) {
return NULL;
}
err = mp_mul_2d(&b, b2, &b);
if (err == MP_OKAY) {
err = mp_init_set(&S, 1);
}
if (err == MP_OKAY) {
err = MulPow5(&S, s5, &S);
}
if (err == MP_OKAY) {
err = mp_mul_2d(&S, s2, &S);
}
/*
* Handle the case where we guess the position of the decimal point wrong.
*/
if ((err == MP_OKAY) && (mp_cmp_mag(&b, &S) == MP_LT)) {
err = mp_mul_d(&b, 10, &b);
minit = 10;
ilim =ilim1;
--k;
}
/*
* mminus = 2**m2minus * 5**m5
*/
if (err == MP_OKAY) {
err = mp_init_set(&mminus, minit);
}
if (err == MP_OKAY) {
err = mp_mul_2d(&mminus, m2minus, &mminus);
}
if ((err == MP_OKAY) && (m2plus > m2minus)) {
err = mp_init_copy(&mplus, &mminus);
if (err == MP_OKAY) {
err = mp_mul_2d(&mplus, m2plus-m2minus, &mplus);
}
}
/*
* Loop through the digits.
*/
if (err == MP_OKAY) {
err = mp_init(&dig);
}
i = 1;
while (err == MP_OKAY) {
err = mp_div(&b, &S, &dig, &b);
if (dig.used > 1 || dig.dp[0] >= 10) {
Tcl_Panic("wrong digit!");
}
digit = dig.dp[0];
/*
* Does the current digit leave us with a remainder small enough to
* round to it?
*/
r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus);
if (r1 == MP_LT || (r1 == MP_EQ && (dPtr->w.word1 & 1) == 0)) {
err = mp_mul_2d(&b, 1, &b);
if (ShouldBankerRoundUp(&b, &S, digit&1)) {
++digit;
if (digit == 10) {
*s++ = '9';
s = BumpUp(s, retval, &k);
break;
}
|
| ︙ | ︙ | |||
3666 3667 3668 3669 3670 3671 3672 | } /* * Have we converted all the requested digits? */ *s++ = '0' + digit; | | | | | > | > | | > | > | 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 |
}
/*
* Have we converted all the requested digits?
*/
*s++ = '0' + digit;
if ((err == MP_OKAY) && (i == ilim)) {
err = mp_mul_2d(&b, 1, &b);
if (ShouldBankerRoundUp(&b, &S, digit&1)) {
s = BumpUp(s, retval, &k);
}
break;
}
/*
* Advance to the next digit.
*/
if ((err == MP_OKAY) && (s5 > 0)) {
/*
* Can possibly shorten the denominator.
*/
err = mp_mul_2d(&b, 1, &b);
if (err == MP_OKAY) {
err = mp_mul_2d(&mminus, 1, &mminus);
}
if ((err == MP_OKAY) && (m2plus > m2minus)) {
err = mp_mul_2d(&mplus, 1, &mplus);
}
if (err == MP_OKAY) {
err = mp_div_d(&S, 5, &S, NULL);
}
--s5;
/*
* IDEA: It might possibly be a win to fall back to int64_t
* arithmetic here if S < 2**64/10. But it's a win only for
* a fairly narrow range of magnitudes so perhaps not worth
* bothering. We already know that we shorten the
|
| ︙ | ︙ | |||
3718 3719 3720 3721 3722 3723 3724 | * 10**38 12 trips * 10**39 13 trips * 10**40 14 trips * 10**41 15 trips * 10**42 16 trips * thereafter no gain. */ | | | > | > | | | 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 |
* 10**38 12 trips
* 10**39 13 trips
* 10**40 14 trips
* 10**41 15 trips
* 10**42 16 trips
* thereafter no gain.
*/
} else if (err == MP_OKAY) {
err = mp_mul_d(&b, 10, &b);
if (err == MP_OKAY) {
err = mp_mul_d(&mminus, 10, &mminus);
}
if ((err == MP_OKAY) && (m2plus > m2minus)) {
err = mp_mul_2d(&mplus, 10, &mplus);
}
}
++i;
}
/*
|
| ︙ | ︙ | |||
3766 3767 3768 3769 3770 3771 3772 | * to the end of the number in *endPtr. * *---------------------------------------------------------------------- */ static inline char * StrictBignumConversion( | < | > > | > | > > > | > | > > > > | > > | < | < | | | | > | > | > | > | | < | | 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 4240 4241 4242 4243 4244 |
* to the end of the number in *endPtr.
*
*----------------------------------------------------------------------
*/
static inline char *
StrictBignumConversion(
Tcl_WideUInt bw, /* Integer significand and exponent. */
int b2, /* Scale factor for the significand. */
int s2, int s5, /* Scale factors for denominator. */
int k, /* Guessed position of the decimal point. */
int len, /* Size of the digit buffer to allocate. */
int ilim, /* Number of digits to convert if b >= s */
int ilim1, /* Number of digits to convert if b < s */
int *decpt, /* OUTPUT: Position of the decimal point. */
char **endPtr) /* OUTPUT: Pointer to the end of the number */
{
char *retval = (char *)ckalloc(len+1);
/* Buffer of digits to return. */
char *s = retval; /* Cursor in the return value. */
mp_int b; /* Numerator of the result. */
mp_int S; /* Denominator of the result. */
mp_int dig; /* Current digit of the result. */
int digit; /* Current digit of the result. */
int g; /* Size of the current digit ground. */
int i, j;
mp_err err;
/*
* b = bw * 2**b2 * 5**b5
* S = 2**s2 * 5*s5
*/
if (mp_init(&dig) != MP_OKAY) {
return NULL;
}
if (mp_init_u64(&b, bw) != MP_OKAY) {
mp_clear(&dig);
return NULL;
}
err = mp_mul_2d(&b, b2, &b);
if (err == MP_OKAY) {
err = mp_init_set(&S, 1);
}
if (err == MP_OKAY) {
err = MulPow5(&S, s5, &S);
if (err == MP_OKAY) {
err = mp_mul_2d(&S, s2, &S);
}
}
/*
* Handle the case where we guess the position of the decimal point wrong.
*/
if ((mp_cmp_mag(&b, &S) == MP_LT) && (mp_mul_d(&b, 10, &b) == MP_OKAY)) {
ilim =ilim1;
--k;
}
/*
* Convert the leading digit.
*/
i = 0;
err = mp_div(&b, &S, &dig, &b);
if (dig.used > 1 || dig.dp[0] >= 10) {
Tcl_Panic("wrong digit!");
}
digit = dig.dp[0];
/*
* Is a single digit all that was requested?
*/
*s++ = '0' + digit;
if (++i >= ilim) {
if ((mp_mul_2d(&b, 1, &b) == MP_OKAY) && ShouldBankerRoundUp(&b, &S, digit&1)) {
s = BumpUp(s, retval, &k);
}
} else {
while (err == MP_OKAY) {
/*
* Shift by a group of digits.
*/
g = ilim - i;
if (g > DIGIT_GROUP) {
g = DIGIT_GROUP;
}
if (s5 >= g) {
err = mp_div_d(&S, dpow5[g], &S, NULL);
s5 -= g;
} else if (s5 > 0) {
err = mp_div_d(&S, dpow5[s5], &S, NULL);
if (err == MP_OKAY) {
err = mp_mul_d(&b, dpow5[g - s5], &b);
}
s5 = 0;
} else {
err = mp_mul_d(&b, dpow5[g], &b);
}
if (err == MP_OKAY) {
err = mp_mul_2d(&b, g, &b);
}
/*
* As with the shortening bignum conversion, it's possible at this
* point that we will have reduced the denominator to less than
* 2**64/10, at which point it would be possible to fall back to
* to int64_t arithmetic. But the potential payoff is tremendously
* less - unless we're working in F format - because we know that
* three groups of digits will always suffice for %#.17e, the
* longest format that doesn't introduce empty precision.
*
* Extract the next group of digits.
*/
if ((err != MP_OKAY) || (mp_div(&b, &S, &dig, &b) != MP_OKAY) || (dig.used > 1)) {
Tcl_Panic("wrong digit!");
}
digit = dig.dp[0];
for (j = g-1; j >= 0; --j) {
int t = itens[j];
*s++ = digit / t + '0';
digit %= t;
}
i += g;
/*
* Have we converted all the requested digits?
*/
if (i == ilim) {
if ((mp_mul_2d(&b, 1, &b) == MP_OKAY) && ShouldBankerRoundUp(&b, &S, digit&1)) {
s = BumpUp(s, retval, &k);
}
break;
}
}
}
while (*--s == '0') {
|
| ︙ | ︙ | |||
3929 3930 3931 3932 3933 3934 3935 | * endPtr to point to the terminating '\0' byte of the string. Sets *sign * to 1 if a minus sign should be printed with the number, or 0 if a plus * sign (or no sign) should appear. * * This function is a service routine that produces the string of digits for * floating-point-to-decimal conversion. It can do a number of things * according to the 'flags' argument. Valid values for 'flags' include: | | | > | | | | 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 | * endPtr to point to the terminating '\0' byte of the string. Sets *sign * to 1 if a minus sign should be printed with the number, or 0 if a plus * sign (or no sign) should appear. * * This function is a service routine that produces the string of digits for * floating-point-to-decimal conversion. It can do a number of things * according to the 'flags' argument. Valid values for 'flags' include: * TCL_DD_SHORTEST - This is the default for floating point conversion if * ::tcl_precision is 0. It constructs the shortest string of * digits that will reconvert to the given number when scanned. * For floating point numbers that are exactly between two * decimal numbers, it resolves using the 'round to even' rule. * With this value, the 'ndigits' parameter is ignored. * TCL_DD_E_FORMAT - This value is used to prepare numbers for %e format * conversion (or for default floating->string if tcl_precision * is not 0). It constructs a string of at most 'ndigits' digits, * choosing the one that is closest to the given number (and * resolving ties with 'round to even'). It is allowed to return * fewer than 'ndigits' if the number converts exactly; if the * TCL_DD_E_FORMAT|TCL_DD_SHORTEST is supplied instead, it * also returns fewer digits if the shorter string will still * reconvert without loss to the given input number. In any case, * strings of trailing zeroes are suppressed. * TCL_DD_F_FORMAT - This value is used to prepare numbers for %f format * conversion. It requests that conversion proceed until * 'ndigits' digits after the decimal point have been converted. * It is possible for this format to result in a zero-length * string if the number is sufficiently small. Again, it is * permissible for TCL_DD_F_FORMAT to return fewer digits for a * number that converts exactly, and changing the argument to * TCL_DD_F_FORMAT|TCL_DD_SHORTEST will allow the routine * also to return fewer digits if the shorter string will still * reconvert without loss to the given input number. Strings of * trailing zeroes are suppressed. * * To any of these flags may be OR'ed TCL_DD_NO_QUICK; this flag requires * all calculations to be done in exact arithmetic. Normally, E and F * format with fewer than about 14 digits will be done with a quick |
| ︙ | ︙ | |||
4088 4089 4090 4091 4092 4093 4094 |
* side, and
* m- = (2**m2minus * 5**m5) / (2**s2 * 5**s5) is the limit on the low
* side.
* We may need to increase s2 to put m2plus, m2minus, b2 over a common
* denominator.
*/
| | | 4437 4438 4439 4440 4441 4442 4443 4444 4445 4446 4447 4448 4449 4450 4451 |
* side, and
* m- = (2**m2minus * 5**m5) / (2**s2 * 5**s5) is the limit on the low
* side.
* We may need to increase s2 to put m2plus, m2minus, b2 over a common
* denominator.
*/
if (flags & TCL_DD_SHORTEST) {
int m2minus = b2;
int m2plus;
int m5 = b5;
int len = i;
/*
* Find the quantity i so that (2**i*5**b5)/(2**s2*5**s5) is 1/2 unit
|
| ︙ | ︙ | |||
4140 4141 4142 4143 4144 4145 4146 |
*/
return ShorteningInt64Conversion(&d, bw, b2, b5, m2plus,
m2minus, m5, s2, s5, k, len, ilim, ilim1, decpt, endPtr);
} else if (s5 == 0) {
/*
* The denominator is a power of 2, so we can replace division by
| | | 4489 4490 4491 4492 4493 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 |
*/
return ShorteningInt64Conversion(&d, bw, b2, b5, m2plus,
m2minus, m5, s2, s5, k, len, ilim, ilim1, decpt, endPtr);
} else if (s5 == 0) {
/*
* The denominator is a power of 2, so we can replace division by
* digit shifts. First we round up s2 to a multiple of MP_DIGIT_BIT,
* and adjust m2 and b2 accordingly. Then we launch into a version
* of the comparison that's specialized for the 'power of mp_digit
* in the denominator' case.
*/
if (s2 % MP_DIGIT_BIT != 0) {
int delta = MP_DIGIT_BIT - (s2 % MP_DIGIT_BIT);
|
| ︙ | ︙ | |||
4191 4192 4193 4194 4195 4196 4197 | /* * If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word, * then all our intermediate calculations can be done using exact * 64-bit arithmetic with no need for expensive multiprecision * operations. */ | | | | | | 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 |
/*
* If 10*2**s2*5**s5 == 2**(s2+1)+5**(s5+1) fits in a 64-bit word,
* then all our intermediate calculations can be done using exact
* 64-bit arithmetic with no need for expensive multiprecision
* operations.
*/
return StrictInt64Conversion(bw, b2, b5, s2, s5, k,
len, ilim, ilim1, decpt, endPtr);
} else if (s5 == 0) {
/*
* The denominator is a power of 2, so we can replace division by
* digit shifts. First we round up s2 to a multiple of MP_DIGIT_BIT,
* and adjust m2 and b2 accordingly. Then we launch into a version
* of the comparison that's specialized for the 'power of mp_digit
* in the denominator' case.
*/
if (s2 % MP_DIGIT_BIT != 0) {
int delta = MP_DIGIT_BIT - (s2 % MP_DIGIT_BIT);
b2 += delta;
s2 += delta;
}
return StrictBignumConversionPowD(bw, b2, b5,
s2/MP_DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr);
} else {
/*
* There are no helpful special cases, but at least we know in
* advance how many digits we will convert. We can run the
* conversion in steps of DIGIT_GROUP digits, so as to have many
* fewer mp_int divisions.
*/
return StrictBignumConversion(bw, b2, s2, s5, k,
len, ilim, ilim1, decpt, endPtr);
}
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 |
double d;
#ifdef IEEE_FLOATING_POINT
union {
double dv;
Tcl_WideUInt iv;
} bitwhack;
#endif
#if defined(__sgi) && defined(_COMPILER_VERSION)
union fpc_csr mipsCR;
mipsCR.fc_word = get_fpc_csr();
mipsCR.fc_struct.flush = 0;
set_fpc_csr(mipsCR.fc_word);
#endif
/*
* Initialize table of powers of 10 expressed as wide integers.
*/
maxpow10_wide = (int)
floor(sizeof(Tcl_WideUInt) * CHAR_BIT * log(2.) / log(10.));
| > > | | 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 |
double d;
#ifdef IEEE_FLOATING_POINT
union {
double dv;
Tcl_WideUInt iv;
} bitwhack;
#endif
mp_err err = MP_OKAY;
#if defined(__sgi) && defined(_COMPILER_VERSION)
union fpc_csr mipsCR;
mipsCR.fc_word = get_fpc_csr();
mipsCR.fc_struct.flush = 0;
set_fpc_csr(mipsCR.fc_word);
#endif
/*
* Initialize table of powers of 10 expressed as wide integers.
*/
maxpow10_wide = (int)
floor(sizeof(Tcl_WideUInt) * CHAR_BIT * log(2.) / log(10.));
pow10_wide = (Tcl_WideUInt *)
ckalloc((maxpow10_wide + 1) * sizeof(Tcl_WideUInt));
u = 1;
for (i = 0; i < maxpow10_wide; ++i) {
pow10_wide[i] = u;
u *= 10;
}
pow10_wide[i] = u;
|
| ︙ | ︙ | |||
4311 4312 4313 4314 4315 4316 4317 |
}
/*
* Initialize a table of large powers of five.
*/
for (i=0; i<9; ++i) {
| | | | | | | > > > | 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 |
}
/*
* Initialize a table of large powers of five.
*/
for (i=0; i<9; ++i) {
err = err || mp_init(pow5 + i);
}
mp_set_u64(pow5, 5);
for (i=0; i<8; ++i) {
err = err || mp_sqr(pow5+i, pow5+i+1);
}
err = err || mp_init_u64(pow5_13, 1220703125);
for (i = 1; i < 5; ++i) {
err = err || mp_init(pow5_13 + i);
err = err || mp_sqr(pow5_13 + i - 1, pow5_13 + i);
}
if (err != MP_OKAY) {
Tcl_Panic("out of memory");
}
/*
* Determine the number of decimal digits to the left and right of the
* decimal point in the largest and smallest double, the smallest double
* that differs from zero, and the number of mp_digits needed to represent
* the significand of a double.
|
| ︙ | ︙ | |||
4346 4347 4348 4349 4350 4351 4352 |
* integers), but the two words of a 'double' are presented most
* significant word first.
*/
#ifdef IEEE_FLOATING_POINT
bitwhack.dv = 1.000000238418579;
/* 3ff0 0000 4000 0000 */
| | | | 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 |
* integers), but the two words of a 'double' are presented most
* significant word first.
*/
#ifdef IEEE_FLOATING_POINT
bitwhack.dv = 1.000000238418579;
/* 3ff0 0000 4000 0000 */
if ((bitwhack.iv >> 32) == 0x3FF00000) {
n770_fp = 0;
} else if ((bitwhack.iv & 0xFFFFFFFF) == 0x3FF00000) {
n770_fp = 1;
} else {
Tcl_Panic("unknown floating point word order on this machine");
}
#endif
}
|
| ︙ | ︙ | |||
4377 4378 4379 4380 4381 4382 4383 |
*/
void
TclFinalizeDoubleConversion(void)
{
int i;
| | | 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 |
*/
void
TclFinalizeDoubleConversion(void)
{
int i;
ckfree(pow10_wide);
for (i=0; i<9; ++i) {
mp_clear(pow5 + i);
}
for (i=0; i < 5; ++i) {
mp_clear(pow5_13 + i);
}
}
|
| ︙ | ︙ | |||
4408 4409 4410 4411 4412 4413 4414 |
*----------------------------------------------------------------------
*/
int
Tcl_InitBignumFromDouble(
Tcl_Interp *interp, /* For error message. */
double d, /* Number to convert. */
| | > > | | > > | | | > > > | 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 |
*----------------------------------------------------------------------
*/
int
Tcl_InitBignumFromDouble(
Tcl_Interp *interp, /* For error message. */
double d, /* Number to convert. */
void *big) /* Place to store the result. */
{
double fract;
int expt;
mp_err err;
mp_int *b = (mp_int *)big;
/*
* Infinite values can't convert to bignum.
*/
if (TclIsInfinite(d)) {
if (interp != NULL) {
const char *s = "integer value too large to represent";
Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL);
}
return TCL_ERROR;
}
fract = frexp(d, &expt);
if (expt <= 0) {
err = mp_init(b);
mp_zero(b);
} else {
Tcl_WideInt w = (Tcl_WideInt) ldexp(fract, mantBits);
int shift = expt - mantBits;
err = mp_init_i64(b, w);
if (err != MP_OKAY) {
/* just skip */
} else if (shift < 0) {
err = mp_div_2d(b, -shift, b, NULL);
} else if (shift > 0) {
err = mp_mul_2d(b, shift, b);
}
}
if (err != MP_OKAY) {
return TCL_ERROR;
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4462 4463 4464 4465 4466 4467 4468 | * too large to convert. * *---------------------------------------------------------------------- */ double TclBignumToDouble( | | > > | | | | > > | | | | | | | | | | > > | | | > > > | | | | | > > | | | > > | | | > | > | | | | > > > | 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 4893 4894 4895 4896 4897 4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 4920 4921 4922 4923 4924 4925 4926 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 4948 4949 4950 4951 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 |
* too large to convert.
*
*----------------------------------------------------------------------
*/
double
TclBignumToDouble(
const void *big) /* Integer to convert. */
{
mp_int b;
int bits, shift, i, lsb;
double r;
mp_err err;
const mp_int *a = (const mp_int *)big;
/*
* We need a 'mantBits'-bit significand. Determine what shift will
* give us that.
*/
bits = mp_count_bits(a);
if (bits > DBL_MAX_EXP*log2FLT_RADIX) {
errno = ERANGE;
if (mp_isneg(a)) {
return -HUGE_VAL;
} else {
return HUGE_VAL;
}
}
shift = mantBits - bits;
/*
* If shift > 0, shift the significand left by the requisite number of
* bits. If shift == 0, the significand is already exactly 'mantBits'
* in length. If shift < 0, we will need to shift the significand right
* by the requisite number of bits, and round it. If the '1-shift'
* least significant bits are 0, but the 'shift'th bit is nonzero,
* then the significand lies exactly between two values and must be
* 'rounded to even'.
*/
err = mp_init(&b);
if (err != MP_OKAY) {
/* just skip */
} else if (shift == 0) {
err = mp_copy(a, &b);
} else if (shift > 0) {
err = mp_mul_2d(a, shift, &b);
} else if (shift < 0) {
lsb = mp_cnt_lsb(a);
if (lsb == -1-shift) {
/*
* Round to even
*/
err = mp_div_2d(a, -shift, &b, NULL);
if ((err == MP_OKAY) && mp_isodd(&b)) {
if (mp_isneg(&b)) {
err = mp_sub_d(&b, 1, &b);
} else {
err = mp_add_d(&b, 1, &b);
}
}
} else {
/*
* Ordinary rounding
*/
err = mp_div_2d(a, -1-shift, &b, NULL);
if (err != MP_OKAY) {
/* just skip */
} else if (mp_isneg(&b)) {
err = mp_sub_d(&b, 1, &b);
} else {
err = mp_add_d(&b, 1, &b);
}
err = mp_div_2d(&b, 1, &b, NULL);
}
}
/*
* Accumulate the result, one mp_digit at a time.
*/
if (err != MP_OKAY) {
return 0.0;
}
r = 0.0;
for (i = b.used-1; i>=0; --i) {
r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
}
mp_clear(&b);
/*
* Scale the result to the correct number of bits.
*/
r = ldexp(r, bits - mantBits);
/*
* Return the result with the appropriate sign.
*/
if (mp_isneg(a)) {
return -r;
} else {
return r;
}
}
/*
*----------------------------------------------------------------------
*
* TclCeil --
*
* Computes the smallest floating point number that is at least the
* mp_int argument.
*
* Results:
* Returns the floating point number.
*
*----------------------------------------------------------------------
*/
double
TclCeil(
const void *big) /* Integer to convert. */
{
double r = 0.0;
mp_int b;
mp_err err;
const mp_int *a = (const mp_int *)big;
err = mp_init(&b);
if ((err == MP_OKAY) && mp_isneg(a)) {
err = mp_neg(a, &b);
r = -TclFloor(&b);
} else {
int bits = mp_count_bits(a);
if (bits > DBL_MAX_EXP*log2FLT_RADIX) {
r = HUGE_VAL;
} else {
int i, exact = 1, shift = mantBits - bits;
if (err != MP_OKAY) {
/* just skip */
} else if (shift > 0) {
err = mp_mul_2d(a, shift, &b);
} else if (shift < 0) {
mp_int d;
err = mp_init(&d);
if (err == MP_OKAY) {
err = mp_div_2d(a, -shift, &b, &d);
}
exact = mp_iszero(&d);
mp_clear(&d);
} else {
err = mp_copy(a, &b);
}
if ((err == MP_OKAY) && !exact) {
err = mp_add_d(&b, 1, &b);
}
if (err != MP_OKAY) {
return 0.0;
}
for (i=b.used-1 ; i>=0 ; --i) {
r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
}
r = ldexp(r, bits - mantBits);
}
}
|
| ︙ | ︙ | |||
4632 4633 4634 4635 4636 4637 4638 | * Returns the floating point value. * *---------------------------------------------------------------------- */ double TclFloor( | | > > | | | | | | > > > | 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 |
* Returns the floating point value.
*
*----------------------------------------------------------------------
*/
double
TclFloor(
const void *big) /* Integer to convert. */
{
double r = 0.0;
mp_int b;
mp_err err;
const mp_int *a = (const mp_int *)big;
err = mp_init(&b);
if ((err == MP_OKAY) && mp_isneg(a)) {
err = mp_neg(a, &b);
r = -TclCeil(&b);
} else {
int bits = mp_count_bits(a);
if (bits > DBL_MAX_EXP*log2FLT_RADIX) {
r = DBL_MAX;
} else {
int i, shift = mantBits - bits;
if (shift > 0) {
err = mp_mul_2d(a, shift, &b);
} else if (shift < 0) {
err = mp_div_2d(a, -shift, &b, NULL);
} else {
err = mp_copy(a, &b);
}
if (err != MP_OKAY) {
return 0.0;
}
for (i=b.used-1 ; i>=0 ; --i) {
r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
}
r = ldexp(r, bits - mantBits);
}
}
|
| ︙ | ︙ | |||
4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 |
int *machexp) /* Power of two. */
{
mp_int b;
int bits;
int shift;
int i;
double r;
/*
* Determine how many bits we need, and extract that many from the input.
* Round to nearest unit in the last place.
*/
bits = mp_count_bits(a);
shift = mantBits - 2 - bits;
| > | > > | | | > | | > | | 5080 5081 5082 5083 5084 5085 5086 5087 5088 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 5114 5115 5116 5117 5118 5119 5120 5121 5122 5123 5124 5125 5126 5127 5128 5129 5130 5131 |
int *machexp) /* Power of two. */
{
mp_int b;
int bits;
int shift;
int i;
double r;
mp_err err = MP_OKAY;
/*
* Determine how many bits we need, and extract that many from the input.
* Round to nearest unit in the last place.
*/
bits = mp_count_bits(a);
shift = mantBits - 2 - bits;
if (mp_init(&b)) {
return 0.0;
}
if (shift > 0) {
err = mp_mul_2d(a, shift, &b);
} else if (shift < 0) {
err = mp_div_2d(a, -shift, &b, NULL);
} else {
err = mp_copy(a, &b);
}
/*
* Accumulate the result, one mp_digit at a time.
*/
r = 0.0;
if (err == MP_OKAY) {
for (i=b.used-1; i>=0; --i) {
r = ldexp(r, MP_DIGIT_BIT) + b.dp[i];
}
}
mp_clear(&b);
/*
* Return the result with the appropriate sign.
*/
*machexp = bits - mantBits + 2;
return (mp_isneg(a) ? -r : r);
}
/*
*----------------------------------------------------------------------
*
* Pow10TimesFrExp --
*
|
| ︙ | ︙ | |||
4767 4768 4769 4770 4771 4772 4773 |
double retval = fraction;
if (exponent > 0) {
/*
* Multiply by 10**exponent.
*/
| | | | 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 |
double retval = fraction;
if (exponent > 0) {
/*
* Multiply by 10**exponent.
*/
retval = frexp(retval * pow10vals[exponent & 0xF], &j);
expt += j;
for (i=4; i<9; ++i) {
if (exponent & (1<<i)) {
retval = frexp(retval * pow_10_2_n[i], &j);
expt += j;
}
}
} else if (exponent < 0) {
/*
* Divide by 10**-exponent.
*/
retval = frexp(retval / pow10vals[(-exponent) & 0xF], &j);
expt += j;
for (i=4; i<9; ++i) {
if ((-exponent) & (1<<i)) {
retval = frexp(retval / pow_10_2_n[i], &j);
expt += j;
}
}
|
| ︙ | ︙ | |||
4896 4897 4898 4899 4900 4901 4902 |
*----------------------------------------------------------------------
*/
#ifdef IEEE_FLOATING_POINT
static Tcl_WideUInt
Nokia770Twiddle(
Tcl_WideUInt w) /* Number to transpose. */
{
| | | 5285 5286 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 |
*----------------------------------------------------------------------
*/
#ifdef IEEE_FLOATING_POINT
static Tcl_WideUInt
Nokia770Twiddle(
Tcl_WideUInt w) /* Number to transpose. */
{
return (((w >> 32) & 0xFFFFFFFF) | (w << 32));
}
#endif
/*
*----------------------------------------------------------------------
*
* TclNokia770Doubles --
|
| ︙ | ︙ |
Changes to generic/tclStringObj.c.
| ︙ | ︙ | |||
31 32 33 34 35 36 37 | * Copyright (c) 1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" | | | | | | | | | | | | | | | 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 | * Copyright (c) 1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclTomMath.h" #include "tclStringRep.h" #include "assert.h" /* * Prototypes for functions defined later in this file: */ static void AppendPrintfToObjVA(Tcl_Obj *objPtr, const char *format, va_list argList); static void AppendUnicodeToUnicodeRep(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int appendNumChars); static void AppendUnicodeToUtfRep(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); static void AppendUtfToUnicodeRep(Tcl_Obj *objPtr, const char *bytes, int numBytes); static void AppendUtfToUtfRep(Tcl_Obj *objPtr, const char *bytes, int numBytes); static void DupStringInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static int ExtendStringRepWithUnicode(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); static void ExtendUnicodeRepWithString(Tcl_Obj *objPtr, const char *bytes, int numBytes, int numAppendChars); static void FillUnicodeRep(Tcl_Obj *objPtr); static void FreeStringInternalRep(Tcl_Obj *objPtr); static void GrowStringBuffer(Tcl_Obj *objPtr, int needed, int flag); static void GrowUnicodeBuffer(Tcl_Obj *objPtr, int needed); static int SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); static int UnicodeLength(const Tcl_UniChar *unicode); static void UpdateStringOfString(Tcl_Obj *objPtr); /* * The structure below defines the string Tcl object type by means of * functions that can be invoked by generic object code. */ |
| ︙ | ︙ | |||
119 120 121 122 123 124 125 |
#ifndef TCL_MIN_UNICHAR_GROWTH
#define TCL_MIN_UNICHAR_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_UniChar)
#endif
static void
GrowStringBuffer(
Tcl_Obj *objPtr,
| | | > | | > | | | | | | > | > | | > > | > | | 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 |
#ifndef TCL_MIN_UNICHAR_GROWTH
#define TCL_MIN_UNICHAR_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_UniChar)
#endif
static void
GrowStringBuffer(
Tcl_Obj *objPtr,
int needed,
int flag)
{
/*
* Pre-conditions:
* objPtr->typePtr == &tclStringType
* needed > stringPtr->allocated
* flag || objPtr->bytes != NULL
*/
String *stringPtr = GET_STRING(objPtr);
char *ptr = NULL;
int attempt;
if (objPtr->bytes == &tclEmptyString) {
objPtr->bytes = NULL;
}
if (flag == 0 || stringPtr->allocated > 0) {
if (needed <= INT_MAX / 2) {
attempt = 2 * needed;
ptr = (char *)attemptckrealloc(objPtr->bytes, attempt + 1);
}
if (ptr == NULL) {
/*
* Take care computing the amount of modest growth to avoid
* overflow into invalid argument values for attempt.
*/
unsigned int limit = INT_MAX - needed;
unsigned int extra = needed - objPtr->length + TCL_MIN_GROWTH;
int growth = (int) ((extra > limit) ? limit : extra);
attempt = needed + growth;
ptr = (char *)attemptckrealloc(objPtr->bytes, attempt + 1);
}
}
if (ptr == NULL) {
/*
* First allocation - just big enough; or last chance fallback.
*/
attempt = needed;
ptr = (char *)ckrealloc(objPtr->bytes, attempt + 1);
}
objPtr->bytes = ptr;
stringPtr->allocated = attempt;
}
static void
GrowUnicodeBuffer(
Tcl_Obj *objPtr,
int needed)
{
/*
* Pre-conditions:
* objPtr->typePtr == &tclStringType
* needed > stringPtr->maxChars
* needed < STRING_MAXCHARS
*/
String *ptr = NULL, *stringPtr = GET_STRING(objPtr);
int attempt;
if (stringPtr->maxChars > 0) {
/*
* Subsequent appends - apply the growth algorithm.
*/
if (needed <= STRING_MAXCHARS / 2) {
attempt = 2 * needed;
ptr = stringAttemptRealloc(stringPtr, attempt);
}
if (ptr == NULL) {
/*
* Take care computing the amount of modest growth to avoid
* overflow into invalid argument values for attempt.
*/
unsigned int limit = STRING_MAXCHARS - needed;
unsigned int extra = needed - stringPtr->numChars
+ TCL_MIN_UNICHAR_GROWTH;
int growth = (int) ((extra > limit) ? limit : extra);
attempt = needed + growth;
ptr = stringAttemptRealloc(stringPtr, attempt);
}
}
if (ptr == NULL) {
/*
* First allocation - just big enough; or last chance fallback.
*/
|
| ︙ | ︙ | |||
243 244 245 246 247 248 249 |
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewStringObj
Tcl_Obj *
Tcl_NewStringObj(
const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
| | | | | > | | 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 |
#ifdef TCL_MEM_DEBUG
#undef Tcl_NewStringObj
Tcl_Obj *
Tcl_NewStringObj(
const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
int length) /* The number of bytes to copy from "bytes"
* when initializing the new object. If
* negative, use bytes up to the first NUL
* byte. */
{
return Tcl_DbNewStringObj(bytes, length, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewStringObj(
const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
int length) /* The number of bytes to copy from "bytes"
* when initializing the new object. If
* negative, use bytes up to the first NUL
* byte. */
{
Tcl_Obj *objPtr;
if (length < 0) {
length = (bytes? strlen(bytes) : 0);
}
TclNewStringObj(objPtr, bytes, length);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
|
| ︙ | ︙ | |||
303 304 305 306 307 308 309 |
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewStringObj(
const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
| | | | > | | | | > | < | < | 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 |
*/
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_DbNewStringObj(
const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
int length, /* The number of bytes to copy from "bytes"
* when initializing the new object. If
* negative, use bytes up to the first NUL
* byte. */
const char *file, /* The name of the source file calling this
* function; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
Tcl_Obj *objPtr;
if (length < 0) {
length = (bytes? strlen(bytes) : 0);
}
TclDbNewObj(objPtr, file, line);
TclInitStringRep(objPtr, bytes, length);
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewStringObj(
const char *bytes, /* Points to the first of the length bytes
* used to initialize the new object. */
int length, /* The number of bytes to copy from "bytes"
* when initializing the new object. If
* negative, use bytes up to the first NUL
* byte. */
TCL_UNUSED(const char *) /*file*/,
TCL_UNUSED(int) /*line*/)
{
return Tcl_NewStringObj(bytes, length);
}
#endif /* TCL_MEM_DEBUG */
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
360 361 362 363 364 365 366 |
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_NewUnicodeObj(
const Tcl_UniChar *unicode, /* The unicode string used to initialize the
* new object. */
| | | 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 |
*---------------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_NewUnicodeObj(
const Tcl_UniChar *unicode, /* The unicode string used to initialize the
* new object. */
int numChars) /* Number of characters in the unicode
* string. */
{
Tcl_Obj *objPtr;
TclNewObj(objPtr);
SetUnicodeObj(objPtr, unicode, numChars);
return objPtr;
|
| ︙ | ︙ | |||
387 388 389 390 391 392 393 | * Side effects: * Frees old internal rep. Allocates memory for new "String" internal * rep. * *---------------------------------------------------------------------- */ | | | | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 |
* Side effects:
* Frees old internal rep. Allocates memory for new "String" internal
* rep.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetCharLength(
Tcl_Obj *objPtr) /* The String object to get the num chars
* of. */
{
String *stringPtr;
int numChars;
/*
* Quick, no-shimmer return for short string reps.
*/
if ((objPtr->bytes) && (objPtr->length < 2)) {
/* 0 bytes -> 0 chars; 1 byte -> 1 char */
|
| ︙ | ︙ | |||
416 417 418 419 420 421 422 |
* machinery behind that test is using a proper bytearray ObjType. We
* could also compute length of an improper bytearray without shimmering
* but there's no value in that. We *want* to shimmer an improper bytearray
* because improper bytearrays have worthless internal reps.
*/
if (TclIsPureByteArray(objPtr)) {
| > > | | | | 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 |
* machinery behind that test is using a proper bytearray ObjType. We
* could also compute length of an improper bytearray without shimmering
* but there's no value in that. We *want* to shimmer an improper bytearray
* because improper bytearrays have worthless internal reps.
*/
if (TclIsPureByteArray(objPtr)) {
int length;
(void) Tcl_GetByteArrayFromObj(objPtr, &length);
return length;
}
/*
* OK, need to work with the object as a string.
*/
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
numChars = stringPtr->numChars;
/*
* If numChars is unknown, compute it.
*/
if (numChars == -1) {
TclNumUtfChars(numChars, objPtr->bytes, objPtr->length);
stringPtr->numChars = numChars;
}
return numChars;
}
/*
|
| ︙ | ︙ | |||
503 504 505 506 507 508 509 |
*----------------------------------------------------------------------
*/
int
Tcl_GetUniChar(
Tcl_Obj *objPtr, /* The object to get the Unicode charater
* from. */
| | | > > > > < | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
*----------------------------------------------------------------------
*/
int
Tcl_GetUniChar(
Tcl_Obj *objPtr, /* The object to get the Unicode charater
* from. */
int index) /* Get the index'th Unicode character. */
{
String *stringPtr;
int ch, length;
if (index < 0) {
return -1;
}
/*
* Optimize the case where we're really dealing with a bytearray object
* we don't need to convert to a string to perform the indexing operation.
*/
if (TclIsPureByteArray(objPtr)) {
unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
if (index >= length) {
return -1;
}
return (int) bytes[index];
}
/*
* OK, need to work with the object as a string.
*/
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode == 0) {
/*
* If numChars is unknown, compute it.
*/
if (stringPtr->numChars == -1) {
TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length);
}
if (stringPtr->numChars == objPtr->length) {
return (Tcl_UniChar) objPtr->bytes[index];
}
FillUnicodeRep(objPtr);
stringPtr = GET_STRING(objPtr);
}
if (index >= stringPtr->numChars) {
return -1;
}
ch = stringPtr->unicode[index];
#if TCL_UTF_MAX <= 3
/* See: bug [11ae2be95dac9417] */
if ((ch & 0xF800) == 0xD800) {
if (ch & 0x400) {
if ((index > 0)
&& ((stringPtr->unicode[index-1] & 0xFC00) == 0xD800)) {
ch = -1; /* low surrogate preceded by high surrogate */
}
} else if ((++index < stringPtr->numChars)
&& ((stringPtr->unicode[index] & 0xFC00) == 0xDC00)) {
/* high surrogate followed by low surrogate */
ch = (((ch & 0x3FF) << 10) |
(stringPtr->unicode[index] & 0x3FF)) + 0x10000;
}
}
#endif
return ch;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetUnicode --
*
* Get the Unicode form of the String object. If the object is not
* already a String object, it will be converted to one. If the String
* object does not have a Unicode rep, then one is created from the UTF
* string format.
*
* Results:
* Returns a pointer to the object's internal Unicode string.
*
* Side effects:
* Converts the object to have the String internal rep.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
#undef Tcl_GetUnicode
Tcl_UniChar *
Tcl_GetUnicode(
Tcl_Obj *objPtr) /* The object to find the unicode string
* for. */
{
return Tcl_GetUnicodeFromObj(objPtr, NULL);
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_GetUnicodeFromObj --
*
* Get the Unicode form of the String object with length. If the object
* is not already a String object, it will be converted to one. If the
|
| ︙ | ︙ | |||
633 634 635 636 637 638 639 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_GetRange(
Tcl_Obj *objPtr, /* The Tcl object to find the range of. */
| | | | | | < < < | | 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 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_GetRange(
Tcl_Obj *objPtr, /* The Tcl object to find the range of. */
int first, /* First index of the range. */
int last) /* Last index of the range. */
{
Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */
String *stringPtr;
int length;
if (first < 0) {
first = 0;
}
/*
* Optimize the case where we're really dealing with a bytearray object
* we don't need to convert to a string to perform the substring operation.
*/
if (TclIsPureByteArray(objPtr)) {
unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length);
if (last >= length) {
last = length - 1;
}
if (last < first) {
return Tcl_NewObj();
}
|
| ︙ | ︙ | |||
676 677 678 679 680 681 682 |
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode == 0) {
/*
* If numChars is unknown, compute it.
*/
| | | 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 |
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode == 0) {
/*
* If numChars is unknown, compute it.
*/
if (stringPtr->numChars == -1) {
TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length);
}
if (stringPtr->numChars == objPtr->length) {
if (last >= stringPtr->numChars) {
last = stringPtr->numChars - 1;
}
if (last < first) {
|
| ︙ | ︙ | |||
706 707 708 709 710 711 712 |
}
if (last > stringPtr->numChars) {
last = stringPtr->numChars;
}
if (last < first) {
return Tcl_NewObj();
}
| | | | | 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 |
}
if (last > stringPtr->numChars) {
last = stringPtr->numChars;
}
if (last < first) {
return Tcl_NewObj();
}
#if TCL_UTF_MAX <= 3
/* See: bug [11ae2be95dac9417] */
if ((first > 0) && ((stringPtr->unicode[first] & 0xFC00) == 0xDC00)
&& ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) {
++first;
}
if ((last + 1 < stringPtr->numChars)
&& ((stringPtr->unicode[last+1] & 0xFC00) == 0xDC00)
&& ((stringPtr->unicode[last] & 0xFC00) == 0xD800)) {
++last;
}
#endif
return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1);
}
|
| ︙ | ︙ | |||
747 748 749 750 751 752 753 |
*/
void
Tcl_SetStringObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
const char *bytes, /* Points to the first of the length bytes
* used to initialize the object. */
| | | | | 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 |
*/
void
Tcl_SetStringObj(
Tcl_Obj *objPtr, /* Object whose internal rep to init. */
const char *bytes, /* Points to the first of the length bytes
* used to initialize the object. */
int length) /* The number of bytes to copy from "bytes"
* when initializing the object. If negative,
* use bytes up to the first NUL byte.*/
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetStringObj");
}
/*
* Set the type to NULL and free any internal rep for the old type.
*/
TclFreeIntRep(objPtr);
/*
* Free any old string rep, then set the string rep to a copy of the
* length bytes starting at "bytes".
*/
TclInvalidateStringRep(objPtr);
if (length < 0) {
length = (bytes? strlen(bytes) : 0);
}
TclInitStringRep(objPtr, bytes, length);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
800 801 802 803 804 805 806 |
*----------------------------------------------------------------------
*/
void
Tcl_SetObjLength(
Tcl_Obj *objPtr, /* Pointer to object. This object must not
* currently be shared. */
| | > > > > > > > > > | | | > > > > > | 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 |
*----------------------------------------------------------------------
*/
void
Tcl_SetObjLength(
Tcl_Obj *objPtr, /* Pointer to object. This object must not
* currently be shared. */
int length) /* Number of bytes desired for string
* representation of object, not including
* terminating null byte. */
{
String *stringPtr;
if (length < 0) {
/*
* Setting to a negative length is nonsense. This is probably the
* result of overflowing the signed integer range.
*/
Tcl_Panic("Tcl_SetObjLength: negative length requested: "
"%d (integer overflow?)", length);
}
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetObjLength");
}
if (objPtr->bytes && objPtr->length == length) {
return;
}
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
if (objPtr->bytes != NULL) {
/*
* Change length of an existing string rep.
*/
if (length > stringPtr->allocated) {
/*
* Need to enlarge the buffer.
*/
if (objPtr->bytes == &tclEmptyString) {
objPtr->bytes = (char *)ckalloc(length + 1);
} else {
objPtr->bytes = (char *)ckrealloc(objPtr->bytes, length + 1);
}
stringPtr->allocated = length;
}
objPtr->length = length;
objPtr->bytes[length] = 0;
/*
* Invalidate the unicode data.
*/
stringPtr->numChars = -1;
stringPtr->hasUnicode = 0;
} else {
/*
* Changing length of pure unicode string.
*/
stringCheckLimits(length);
if (length > stringPtr->maxChars) {
stringPtr = stringRealloc(stringPtr, length);
SET_STRING(objPtr, stringPtr);
stringPtr->maxChars = length;
}
/*
|
| ︙ | ︙ | |||
891 892 893 894 895 896 897 |
*----------------------------------------------------------------------
*/
int
Tcl_AttemptSetObjLength(
Tcl_Obj *objPtr, /* Pointer to object. This object must not
* currently be shared. */
| | > > > > > > > > | 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 |
*----------------------------------------------------------------------
*/
int
Tcl_AttemptSetObjLength(
Tcl_Obj *objPtr, /* Pointer to object. This object must not
* currently be shared. */
int length) /* Number of bytes desired for string
* representation of object, not including
* terminating null byte. */
{
String *stringPtr;
if (length < 0) {
/*
* Setting to a negative length is nonsense. This is probably the
* result of overflowing the signed integer range.
*/
return 0;
}
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_AttemptSetObjLength");
}
if (objPtr->bytes && objPtr->length == length) {
return 1;
}
|
| ︙ | ︙ | |||
919 920 921 922 923 924 925 |
/*
* Need to enlarge the buffer.
*/
char *newBytes;
if (objPtr->bytes == &tclEmptyString) {
| | | | > > > | 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 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 |
/*
* Need to enlarge the buffer.
*/
char *newBytes;
if (objPtr->bytes == &tclEmptyString) {
newBytes = (char *)attemptckalloc(length + 1);
} else {
newBytes = (char *)attemptckrealloc(objPtr->bytes, length + 1);
}
if (newBytes == NULL) {
return 0;
}
objPtr->bytes = newBytes;
stringPtr->allocated = length;
}
objPtr->length = length;
objPtr->bytes[length] = 0;
/*
* Invalidate the unicode data.
*/
stringPtr->numChars = -1;
stringPtr->hasUnicode = 0;
} else {
/*
* Changing length of pure unicode string.
*/
if (length > STRING_MAXCHARS) {
return 0;
}
if (length > stringPtr->maxChars) {
stringPtr = stringAttemptRealloc(stringPtr, length);
if (stringPtr == NULL) {
return 0;
}
SET_STRING(objPtr, stringPtr);
stringPtr->maxChars = length;
|
| ︙ | ︙ | |||
990 991 992 993 994 995 996 |
*/
void
Tcl_SetUnicodeObj(
Tcl_Obj *objPtr, /* The object to set the string of. */
const Tcl_UniChar *unicode, /* The unicode string used to initialize the
* object. */
| | | | | > | | > | 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 |
*/
void
Tcl_SetUnicodeObj(
Tcl_Obj *objPtr, /* The object to set the string of. */
const Tcl_UniChar *unicode, /* The unicode string used to initialize the
* object. */
int numChars) /* Number of characters in the unicode
* string. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetUnicodeObj");
}
TclFreeIntRep(objPtr);
SetUnicodeObj(objPtr, unicode, numChars);
}
static int
UnicodeLength(
const Tcl_UniChar *unicode)
{
int numChars = 0;
if (unicode) {
while (numChars >= 0 && unicode[numChars] != 0) {
numChars++;
}
}
stringCheckLimits(numChars);
return numChars;
}
static void
SetUnicodeObj(
Tcl_Obj *objPtr, /* The object to set the string of. */
const Tcl_UniChar *unicode, /* The unicode string used to initialize the
* object. */
int numChars) /* Number of characters in the unicode
* string. */
{
String *stringPtr;
if (numChars < 0) {
numChars = UnicodeLength(unicode);
}
/*
* Allocate enough space for the String structure + Unicode string.
*/
stringCheckLimits(numChars);
stringPtr = stringAlloc(numChars);
SET_STRING(objPtr, stringPtr);
objPtr->typePtr = &tclStringType;
stringPtr->maxChars = numChars;
memcpy(stringPtr->unicode, unicode, numChars * sizeof(Tcl_UniChar));
stringPtr->unicode[numChars] = 0;
|
| ︙ | ︙ | |||
1069 1070 1071 1072 1073 1074 1075 |
*/
void
Tcl_AppendLimitedToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const char *bytes, /* Points to the bytes to append to the
* object. */
| | | | | | | < < | < | > > > > > > > | | > > > > | | | | | 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 |
*/
void
Tcl_AppendLimitedToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const char *bytes, /* Points to the bytes to append to the
* object. */
int length, /* The number of bytes available to be
* appended from "bytes". If < 0, then all
* bytes up to a NUL byte are available. */
int limit, /* The maximum number of bytes to append to
* the object. */
const char *ellipsis) /* Ellipsis marker string, appended to the
* object to indicate not all available bytes
* at "bytes" were appended. */
{
String *stringPtr;
int toCopy = 0;
int eLen = 0;
if (length < 0) {
length = (bytes ? strlen(bytes) : 0);
}
if (length == 0) {
return;
}
if (limit <= 0) {
return;
}
if (length <= limit) {
toCopy = length;
} else {
if (ellipsis == NULL) {
ellipsis = "...";
}
eLen = strlen(ellipsis);
while (eLen > limit) {
eLen = TclUtfPrev(ellipsis+eLen, ellipsis) - ellipsis;
}
toCopy = TclUtfPrev(bytes+limit+1-eLen, bytes) - bytes;
}
/*
* If objPtr has a valid Unicode rep, then append the Unicode conversion
* of "bytes" to the objPtr's Unicode rep, otherwise append "bytes" to
* objPtr's string rep.
*/
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_AppendLimitedToObj");
}
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode && stringPtr->numChars > 0) {
AppendUtfToUnicodeRep(objPtr, bytes, toCopy);
} else {
AppendUtfToUtfRep(objPtr, bytes, toCopy);
}
if (length <= limit) {
return;
}
stringPtr = GET_STRING(objPtr);
if (stringPtr->hasUnicode && stringPtr->numChars > 0) {
AppendUtfToUnicodeRep(objPtr, ellipsis, eLen);
} else {
AppendUtfToUtfRep(objPtr, ellipsis, eLen);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendToObj --
|
| ︙ | ︙ | |||
1151 1152 1153 1154 1155 1156 1157 |
*/
void
Tcl_AppendToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const char *bytes, /* Points to the bytes to append to the
* object. */
| | | | | 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 |
*/
void
Tcl_AppendToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const char *bytes, /* Points to the bytes to append to the
* object. */
int length) /* The number of bytes to append from "bytes".
* If < 0, then append all bytes up to NUL
* byte. */
{
Tcl_AppendLimitedToObj(objPtr, bytes, length, INT_MAX, NULL);
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendUnicodeToObj --
*
|
| ︙ | ︙ | |||
1180 1181 1182 1183 1184 1185 1186 |
*/
void
Tcl_AppendUnicodeToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const Tcl_UniChar *unicode, /* The unicode string to append to the
* object. */
| | | 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 |
*/
void
Tcl_AppendUnicodeToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const Tcl_UniChar *unicode, /* The unicode string to append to the
* object. */
int length) /* Number of chars in "unicode". */
{
String *stringPtr;
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj");
}
|
| ︙ | ︙ | |||
1234 1235 1236 1237 1238 1239 1240 |
void
Tcl_AppendObjToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
Tcl_Obj *appendObjPtr) /* Object to append. */
{
String *stringPtr;
| < | | 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 |
void
Tcl_AppendObjToObj(
Tcl_Obj *objPtr, /* Points to the object to append to. */
Tcl_Obj *appendObjPtr) /* Object to append. */
{
String *stringPtr;
int length, numChars, appendNumChars = -1;
const char *bytes;
/*
* Special case: second object is standard-empty is fast case. We know
* that appending nothing to anything leaves that starting anything...
*/
|
| ︙ | ︙ | |||
1259 1260 1261 1262 1263 1264 1265 |
*/
if ((TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString)
&& TclIsPureByteArray(appendObjPtr)) {
/*
* You might expect the code here to be
*
| | | | | | 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 |
*/
if ((TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString)
&& TclIsPureByteArray(appendObjPtr)) {
/*
* You might expect the code here to be
*
* bytes = Tcl_GetByteArrayFromObj(appendObjPtr, &length);
* TclAppendBytesToByteArray(objPtr, bytes, length);
*
* and essentially all of the time that would be fine. However, it
* would run into trouble in the case where objPtr and appendObjPtr
* point to the same thing. That may never be a good idea. It seems to
* violate Copy On Write, and we don't have any tests for the
* situation, since making any Tcl commands that call
* Tcl_AppendObjToObj() do that appears impossible (They honor Copy On
* Write!). For the sake of extensions that go off into that realm,
* though, here's a more complex approach that can handle all the
* cases.
*
* First, get the lengths.
*/
int lengthSrc;
(void) Tcl_GetByteArrayFromObj(objPtr, &length);
(void) Tcl_GetByteArrayFromObj(appendObjPtr, &lengthSrc);
/*
* Grow buffer enough for the append.
*/
TclAppendBytesToByteArray(objPtr, NULL, lengthSrc);
|
| ︙ | ︙ | |||
1321 1322 1323 1324 1325 1326 1327 |
if (stringPtr->hasUnicode) {
/*
* If appendObjPtr is not of the "String" type, don't convert it.
*/
if (TclHasIntRep(appendObjPtr, &tclStringType)) {
Tcl_UniChar *unicode =
| | | | | 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 |
if (stringPtr->hasUnicode) {
/*
* If appendObjPtr is not of the "String" type, don't convert it.
*/
if (TclHasIntRep(appendObjPtr, &tclStringType)) {
Tcl_UniChar *unicode =
Tcl_GetUnicodeFromObj(appendObjPtr, &numChars);
AppendUnicodeToUnicodeRep(objPtr, unicode, numChars);
} else {
bytes = TclGetStringFromObj(appendObjPtr, &length);
AppendUtfToUnicodeRep(objPtr, bytes, length);
}
return;
}
/*
* Append to objPtr's UTF string rep. If we know the number of characters
* in both objects before appending, then set the combined number of
* characters in the final (appended-to) object.
*/
bytes = TclGetStringFromObj(appendObjPtr, &length);
numChars = stringPtr->numChars;
if ((numChars >= 0) && TclHasIntRep(appendObjPtr, &tclStringType)) {
String *appendStringPtr = GET_STRING(appendObjPtr);
appendNumChars = appendStringPtr->numChars;
}
AppendUtfToUtfRep(objPtr, bytes, length);
if (numChars >= 0 && appendNumChars >= 0) {
stringPtr->numChars = numChars + appendNumChars;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1374 1375 1376 1377 1378 1379 1380 |
*----------------------------------------------------------------------
*/
static void
AppendUnicodeToUnicodeRep(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const Tcl_UniChar *unicode, /* String to append. */
| | | | > < > | | | | 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 |
*----------------------------------------------------------------------
*/
static void
AppendUnicodeToUnicodeRep(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const Tcl_UniChar *unicode, /* String to append. */
int appendNumChars) /* Number of chars of "unicode" to append. */
{
String *stringPtr;
int numChars;
if (appendNumChars < 0) {
appendNumChars = UnicodeLength(unicode);
}
if (appendNumChars == 0) {
return;
}
SetStringFromAny(NULL, objPtr);
stringPtr = GET_STRING(objPtr);
/*
* If not enough space has been allocated for the unicode rep, reallocate
* the internal rep object with additional space. First try to double the
* required allocation; if that fails, try a more modest increase. See the
* "TCL STRING GROWTH ALGORITHM" comment at the top of this file for an
* explanation of this growth algorithm.
*/
numChars = stringPtr->numChars + appendNumChars;
stringCheckLimits(numChars);
if (numChars > stringPtr->maxChars) {
int offset = -1;
/*
* Protect against case where unicode points into the existing
* stringPtr->unicode array. Force it to follow any relocations due to
* the reallocs below.
*/
if (unicode && unicode >= stringPtr->unicode
&& unicode <= stringPtr->unicode + stringPtr->maxChars) {
offset = unicode - stringPtr->unicode;
}
GrowUnicodeBuffer(objPtr, numChars);
stringPtr = GET_STRING(objPtr);
/*
* Relocate unicode if needed; see above.
*/
if (offset >= 0) {
unicode = stringPtr->unicode + offset;
}
}
/*
* Copy the new string onto the end of the old string, then add the
* trailing null.
*/
|
| ︙ | ︙ | |||
1462 1463 1464 1465 1466 1467 1468 |
*----------------------------------------------------------------------
*/
static void
AppendUnicodeToUtfRep(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const Tcl_UniChar *unicode, /* String to convert to UTF. */
| | | | 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 |
*----------------------------------------------------------------------
*/
static void
AppendUnicodeToUtfRep(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const Tcl_UniChar *unicode, /* String to convert to UTF. */
int numChars) /* Number of chars of "unicode" to convert. */
{
String *stringPtr = GET_STRING(objPtr);
numChars = ExtendStringRepWithUnicode(objPtr, unicode, numChars);
if (stringPtr->numChars != -1) {
stringPtr->numChars += numChars;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1495 1496 1497 1498 1499 1500 1501 |
*----------------------------------------------------------------------
*/
static void
AppendUtfToUnicodeRep(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const char *bytes, /* String to convert to Unicode. */
| | | 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 |
*----------------------------------------------------------------------
*/
static void
AppendUtfToUnicodeRep(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const char *bytes, /* String to convert to Unicode. */
int numBytes) /* Number of bytes of "bytes" to convert. */
{
String *stringPtr;
if (numBytes == 0) {
return;
}
|
| ︙ | ︙ | |||
1531 1532 1533 1534 1535 1536 1537 |
*----------------------------------------------------------------------
*/
static void
AppendUtfToUtfRep(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const char *bytes, /* String to append. */
| | | > > > | | 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 |
*----------------------------------------------------------------------
*/
static void
AppendUtfToUtfRep(
Tcl_Obj *objPtr, /* Points to the object to append to. */
const char *bytes, /* String to append. */
int numBytes) /* Number of bytes of "bytes" to append. */
{
String *stringPtr;
int newLength, oldLength;
if (numBytes == 0) {
return;
}
/*
* Copy the new string onto the end of the old string, then add the
* trailing null.
*/
if (objPtr->bytes == NULL) {
objPtr->length = 0;
}
oldLength = objPtr->length;
newLength = numBytes + oldLength;
if (newLength < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
stringPtr = GET_STRING(objPtr);
if (newLength > stringPtr->allocated) {
int offset = -1;
/*
* Protect against case where unicode points into the existing
* stringPtr->unicode array. Force it to follow any relocations due to
* the reallocs below.
*/
|
| ︙ | ︙ | |||
1577 1578 1579 1580 1581 1582 1583 | GrowStringBuffer(objPtr, newLength, 0); /* * Relocate bytes if needed; see above. */ | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 |
GrowStringBuffer(objPtr, newLength, 0);
/*
* Relocate bytes if needed; see above.
*/
if (offset >= 0) {
bytes = objPtr->bytes + offset;
}
}
/*
* Invalidate the unicode data.
*/
stringPtr->numChars = -1;
stringPtr->hasUnicode = 0;
if (bytes) {
memmove(objPtr->bytes + oldLength, bytes, numBytes);
}
objPtr->bytes[newLength] = 0;
objPtr->length = newLength;
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendStringsToObjVA --
*
* This function appends one or more null-terminated strings to an
* object.
*
* Results:
* None.
*
* Side effects:
* The contents of all the string arguments are appended to the string
* representation of objPtr.
*
*----------------------------------------------------------------------
*/
void
Tcl_AppendStringsToObjVA(
Tcl_Obj *objPtr, /* Points to the object to append to. */
va_list argList) /* Variable argument list. */
{
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_AppendStringsToObj");
}
while (1) {
const char *bytes = va_arg(argList, char *);
if (bytes == NULL) {
break;
}
Tcl_AppendToObj(objPtr, bytes, -1);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendStringsToObj --
*
* This function appends one or more null-terminated strings to an
|
| ︙ | ︙ | |||
1622 1623 1624 1625 1626 1627 1628 |
Tcl_AppendStringsToObj(
Tcl_Obj *objPtr,
...)
{
va_list argList;
va_start(argList, objPtr);
| < | < < < < < < < < < < | 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 |
Tcl_AppendStringsToObj(
Tcl_Obj *objPtr,
...)
{
va_list argList;
va_start(argList, objPtr);
Tcl_AppendStringsToObjVA(objPtr, argList);
va_end(argList);
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendFormatToObj --
|
| ︙ | ︙ | |||
1666 1667 1668 1669 1670 1671 1672 |
Tcl_Interp *interp,
Tcl_Obj *appendObj,
const char *format,
int objc,
Tcl_Obj *const objv[])
{
const char *span = format, *msg, *errCode;
| | | | | | < | 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 |
Tcl_Interp *interp,
Tcl_Obj *appendObj,
const char *format,
int objc,
Tcl_Obj *const objv[])
{
const char *span = format, *msg, *errCode;
int numBytes = 0, objIndex = 0, gotXpg = 0, gotSequential = 0;
int originalLength, limit;
Tcl_UniChar ch = 0;
static const char *mixedXPG =
"cannot mix \"%\" and \"%n$\" conversion specifiers";
static const char *const badIndex[2] = {
"not enough arguments for all format specifiers",
"\"%n$\" argument index out of range"
};
static const char *overflow = "max size for a Tcl value exceeded";
if (Tcl_IsShared(appendObj)) {
Tcl_Panic("%s called with shared object", "Tcl_AppendFormatToObj");
}
TclGetStringFromObj(appendObj, &originalLength);
limit = INT_MAX - originalLength;
/*
* Format string is NUL-terminated.
*/
while (*format != '\0') {
char *end;
int gotMinus = 0, gotHash = 0, gotZero = 0, gotSpace = 0, gotPlus = 0;
int width, gotPrecision, precision, sawFlag, useShort = 0, useBig = 0;
#ifndef TCL_WIDE_INT_IS_LONG
int useWide = 0;
#endif
int newXpg, numChars, allocSegment = 0, segmentLimit, segmentNumBytes;
Tcl_Obj *segment;
int step = TclUtfToUniChar(format, &ch);
format += step;
if (ch != '%') {
numBytes += step;
continue;
|
| ︙ | ︙ | |||
1827 1828 1829 1830 1831 1832 1833 | width = -width; gotMinus = 1; } objIndex++; format += step; step = TclUtfToUniChar(format, &ch); } | | | 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 |
width = -width;
gotMinus = 1;
}
objIndex++;
format += step;
step = TclUtfToUniChar(format, &ch);
}
if (width > limit) {
msg = overflow;
errCode = "OVERFLOW";
goto errorMsg;
}
/*
* Step 4. Precision.
|
| ︙ | ︙ | |||
1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 |
segment = Tcl_NewStringObj(buf, length);
Tcl_IncrRefCount(segment);
allocSegment = 1;
break;
}
case 'u':
case 'd':
case 'o':
case 'p':
case 'x':
case 'X':
case 'b': {
short s = 0; /* Silence compiler warning; only defined and
| > | 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 |
segment = Tcl_NewStringObj(buf, length);
Tcl_IncrRefCount(segment);
allocSegment = 1;
break;
}
case 'u':
/* FALLTHRU */
case 'd':
case 'o':
case 'p':
case 'x':
case 'X':
case 'b': {
short s = 0; /* Silence compiler warning; only defined and
|
| ︙ | ︙ | |||
2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 |
Tcl_AppendToObj(segment, "0x", 2);
segmentLimit -= 2;
break;
case 'b':
Tcl_AppendToObj(segment, "0b", 2);
segmentLimit -= 2;
break;
}
}
switch (ch) {
case 'd': {
| > > > > > > > > | | 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 |
Tcl_AppendToObj(segment, "0x", 2);
segmentLimit -= 2;
break;
case 'b':
Tcl_AppendToObj(segment, "0b", 2);
segmentLimit -= 2;
break;
#if TCL_MAJOR_VERSION < 9
case 'd':
if (gotZero) {
Tcl_AppendToObj(segment, "0d", 2);
segmentLimit -= 2;
}
break;
#endif
}
}
switch (ch) {
case 'd': {
int length;
Tcl_Obj *pure;
const char *bytes;
if (useShort) {
pure = Tcl_NewWideIntObj(s);
#ifndef TCL_WIDE_INT_IS_LONG
} else if (useWide) {
|
| ︙ | ︙ | |||
2092 2093 2094 2095 2096 2097 2098 |
/*
* Canonical decimal string reps for integers are composed
* entirely of one-byte encoded characters, so "length" is the
* number of chars.
*/
if (gotPrecision) {
| | | | | | | | < | 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 |
/*
* Canonical decimal string reps for integers are composed
* entirely of one-byte encoded characters, so "length" is the
* number of chars.
*/
if (gotPrecision) {
if (length < precision) {
segmentLimit -= precision - length;
}
while (length < precision) {
Tcl_AppendToObj(segment, "0", 1);
length++;
}
gotZero = 0;
}
if (gotZero) {
length += Tcl_GetCharLength(segment);
if (length < width) {
segmentLimit -= width - length;
}
while (length < width) {
Tcl_AppendToObj(segment, "0", 1);
length++;
}
}
if (toAppend > segmentLimit) {
msg = overflow;
errCode = "OVERFLOW";
goto errorMsg;
}
Tcl_AppendToObj(segment, bytes, toAppend);
Tcl_DecrRefCount(pure);
break;
}
case 'u':
case 'o':
case 'p':
case 'x':
case 'X':
case 'b': {
Tcl_WideUInt bits = (Tcl_WideUInt) 0;
Tcl_WideInt numDigits = (Tcl_WideInt) 0;
int length, numBits = 4, base = 16, index = 0, shift = 0;
Tcl_Obj *pure;
char *bytes;
if (ch == 'u') {
base = 10;
} else if (ch == 'o') {
base = 8;
|
| ︙ | ︙ | |||
2161 2162 2163 2164 2165 2166 2167 |
bits = uw;
while (uw) {
numDigits++;
uw /= base;
}
#endif
| | | 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 |
bits = uw;
while (uw) {
numDigits++;
uw /= base;
}
#endif
} else if (useBig && !mp_iszero(&big)) {
int leftover = (big.used * MP_DIGIT_BIT) % numBits;
mp_digit mask = (~(mp_digit)0) << (MP_DIGIT_BIT-leftover);
numDigits = 1 +
(((Tcl_WideInt) big.used * MP_DIGIT_BIT) / numBits);
while ((mask & big.dp[big.used-1]) == 0) {
numDigits--;
|
| ︙ | ︙ | |||
2194 2195 2196 2197 2198 2199 2200 |
* Need to be sure zero becomes "0", not "".
*/
if (numDigits == 0) {
numDigits = 1;
}
pure = Tcl_NewObj();
| | | | | | | | | | 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 |
* Need to be sure zero becomes "0", not "".
*/
if (numDigits == 0) {
numDigits = 1;
}
pure = Tcl_NewObj();
Tcl_SetObjLength(pure, (int) numDigits);
bytes = TclGetString(pure);
toAppend = length = (int) numDigits;
while (numDigits--) {
int digitOffset;
if (useBig && !mp_iszero(&big)) {
if (index < big.used && (size_t) shift <
CHAR_BIT*sizeof(Tcl_WideUInt) - MP_DIGIT_BIT) {
bits |= ((Tcl_WideUInt) big.dp[index++]) << shift;
shift += MP_DIGIT_BIT;
}
shift -= numBits;
}
digitOffset = (int) (bits % base);
if (digitOffset > 9) {
if (ch == 'X') {
bytes[numDigits] = 'A' + digitOffset - 10;
} else {
bytes[numDigits] = 'a' + digitOffset - 10;
}
} else {
bytes[numDigits] = '0' + digitOffset;
}
bits /= base;
}
if (useBig) {
mp_clear(&big);
}
if (gotPrecision) {
if (length < precision) {
segmentLimit -= precision - length;
}
while (length < precision) {
Tcl_AppendToObj(segment, "0", 1);
length++;
}
gotZero = 0;
}
if (gotZero) {
length += Tcl_GetCharLength(segment);
if (length < width) {
segmentLimit -= width - length;
}
while (length < width) {
Tcl_AppendToObj(segment, "0", 1);
length++;
}
}
if (toAppend > segmentLimit) {
msg = overflow;
errCode = "OVERFLOW";
|
| ︙ | ︙ | |||
2357 2358 2359 2360 2361 2362 2363 |
}
while (numChars < width) {
Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1);
numChars++;
}
}
| | | 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 |
}
while (numChars < width) {
Tcl_AppendToObj(appendObj, (gotZero ? "0" : " "), 1);
numChars++;
}
}
TclGetStringFromObj(segment, &segmentNumBytes);
if (segmentNumBytes > limit) {
if (allocSegment) {
Tcl_DecrRefCount(segment);
}
msg = overflow;
errCode = "OVERFLOW";
goto errorMsg;
|
| ︙ | ︙ | |||
2499 2500 2501 2502 2503 2504 2505 | /* * Within that buffer, we trim both ends if needed so that we * copy only whole characters, and avoid copying any partial * multi-byte characters. */ | | | | | | 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 |
/*
* Within that buffer, we trim both ends if needed so that we
* copy only whole characters, and avoid copying any partial
* multi-byte characters.
*/
q = TclUtfPrev(end, bytes);
if (!Tcl_UtfCharComplete(q, (int)(end - q))) {
end = q;
}
q = bytes + 4;
while ((bytes < end) && (bytes < q)
&& ((*bytes & 0xC0) == 0x80)) {
bytes++;
}
Tcl_ListObjAppendElement(NULL, list,
Tcl_NewStringObj(bytes , (int)(end - bytes)));
break;
}
case 'c':
case 'i':
case 'u':
case 'd':
|
| ︙ | ︙ | |||
2561 2562 2563 2564 2565 2566 2567 |
} else {
Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
va_arg(argList, double)));
}
seekingConversion = 0;
break;
case '*':
| | | | 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 |
} else {
Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
va_arg(argList, double)));
}
seekingConversion = 0;
break;
case '*':
lastNum = (int) va_arg(argList, int);
Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj(lastNum));
p++;
break;
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': {
char *end;
lastNum = (int) strtoul(p, &end, 10);
p = end;
break;
}
case '.':
gotPrecision = 1;
p++;
break;
|
| ︙ | ︙ | |||
2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 |
break;
case 'L':
size = 3;
p++;
break;
case 'h':
size = -1;
default:
p++;
}
} while (seekingConversion);
}
TclListObjGetElements(NULL, list, &objc, &objv);
code = Tcl_AppendFormatToObj(NULL, objPtr, format, objc, objv);
if (code != TCL_OK) {
Tcl_AppendPrintfToObj(objPtr,
"Unable to format \"%s\" with supplied arguments: %s",
| > | | 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 |
break;
case 'L':
size = 3;
p++;
break;
case 'h':
size = -1;
/* FALLTHRU */
default:
p++;
}
} while (seekingConversion);
}
TclListObjGetElements(NULL, list, &objc, &objv);
code = Tcl_AppendFormatToObj(NULL, objPtr, format, objc, objv);
if (code != TCL_OK) {
Tcl_AppendPrintfToObj(objPtr,
"Unable to format \"%s\" with supplied arguments: %s",
format, Tcl_GetString(list));
}
Tcl_DecrRefCount(list);
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2700 2701 2702 2703 2704 2705 2706 |
*
*---------------------------------------------------------------------------
*/
char *
TclGetStringStorage(
Tcl_Obj *objPtr,
| | | | 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 |
*
*---------------------------------------------------------------------------
*/
char *
TclGetStringStorage(
Tcl_Obj *objPtr,
unsigned int *sizePtr)
{
String *stringPtr;
if (!TclHasIntRep(objPtr, &tclStringType) || objPtr->bytes == NULL) {
return TclGetStringFromObj(objPtr, (int *)sizePtr);
}
stringPtr = GET_STRING(objPtr);
*sizePtr = stringPtr->allocated;
return objPtr->bytes;
}
|
| ︙ | ︙ | |||
2734 2735 2736 2737 2738 2739 2740 |
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclStringRepeat(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
| | | | 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 |
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclStringRepeat(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
int count,
int flags)
{
Tcl_Obj *objResultPtr;
int inPlace = flags & TCL_STRING_IN_PLACE;
int length = 0, unichar = 0, done = 1;
int binary = TclIsPureByteArray(objPtr);
/* assert (count >= 2) */
/*
* Analyze to determine what representation result should be.
* GOALS: Avoid shimmering & string rep generation.
|
| ︙ | ︙ | |||
2762 2763 2764 2765 2766 2767 2768 |
unichar = 1;
}
}
}
if (binary) {
/* Result will be pure byte array. Pre-size it */
| | | | | 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 |
unichar = 1;
}
}
}
if (binary) {
/* Result will be pure byte array. Pre-size it */
Tcl_GetByteArrayFromObj(objPtr, &length);
} else if (unichar) {
/* Result will be pure Tcl_UniChar array. Pre-size it. */
Tcl_GetUnicodeFromObj(objPtr, &length);
} else {
/* Result will be concat of string reps. Pre-size it. */
Tcl_GetStringFromObj(objPtr, &length);
}
if (length == 0) {
/* Any repeats of empty is empty. */
return objPtr;
}
|
| ︙ | ︙ | |||
2834 2835 2836 2837 2838 2839 2840 |
(count - done) * length);
} else {
/*
* Efficiently concatenate string reps.
*/
if (!inPlace || Tcl_IsShared(objPtr)) {
| | | | | 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 |
(count - done) * length);
} else {
/*
* Efficiently concatenate string reps.
*/
if (!inPlace || Tcl_IsShared(objPtr)) {
objResultPtr = Tcl_NewStringObj(Tcl_GetString(objPtr), length);
} else {
TclFreeIntRep(objPtr);
objResultPtr = objPtr;
}
if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"string size overflow: unable to alloc %u bytes",
count*length));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return NULL;
}
Tcl_SetObjLength(objResultPtr, length);
while (count - done > done) {
Tcl_AppendObjToObj(objResultPtr, objResultPtr);
done *= 2;
}
Tcl_AppendToObj(objResultPtr, Tcl_GetString(objResultPtr),
(count - done) * length);
}
return objResultPtr;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
2884 2885 2886 2887 2888 2889 2890 |
TclStringCat(
Tcl_Interp *interp,
int objc,
Tcl_Obj * const objv[],
int flags)
{
Tcl_Obj *objResultPtr, * const *ov;
| | < | 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 |
TclStringCat(
Tcl_Interp *interp,
int objc,
Tcl_Obj * const objv[],
int flags)
{
Tcl_Obj *objResultPtr, * const *ov;
int oc, length = 0, binary = 1;
int allowUniChar = 1, requestUniChar = 0;
int first = objc - 1; /* Index of first value possibly not empty */
int last = 0; /* Index of last value possibly not empty */
int inPlace = flags & TCL_STRING_IN_PLACE;
/* assert ( objc >= 0 ) */
|
| ︙ | ︙ | |||
2945 2946 2947 2948 2949 2950 2951 |
} while (--oc && (binary || allowUniChar));
if (binary) {
/*
* Result will be pure byte array. Pre-size it
*/
| | | > > | | > > | 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 |
} while (--oc && (binary || allowUniChar));
if (binary) {
/*
* Result will be pure byte array. Pre-size it
*/
int numBytes;
ov = objv;
oc = objc;
do {
Tcl_Obj *objPtr = *ov++;
/*
* Every argument is either a bytearray with a ("pure")
* value we know we can safely use, or it is an empty string.
* We don't need to count bytes for the empty strings.
*/
if (TclIsPureByteArray(objPtr)) {
Tcl_GetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */
if (numBytes) {
last = objc - oc;
if (length == 0) {
first = last;
} else if (numBytes > INT_MAX - length) {
goto overflow;
}
length += numBytes;
}
}
} while (--oc);
} else if (allowUniChar && requestUniChar) {
/*
* Result will be pure Tcl_UniChar array. Pre-size it.
*/
ov = objv;
oc = objc;
do {
Tcl_Obj *objPtr = *ov++;
if ((objPtr->bytes == NULL) || (objPtr->length)) {
int numChars;
Tcl_GetUnicodeFromObj(objPtr, &numChars); /* PANIC? */
if (numChars) {
last = objc - oc;
if (length == 0) {
first = last;
} else if (numChars > INT_MAX - length) {
goto overflow;
}
length += numChars;
}
}
} while (--oc);
} else {
/* Result will be concat of string reps. Pre-size it. */
|
| ︙ | ︙ | |||
3013 3014 3015 3016 3017 3018 3019 |
Tcl_Obj *objPtr = *ov++;
if (objPtr->bytes == NULL) {
/* No string rep; Take the chance we can avoid making it */
pendingPtr = objPtr;
} else {
| | | | | | | | < | | 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 |
Tcl_Obj *objPtr = *ov++;
if (objPtr->bytes == NULL) {
/* No string rep; Take the chance we can avoid making it */
pendingPtr = objPtr;
} else {
Tcl_GetStringFromObj(objPtr, &length); /* PANIC? */
}
} while (--oc && (length == 0) && (pendingPtr == NULL));
/*
* Either we found a possibly non-empty value, and we remember
* this index as the first and last such value so far seen,
* or (oc == 0) and all values are known empty,
* so first = last = objc - 1 signals the right quick return.
*/
first = last = objc - oc - 1;
if (oc && (length == 0)) {
int numBytes;
/* assert ( pendingPtr != NULL ) */
/*
* There's a pending value followed by more values. Loop over
* remaining values generating strings until a non-empty value
* is found, or the pending value gets its string generated.
*/
do {
Tcl_Obj *objPtr = *ov++;
Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */
} while (--oc && numBytes == 0 && pendingPtr->bytes == NULL);
if (numBytes) {
last = objc -oc -1;
}
if (oc || numBytes) {
Tcl_GetStringFromObj(pendingPtr, &length);
}
if (length == 0) {
if (numBytes) {
first = last;
}
} else if (numBytes > INT_MAX - length) {
goto overflow;
}
length += numBytes;
}
} while (oc && (length == 0));
while (oc) {
int numBytes;
Tcl_Obj *objPtr = *ov++;
/* assert ( length > 0 && pendingPtr == NULL ) */
Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */
if (numBytes) {
last = objc - oc;
if (numBytes > INT_MAX - length) {
goto overflow;
}
length += numBytes;
}
--oc;
}
}
|
| ︙ | ︙ | |||
3096 3097 3098 3099 3100 3101 3102 |
/*
* Broken interface! Byte array value routines offer no way to handle
* failure to allocate enough space. Following stanza may panic.
*/
if (inPlace && !Tcl_IsShared(*objv)) {
| | | | | | | | 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 |
/*
* Broken interface! Byte array value routines offer no way to handle
* failure to allocate enough space. Following stanza may panic.
*/
if (inPlace && !Tcl_IsShared(*objv)) {
int start;
objResultPtr = *objv++; objc--;
Tcl_GetByteArrayFromObj(objResultPtr, &start);
dst = Tcl_SetByteArrayLength(objResultPtr, length) + start;
} else {
objResultPtr = Tcl_NewByteArrayObj(NULL, length);
dst = Tcl_SetByteArrayLength(objResultPtr, length);
}
while (objc--) {
Tcl_Obj *objPtr = *objv++;
/*
* Every argument is either a bytearray with a ("pure")
* value we know we can safely use, or it is an empty string.
* We don't need to copy bytes from the empty strings.
*/
if (TclIsPureByteArray(objPtr)) {
int more;
unsigned char *src = Tcl_GetByteArrayFromObj(objPtr, &more);
memcpy(dst, src, more);
dst += more;
}
}
} else if (allowUniChar && requestUniChar) {
/* Efficiently produce a pure Tcl_UniChar array result */
Tcl_UniChar *dst;
if (inPlace && !Tcl_IsShared(*objv)) {
int start;
objResultPtr = *objv++; objc--;
/* Ugly interface! Force resize of the unicode array. */
Tcl_GetUnicodeFromObj(objResultPtr, &start);
Tcl_InvalidateStringRep(objResultPtr);
if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"concatenation failed: unable to alloc %"
TCL_Z_MODIFIER "u bytes",
STRING_SIZE(length)));
|
| ︙ | ︙ | |||
3166 3167 3168 3169 3170 3171 3172 |
}
dst = Tcl_GetUnicode(objResultPtr);
}
while (objc--) {
Tcl_Obj *objPtr = *objv++;
if ((objPtr->bytes == NULL) || (objPtr->length)) {
| | | | | | | | | | | | 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 |
}
dst = Tcl_GetUnicode(objResultPtr);
}
while (objc--) {
Tcl_Obj *objPtr = *objv++;
if ((objPtr->bytes == NULL) || (objPtr->length)) {
int more;
Tcl_UniChar *src = Tcl_GetUnicodeFromObj(objPtr, &more);
memcpy(dst, src, more * sizeof(Tcl_UniChar));
dst += more;
}
}
} else {
/* Efficiently concatenate string reps */
char *dst;
if (inPlace && !Tcl_IsShared(*objv)) {
int start;
objResultPtr = *objv++; objc--;
Tcl_GetStringFromObj(objResultPtr, &start);
if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"concatenation failed: unable to alloc %u bytes",
length));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return NULL;
}
dst = Tcl_GetString(objResultPtr) + start;
/* assert ( length > start ) */
TclFreeIntRep(objResultPtr);
} else {
objResultPtr = Tcl_NewObj(); /* 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);
}
return NULL;
}
dst = Tcl_GetString(objResultPtr);
}
while (objc--) {
Tcl_Obj *objPtr = *objv++;
if ((objPtr->bytes == NULL) || (objPtr->length)) {
int more;
char *src = Tcl_GetStringFromObj(objPtr, &more);
memcpy(dst, src, more);
dst += more;
}
}
/* Must NUL-terminate! */
*dst = '\0';
|
| ︙ | ︙ | |||
3256 3257 3258 3259 3260 3261 3262 |
int
TclStringCmp(
Tcl_Obj *value1Ptr,
Tcl_Obj *value2Ptr,
int checkEq, /* comparison is only for equality */
int nocase, /* comparison is not case sensitive */
| | | < | | | | | 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 |
int
TclStringCmp(
Tcl_Obj *value1Ptr,
Tcl_Obj *value2Ptr,
int checkEq, /* comparison is only for equality */
int nocase, /* comparison is not case sensitive */
int reqlength) /* requested length */
{
char *s1, *s2;
int empty, length, match, s1len, s2len;
memCmpFn_t memCmpFn;
if ((reqlength == 0) || (value1Ptr == value2Ptr)) {
/*
* Always match at 0 chars of if it is the same obj.
*/
match = 0;
} else {
if (!nocase && TclIsPureByteArray(value1Ptr)
&& TclIsPureByteArray(value2Ptr)) {
/*
* Use binary versions of comparisons since that won't cause undue
* type conversions and it is much faster. Only do this if we're
* case-sensitive (which is all that really makes sense with byte
* arrays anyway, and we have no memcasecmp() for some reason... :^)
*/
s1 = (char *) Tcl_GetByteArrayFromObj(value1Ptr, &s1len);
s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
memCmpFn = memcmp;
} else if (TclHasIntRep(value1Ptr, &tclStringType)
&& TclHasIntRep(value2Ptr, &tclStringType)) {
/*
* Do a unicode-specific comparison if both of the args are of
* String type. If the char length == byte length, we can do a
* 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)Tcl_UniCharNcasecmp;
} else {
s1len = Tcl_GetCharLength(value1Ptr);
s2len = Tcl_GetCharLength(value2Ptr);
if ((s1len == value1Ptr->length)
&& (value1Ptr->bytes != NULL)
&& (s2len == value2Ptr->length)
|
| ︙ | ︙ | |||
3375 3376 3377 3378 3379 3380 3381 | * As a catch-all we will work with UTF-8. We cannot use * 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. */ | | > > | < < | | | | | > > > | | | | | | | | | | | | | | > | < > < < | < | | | < > | | | | | | > | | > > | < | | | | > > > | | | | | | | | | | > | < < > | | | | | | | | | < > | | | | | | > | | | > > | < | 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 |
* As a catch-all we will work with UTF-8. We cannot use
* 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) TclpUtfNcmp2;
} else {
s1len = Tcl_NumUtfChars(s1, s1len);
s2len = Tcl_NumUtfChars(s2, s2len);
memCmpFn = (memCmpFn_t)
(nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp);
}
}
}
length = (s1len < s2len) ? s1len : s2len;
if (reqlength > 0 && reqlength < length) {
length = reqlength;
} else if (reqlength < 0) {
/*
* The requested length is negative, so we ignore it by setting it
* to length + 1 so we correct the match var.
*/
reqlength = length + 1;
}
if (checkEq && (s1len != s2len)) {
match = 1; /* This will be reversed below. */
} else {
/*
* The comparison function should compare up to the minimum byte
* length only.
*/
match = memCmpFn(s1, s2, (size_t) length);
}
if ((match == 0) && (reqlength > length)) {
match = s1len - s2len;
}
match = (match > 0) ? 1 : (match < 0) ? -1 : 0;
}
matchdone:
return match;
}
/*
*---------------------------------------------------------------------------
*
* TclStringFirst --
*
* Implements the [string first] operation.
*
* Results:
* If needle is found as a substring of haystack, the index of the
* first instance of such a find is returned. If needle is not present
* as a substring of haystack, -1 is returned.
*
* Side effects:
* needle and haystack may have their Tcl_ObjType changed.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclStringFirst(
Tcl_Obj *needle,
Tcl_Obj *haystack,
int start)
{
int lh, ln = Tcl_GetCharLength(needle);
Tcl_Obj *result;
int value = -1;
Tcl_UniChar *check, *end, *uh, *un;
if (start < 0) {
start = 0;
}
if (ln == 0) {
/* We don't find empty substrings. Bizarre!
* Whenever this routine is turned into a proper substring
* finder, change to `return start` after limits imposed. */
goto firstEnd;
}
if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) {
unsigned char *end, *check, *bh;
unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln);
/* Find bytes in bytes */
bh = Tcl_GetByteArrayFromObj(haystack, &lh);
if ((lh < ln) || (start > lh - ln)) {
/* Don't start the loop if there cannot be a valid answer */
goto firstEnd;
}
end = bh + lh;
check = bh + start;
while (check + ln <= end) {
/*
* Look for the leading byte of the needle in the haystack
* starting at check and stopping when there's not enough room
* for the needle left.
*/
check = (unsigned char *)memchr(check, bn[0], (end + 1 - ln) - check);
if (check == NULL) {
/* Leading byte not found -> needle cannot be found. */
goto firstEnd;
}
/* Leading byte found, check rest of needle. */
if (0 == memcmp(check+1, bn+1, ln-1)) {
/* Checks! Return the successful index. */
value = (check - bh);
goto firstEnd;
}
/* Rest of needle match failed; Iterate to continue search. */
check++;
}
goto firstEnd;
}
/*
* TODO: It might be nice to support some cases where it is not
* necessary to shimmer to &tclStringType to compute the result,
* and instead operate just on the objPtr->bytes values directly.
* However, we also do not want the answer to change based on the
* code pathway, or if it does we want that to be for some values
* we explicitly decline to support. Getting there will involve
* locking down in practice more firmly just what encodings produce
* what supported results for the objPtr->bytes values. For now,
* do only the well-defined Tcl_UniChar array search.
*/
un = Tcl_GetUnicodeFromObj(needle, &ln);
uh = Tcl_GetUnicodeFromObj(haystack, &lh);
if ((lh < ln) || (start > lh - ln)) {
/* Don't start the loop if there cannot be a valid answer */
goto firstEnd;
}
end = uh + lh;
for (check = uh + start; check + ln <= end; check++) {
if ((*check == *un) && (0 ==
memcmp(check + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) {
value = (check - uh);
goto firstEnd;
}
}
firstEnd:
TclNewIntObj(result, value);
return result;
}
/*
*---------------------------------------------------------------------------
*
* TclStringLast --
*
* Implements the [string last] operation.
*
* Results:
* If needle is found as a substring of haystack, the index of the
* last instance of such a find is returned. If needle is not present
* as a substring of haystack, -1 is returned.
*
* Side effects:
* needle and haystack may have their Tcl_ObjType changed.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclStringLast(
Tcl_Obj *needle,
Tcl_Obj *haystack,
int last)
{
int lh, ln = Tcl_GetCharLength(needle);
Tcl_Obj *result;
int value = -1;
Tcl_UniChar *check, *uh, *un;
if (ln == 0) {
/*
* We don't find empty substrings. Bizarre!
*
* TODO: When we one day make this a true substring
* finder, change this to "return last", after limitation.
*/
goto lastEnd;
}
if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) {
unsigned char *check, *bh = Tcl_GetByteArrayFromObj(haystack, &lh);
unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln);
if (last >= lh) {
last = lh - 1;
}
if (last + 1 < ln) {
/* Don't start the loop if there cannot be a valid answer */
goto lastEnd;
}
check = bh + last + 1 - ln;
while (check >= bh) {
if ((*check == bn[0])
&& (0 == memcmp(check+1, bn+1, ln-1))) {
value = (check - bh);
goto lastEnd;
}
check--;
}
goto lastEnd;
}
uh = Tcl_GetUnicodeFromObj(haystack, &lh);
un = Tcl_GetUnicodeFromObj(needle, &ln);
if (last >= lh) {
last = lh - 1;
}
if (last + 1 < ln) {
/* Don't start the loop if there cannot be a valid answer */
goto lastEnd;
}
check = uh + last + 1 - ln;
while (check >= uh) {
if ((*check == un[0])
&& (0 == memcmp(check+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) {
value = (check - uh);
goto lastEnd;
}
check--;
}
lastEnd:
TclNewIntObj(result, value);
return result;
}
/*
*---------------------------------------------------------------------------
*
* TclStringReverse --
*
|
| ︙ | ︙ | |||
3625 3626 3627 3628 3629 3630 3631 |
*---------------------------------------------------------------------------
*/
static void
ReverseBytes(
unsigned char *to, /* Copy bytes into here... */
unsigned char *from, /* ...from here... */
| | | 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 |
*---------------------------------------------------------------------------
*/
static void
ReverseBytes(
unsigned char *to, /* Copy bytes into here... */
unsigned char *from, /* ...from here... */
int count) /* Until this many are copied, */
/* reversing as you go. */
{
unsigned char *src = from + count;
if (to == from) {
/* Reversing in place */
while (--src > to) {
|
| ︙ | ︙ | |||
3655 3656 3657 3658 3659 3660 3661 |
int flags)
{
String *stringPtr;
Tcl_UniChar ch = 0;
int inPlace = flags & TCL_STRING_IN_PLACE;
if (TclIsPureByteArray(objPtr)) {
| | | | 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 |
int flags)
{
String *stringPtr;
Tcl_UniChar ch = 0;
int inPlace = flags & TCL_STRING_IN_PLACE;
if (TclIsPureByteArray(objPtr)) {
int numBytes;
unsigned char *from = Tcl_GetByteArrayFromObj(objPtr, &numBytes);
if (!inPlace || Tcl_IsShared(objPtr)) {
objPtr = Tcl_NewByteArrayObj(NULL, numBytes);
}
ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, NULL), from, numBytes);
return objPtr;
}
|
| ︙ | ︙ | |||
3700 3701 3702 3703 3704 3705 3706 |
*src = *from;
*from++ = ch;
}
}
}
if (objPtr->bytes) {
| | | | | | | | 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 |
*src = *from;
*from++ = ch;
}
}
}
if (objPtr->bytes) {
int numChars = stringPtr->numChars;
int numBytes = objPtr->length;
char *to, *from = objPtr->bytes;
if (!inPlace || Tcl_IsShared(objPtr)) {
objPtr = Tcl_NewObj();
Tcl_SetObjLength(objPtr, numBytes);
}
to = objPtr->bytes;
if (numChars < numBytes) {
/*
* Either numChars == -1 and we don't know how many chars are
* represented by objPtr->bytes and we need Pass 1 just in case,
* or numChars >= 0 and we know we have fewer chars than bytes, so
* we know there's a multibyte character needing Pass 1.
*
* Pass 1. Reverse the bytes of each multi-byte character.
*/
int charCount = 0;
int bytesLeft = numBytes;
while (bytesLeft) {
/*
* NOTE: We know that the from buffer is NUL-terminated. It's
* part of the contract for objPtr->bytes values. Thus, we can
* skip calling Tcl_UtfCharComplete() here.
*/
int bytesInChar = TclUtfToUniChar(from, &ch);
ReverseBytes((unsigned char *)to, (unsigned char *)from,
bytesInChar);
to += bytesInChar;
from += bytesInChar;
bytesLeft -= bytesInChar;
charCount++;
|
| ︙ | ︙ | |||
3780 3781 3782 3783 3784 3785 3786 |
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclStringReplace(
Tcl_Interp *interp, /* For error reporting, may be NULL */
Tcl_Obj *objPtr, /* String to act upon */
| | | > > > > | | | 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 |
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclStringReplace(
Tcl_Interp *interp, /* For error reporting, may be NULL */
Tcl_Obj *objPtr, /* String to act upon */
int first, /* First index to replace */
int count, /* How many chars to replace */
Tcl_Obj *insertPtr, /* Replacement string, may be NULL */
int flags) /* TCL_STRING_IN_PLACE => attempt in-place */
{
int inPlace = flags & TCL_STRING_IN_PLACE;
Tcl_Obj *result;
/* Caller is expected to pass sensible arguments */
assert ( count >= 0 ) ;
assert ( first >= 0 ) ;
/* Replace nothing with nothing */
if ((insertPtr == NULL) && (count == 0)) {
if (inPlace) {
return objPtr;
} else {
return Tcl_DuplicateObj(objPtr);
}
}
/*
* The caller very likely had to call Tcl_GetCharLength() or similar
* to be able to process index values. This means it is likely that
* objPtr is either a proper "bytearray" or a "string" or else it has
* a known and short string rep.
*/
if (TclIsPureByteArray(objPtr)) {
int numBytes;
unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &numBytes);
if (insertPtr == NULL) {
/* Replace something with nothing. */
assert ( first <= numBytes ) ;
assert ( count <= numBytes ) ;
assert ( first + count <= numBytes ) ;
|
| ︙ | ︙ | |||
3828 3829 3830 3831 3832 3833 3834 |
/* Replace everything */
if ((first == 0) && (count == numBytes)) {
return insertPtr;
}
if (TclIsPureByteArray(insertPtr)) {
| | | | | 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 |
/* Replace everything */
if ((first == 0) && (count == numBytes)) {
return insertPtr;
}
if (TclIsPureByteArray(insertPtr)) {
int newBytes;
unsigned char *iBytes
= Tcl_GetByteArrayFromObj(insertPtr, &newBytes);
if (count == newBytes && inPlace && !Tcl_IsShared(objPtr)) {
/*
* Removal count and replacement count are equal.
* Other conditions permit. Do in-place splice.
*/
memcpy(bytes + first, iBytes, count);
Tcl_InvalidateStringRep(objPtr);
return objPtr;
}
if (newBytes > INT_MAX - (numBytes - count)) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"max size for a Tcl value (%d bytes) exceeded",
INT_MAX));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
return NULL;
|
| ︙ | ︙ | |||
3873 3874 3875 3876 3877 3878 3879 |
* TODO: Figure out how not to generate a Tcl_UniChar array rep
* when it can be determined objPtr->bytes points to a string of
* all single-byte characters so we can index it directly.
*/
/* The traditional implementation... */
{
| | | | | 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 |
* TODO: Figure out how not to generate a Tcl_UniChar array rep
* when it can be determined objPtr->bytes points to a string of
* all single-byte characters so we can index it directly.
*/
/* The traditional implementation... */
{
int numChars;
Tcl_UniChar *ustring = Tcl_GetUnicodeFromObj(objPtr, &numChars);
/* TODO: Is there an in-place option worth pursuing here? */
result = Tcl_NewUnicodeObj(ustring, first);
if (insertPtr) {
Tcl_AppendObjToObj(result, insertPtr);
}
if (first + count < numChars) {
Tcl_AppendUnicodeToObj(result, ustring + first + count,
numChars - first - count);
}
return result;
}
}
|
| ︙ | ︙ | |||
3923 3924 3925 3926 3927 3928 3929 |
stringPtr->numChars);
}
static void
ExtendUnicodeRepWithString(
Tcl_Obj *objPtr,
const char *bytes,
| | | | | > | 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 |
stringPtr->numChars);
}
static void
ExtendUnicodeRepWithString(
Tcl_Obj *objPtr,
const char *bytes,
int numBytes,
int numAppendChars)
{
String *stringPtr = GET_STRING(objPtr);
int needed, numOrigChars = 0;
Tcl_UniChar *dst, unichar = 0;
if (stringPtr->hasUnicode) {
numOrigChars = stringPtr->numChars;
}
if (numAppendChars == -1) {
TclNumUtfChars(numAppendChars, bytes, numBytes);
}
needed = numOrigChars + numAppendChars;
stringCheckLimits(needed);
if (needed > stringPtr->maxChars) {
GrowUnicodeBuffer(objPtr, needed);
stringPtr = GET_STRING(objPtr);
}
stringPtr->hasUnicode = 1;
|
| ︙ | ︙ | |||
3984 3985 3986 3987 3988 3989 3990 |
* an internal rep of type "String". */
Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not
* currently have an internal rep.*/
{
String *srcStringPtr = GET_STRING(srcPtr);
String *copyStringPtr = NULL;
| | | 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 |
* an internal rep of type "String". */
Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not
* currently have an internal rep.*/
{
String *srcStringPtr = GET_STRING(srcPtr);
String *copyStringPtr = NULL;
if (srcStringPtr->numChars == -1) {
/*
* The String struct in the source value holds zero useful data. Don't
* bother copying it. Don't even bother allocating space in which to
* copy it. Just let the copy be untyped.
*/
return;
|
| ︙ | ︙ | |||
4050 4051 4052 4053 4054 4055 4056 | * representation is set to "String". * *---------------------------------------------------------------------- */ static int SetStringFromAny( | | | 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 |
* representation is set to "String".
*
*----------------------------------------------------------------------
*/
static int
SetStringFromAny(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *objPtr) /* The object to convert. */
{
if (!TclHasIntRep(objPtr, &tclStringType)) {
String *stringPtr = stringAlloc(0);
/*
* Convert whatever we have into an untyped value. Just A String.
|
| ︙ | ︙ | |||
4120 4121 4122 4123 4124 4125 4126 |
TclInitStringRep(objPtr, NULL, 0);
} else {
(void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode,
stringPtr->numChars);
}
}
| | | | | | 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 |
TclInitStringRep(objPtr, NULL, 0);
} else {
(void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode,
stringPtr->numChars);
}
}
static int
ExtendStringRepWithUnicode(
Tcl_Obj *objPtr,
const Tcl_UniChar *unicode,
int numChars)
{
/*
* Pre-condition: this is the "string" Tcl_ObjType.
*/
int i, origLength, size = 0;
char *dst;
String *stringPtr = GET_STRING(objPtr);
if (numChars < 0) {
numChars = UnicodeLength(unicode);
}
if (numChars == 0) {
return 0;
}
|
| ︙ | ︙ | |||
4156 4157 4158 4159 4160 4161 4162 |
*/
if (numChars <= (INT_MAX - size)/TCL_UTF_MAX
&& stringPtr->allocated >= size + numChars * TCL_UTF_MAX) {
goto copyBytes;
}
| | > > > | 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 |
*/
if (numChars <= (INT_MAX - size)/TCL_UTF_MAX
&& stringPtr->allocated >= size + numChars * TCL_UTF_MAX) {
goto copyBytes;
}
for (i = 0; i < numChars && size >= 0; i++) {
size += TclUtfCount(unicode[i]);
}
if (size < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
/*
* Grow space if needed.
*/
if (size > stringPtr->allocated) {
GrowStringBuffer(objPtr, size, 1);
|
| ︙ | ︙ | |||
4199 4200 4201 4202 4203 4204 4205 |
*----------------------------------------------------------------------
*/
static void
FreeStringInternalRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
| | | 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 |
*----------------------------------------------------------------------
*/
static void
FreeStringInternalRep(
Tcl_Obj *objPtr) /* Object with internal rep to free. */
{
ckfree(GET_STRING(objPtr));
objPtr->typePtr = NULL;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclStringRep.h.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 | * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ | < < < < | | | | > > > > > > > > > | | | | < | 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 |
*
* Copyright (c) 1995-1997 Sun Microsystems, Inc.
* Copyright (c) 1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
/*
* The following structure is the internal rep for a String object. It keeps
* track of how much memory has been used and how much has been allocated for
* the Unicode and UTF string to enable growing and shrinking of the UTF and
* Unicode reps of the String object with fewer mallocs. To optimize string
* length and indexing operations, this structure also stores the number of
* characters (same of UTF and Unicode!) once that value has been computed.
*
* Under normal configurations, what Tcl calls "Unicode" is actually UTF-16
* restricted to the Basic Multilingual Plane (i.e. U+00000 to U+0FFFF). This
* can be officially modified by altering the definition of Tcl_UniChar in
* tcl.h, but do not do that unless you are sure what you're doing!
*/
typedef struct {
int numChars; /* The number of chars in the string. -1 means
* this value has not been calculated. >= 0
* means that there is a valid Unicode rep, or
* that the number of UTF bytes == the number
* of chars. */
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[1]; /* 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 - sizeof(String))/sizeof(Tcl_UniChar))
#define STRING_SIZE(numChars) \
(sizeof(String) + ((numChars) * 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)
#define stringAttemptAlloc(numChars) \
(String *) attemptckalloc(STRING_SIZE(numChars))
#define stringAlloc(numChars) \
(String *) ckalloc(STRING_SIZE(numChars))
#define stringRealloc(ptr, numChars) \
(String *) ckrealloc((ptr), STRING_SIZE(numChars))
#define stringAttemptRealloc(ptr, numChars) \
(String *) attemptckrealloc((ptr), STRING_SIZE(numChars))
#define GET_STRING(objPtr) \
((String *) (objPtr)->internalRep.twoPtrValue.ptr1)
#define SET_STRING(objPtr, stringPtr) \
((objPtr)->internalRep.twoPtrValue.ptr2 = NULL), \
((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr))
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclStringTrim.h.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 31 32 33 34 35 36 37 | */ MODULE_SCOPE const char tclDefaultTrimSet[]; /* * The whitespace trimming set used when [concat]enating. This is a subset of * the above, and deliberately so. */ #define CONCAT_TRIM_SET " \f\v\r\t\n" #endif /* TCL_STRING_TRIM_H */ /* | > > | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | */ MODULE_SCOPE const char tclDefaultTrimSet[]; /* * The whitespace trimming set used when [concat]enating. This is a subset of * the above, and deliberately so. * * TODO: Find a reasonable way to guarantee in sync with TclIsSpaceProc() */ #define CONCAT_TRIM_SET " \f\v\r\t\n" #endif /* TCL_STRING_TRIM_H */ /* |
| ︙ | ︙ |
Changes to generic/tclStubInit.c.
1 2 3 4 5 6 7 8 9 10 11 12 | /* * tclStubInit.c -- * * This file contains the initializers for the Tcl stub vectors. * * Copyright (c) 1998-1999 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | > | | > > > > > > > > > > > > > > > > > > | > > | > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | > > > > | | | > > > > > | < > > | > | > > > > > > > > | > | > > | < < < | | | < | | | < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 |
/*
* tclStubInit.c --
*
* This file contains the initializers for the Tcl stub vectors.
*
* Copyright (c) 1998-1999 by Scriptics Corporation.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#include "tommath_private.h"
#include "tclTomMath.h"
#ifdef __CYGWIN__
# include <wchar.h>
#endif
#ifdef __GNUC__
#pragma GCC dependency "tcl.decls"
#pragma GCC dependency "tclInt.decls"
#pragma GCC dependency "tclTomMath.decls"
#endif
/*
* Remove macros that will interfere with the definitions below.
*/
#undef Tcl_Alloc
#undef Tcl_Free
#undef Tcl_Realloc
#undef Tcl_NewBooleanObj
#undef Tcl_NewByteArrayObj
#undef Tcl_NewDoubleObj
#undef Tcl_NewIntObj
#undef Tcl_NewListObj
#undef Tcl_NewLongObj
#undef Tcl_DbNewLongObj
#undef Tcl_NewObj
#undef Tcl_NewStringObj
#undef Tcl_GetUnicode
#undef Tcl_GetUnicodeFromObj
#undef Tcl_AppendUnicodeToObj
#undef Tcl_NewUnicodeObj
#undef Tcl_SetUnicodeObj
#undef Tcl_UniCharNcasecmp
#undef Tcl_UniCharCaseMatch
#undef Tcl_UniCharLen
#undef Tcl_UniCharNcmp
#undef Tcl_DumpActiveMemory
#undef Tcl_ValidateAllMemory
#undef Tcl_FindHashEntry
#undef Tcl_CreateHashEntry
#undef Tcl_Panic
#undef Tcl_FindExecutable
#undef Tcl_SetExitProc
#undef Tcl_SetPanicProc
#undef TclpGetPid
#undef TclSockMinimumBuffers
#undef Tcl_SetIntObj
#undef Tcl_SetLongObj
#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
static void uniCodePanic(void) {
Tcl_Panic("This extension uses a deprecated function, not available now: Tcl is compiled with -DTCL_UTF_MAX==%d", TCL_UTF_MAX);
}
# define Tcl_GetUnicode (int *(*)(Tcl_Obj *))(void *)uniCodePanic
# define Tcl_GetUnicodeFromObj (int *(*)(Tcl_Obj *, Tcl_UniChar *))(void *)uniCodePanic
# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const int *, Tcl_UniChar))(void *)uniCodePanic
# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, int))(void *)uniCodePanic
# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const Tcl_UniChar *, int))(void *)uniCodePanic
# define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, unsigned long))(void *)uniCodePanic
# define Tcl_UniCharCaseMatch (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, int))(void *)uniCodePanic
# define Tcl_UniCharLen (int(*)(const Tcl_UniChar *))(void *)uniCodePanic
# define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar *, const Tcl_UniChar *, unsigned long))(void *)uniCodePanic
#endif
#define TclBN_mp_add mp_add
#define TclBN_mp_and mp_and
#define TclBN_mp_clamp mp_clamp
#define TclBN_mp_clear mp_clear
#define TclBN_mp_clear_multi mp_clear_multi
#define TclBN_mp_cmp mp_cmp
#define TclBN_mp_cmp_mag mp_cmp_mag
#define TclBN_mp_cnt_lsb mp_cnt_lsb
#define TclBN_mp_copy mp_copy
#define TclBN_mp_count_bits mp_count_bits
#define TclBN_mp_div mp_div
#define TclBN_mp_div_2 mp_div_2
#define TclBN_mp_div_2d mp_div_2d
#define TclBN_mp_exch mp_exch
#define TclBN_mp_get_mag_u64 mp_get_mag_u64
#define TclBN_mp_grow mp_grow
#define TclBN_mp_init mp_init
#define TclBN_mp_init_copy mp_init_copy
#define TclBN_mp_init_multi mp_init_multi
#define TclBN_mp_init_size mp_init_size
#define TclBN_mp_init_i64 mp_init_i64
#define TclBN_mp_init_u64 mp_init_u64
#define TclBN_mp_lshd mp_lshd
#define TclBN_mp_mod mp_mod
#define TclBN_mp_mod_2d mp_mod_2d
#define TclBN_mp_mul mp_mul
#define TclBN_mp_mul_2 mp_mul_2
#define TclBN_mp_mul_2d mp_mul_2d
#define TclBN_mp_neg mp_neg
#define TclBN_mp_or mp_or
#define TclBN_mp_radix_size mp_radix_size
#define TclBN_mp_reverse mp_reverse
#define TclBN_mp_read_radix mp_read_radix
#define TclBN_mp_rshd mp_rshd
#define TclBN_mp_set_i64 mp_set_i64
#define TclBN_mp_set_u64 mp_set_u64
#define TclBN_mp_shrink mp_shrink
#define TclBN_mp_sqr mp_sqr
#define TclBN_mp_sqrt mp_sqrt
#define TclBN_mp_sub mp_sub
#define TclBN_mp_signed_rsh mp_signed_rsh
#define TclBN_mp_tc_and TclBN_mp_and
#define TclBN_mp_tc_div_2d mp_signed_rsh
#define TclBN_mp_tc_or TclBN_mp_or
#define TclBN_mp_tc_xor TclBN_mp_xor
#define TclBN_mp_to_radix mp_to_radix
#define TclBN_mp_to_ubin mp_to_ubin
#define TclBN_mp_ubin_size mp_ubin_size
#define TclBN_mp_xor mp_xor
#define TclBN_mp_zero mp_zero
#define TclBN_s_mp_add s_mp_add
#define TclBN_s_mp_balance_mul mp_balance_mul
#define TclBN_mp_karatsuba_mul s_mp_karatsuba_mul
#define TclBN_mp_karatsuba_sqr s_mp_karatsuba_sqr
#define TclBN_s_mp_mul_digs s_mp_mul_digs
#define TclBN_s_mp_mul_digs_fast s_mp_mul_digs_fast
#define TclBN_s_mp_reverse s_mp_reverse
#define TclBN_s_mp_sqr s_mp_sqr
#define TclBN_s_mp_sqr_fast s_mp_sqr_fast
#define TclBN_s_mp_sub s_mp_sub
#define TclBN_mp_toom_mul s_mp_toom_mul
#define TclBN_mp_toom_sqr s_mp_toom_sqr
#define TclUnusedStubEntry NULL
/* See bug 510001: TclSockMinimumBuffers needs plat imp */
#if defined(_WIN64) || defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
# define TclSockMinimumBuffersOld 0
#else
#define TclSockMinimumBuffersOld sockMinimumBuffersOld
static int TclSockMinimumBuffersOld(int sock, int size)
{
return TclSockMinimumBuffers(INT2PTR(sock), size);
}
#endif
mp_err TclBN_mp_set_int(mp_int *a, unsigned long i)
{
TclBN_mp_set_u64(a, i);
return MP_OKAY;
}
static mp_err TclBN_mp_set_long(mp_int *a, unsigned long i)
{
TclBN_mp_set_u64(a, i);
return MP_OKAY;
}
#define TclBN_mp_set_ul (void (*)(mp_int *a, unsigned long i))(void *)TclBN_mp_set_long
mp_err MP_WUR TclBN_mp_expt_u32(const mp_int *a, unsigned int b, mp_int *c) {
return mp_expt_u32(a, b, c);
}
mp_err TclBN_mp_add_d(const mp_int *a, unsigned int b, mp_int *c) {
return mp_add_d(a, b, c);
}
mp_err TclBN_mp_cmp_d(const mp_int *a, unsigned int b) {
return mp_cmp_d(a, b);
}
mp_err TclBN_mp_sub_d(const mp_int *a, unsigned int b, mp_int *c) {
return mp_sub_d(a, b, c);
}
mp_err TclBN_mp_div_d(const mp_int *a, unsigned int b, mp_int *c, unsigned int *d) {
mp_digit d2;
mp_err result = mp_div_d(a, b, c, (d ? &d2 : NULL));
if (d) {
*d = d2;
}
return result;
}
mp_err TclBN_mp_div_ld(const mp_int *a, uint64_t b, mp_int *c, uint64_t *d) {
mp_err result;
mp_digit d2;
if ((b | (mp_digit)-1) != (mp_digit)-1) {
return MP_VAL;
}
result = mp_div_d(a, b, c, (d ? &d2 : NULL));
if (d) {
*d = d2;
}
return result;
}
mp_err TclBN_mp_init_set(mp_int *a, unsigned int b) {
return mp_init_set(a, b);
}
mp_err TclBN_mp_mul_d(const mp_int *a, unsigned int b, mp_int *c) {
return mp_mul_d(a, b, c);
}
#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
# define TclBN_mp_expt_d_ex 0
# define TclBN_mp_to_unsigned_bin 0
# define TclBN_mp_to_unsigned_bin_n 0
# define TclBN_mp_toradix_n 0
# undef TclBN_mp_sqr
# define TclBN_mp_sqr 0
# undef TclBN_mp_div_3
# define TclBN_mp_div_3 0
# define TclBN_mp_init_l 0
# define TclBN_mp_init_ul 0
# define TclBN_mp_set 0
# define TclSetStartupScriptPath 0
# define TclGetStartupScriptPath 0
# define TclSetStartupScriptFileName 0
# define TclGetStartupScriptFileName 0
# define TclPrecTraceProc 0
# define TclpInetNtoa 0
# define TclWinGetServByName 0
# define TclWinGetSockOpt 0
# define TclWinSetSockOpt 0
# define TclWinNToHS 0
# define TclWinGetPlatformId 0
# define TclWinResetInterfaces 0
# define TclWinSetInterfaces 0
# define TclWinGetPlatformId 0
# define Tcl_Backslash 0
# define Tcl_GetDefaultEncodingDir 0
# define Tcl_SetDefaultEncodingDir 0
# define Tcl_EvalTokens 0
# define Tcl_CreateMathFunc 0
# define Tcl_GetMathFuncInfo 0
# define Tcl_ListMathFuncs 0
# define Tcl_SetIntObj 0
# define Tcl_SetLongObj 0
# define Tcl_NewIntObj 0
# define Tcl_NewLongObj 0
# define Tcl_DbNewLongObj 0
# define Tcl_BackgroundError 0
# define Tcl_FreeResult 0
# define Tcl_ChannelSeekProc 0
# define Tcl_ChannelCloseProc 0
# define Tcl_Close 0
# define Tcl_MacOSXOpenBundleResources 0
#else
mp_err TclBN_mp_div_3(const mp_int *a, mp_int *c, unsigned int *d) {
mp_digit d2;
mp_err result = mp_div_d(a, 3, c, &d2);
if (d) {
*d = d2;
}
return result;
}
int TclBN_mp_expt_d_ex(const mp_int *a, unsigned int b, mp_int *c,
TCL_UNUSED(int) /*fast*/)
{
return TclBN_mp_expt_u32(a, b, c);
}
mp_err TclBN_mp_to_unsigned_bin(const mp_int *a, unsigned char *b)
{
return TclBN_mp_to_ubin(a, b, INT_MAX, NULL);
}
mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen)
{
size_t n = TclBN_mp_ubin_size(a);
if (*outlen < (unsigned long)n) {
return MP_VAL;
}
*outlen = (unsigned long)n;
return TclBN_mp_to_ubin(a, b, n, NULL);
}
void TclBN_reverse(unsigned char *s, int len)
{
if (len > 0) {
TclBN_s_mp_reverse(s, (size_t)len);
}
}
mp_err TclBN_mp_init_ul(mp_int *a, unsigned long b)
{
return TclBN_mp_init_u64(a,b);
}
mp_err TclBN_mp_init_l(mp_int *a, long b)
{
return TclBN_mp_init_i64(a,b);
}
void TclBN_mp_set(mp_int *a, unsigned int b) {
TclBN_mp_set_u64(a, b);
}
mp_err TclBN_mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen)
{
if (maxlen < 0) {
return MP_VAL;
}
return TclBN_mp_to_radix(a, str, (size_t)maxlen, NULL, radix);
}
#define TclSetStartupScriptPath setStartupScriptPath
static void TclSetStartupScriptPath(Tcl_Obj *path)
{
Tcl_SetStartupScript(path, NULL);
}
#define TclGetStartupScriptPath getStartupScriptPath
static Tcl_Obj *TclGetStartupScriptPath(void)
{
return Tcl_GetStartupScript(NULL);
}
#define TclSetStartupScriptFileName setStartupScriptFileName
static void TclSetStartupScriptFileName(
const char *fileName)
{
Tcl_SetStartupScript(Tcl_NewStringObj(fileName,-1), NULL);
}
#define TclGetStartupScriptFileName getStartupScriptFileName
static const char *TclGetStartupScriptFileName(void)
{
Tcl_Obj *path = Tcl_GetStartupScript(NULL);
if (path == NULL) {
return NULL;
}
return Tcl_GetString(path);
}
#if defined(_WIN32) || defined(__CYGWIN__)
#undef TclWinNToHS
#undef TclWinGetPlatformId
#undef TclWinResetInterfaces
#undef TclWinSetInterfaces
static void
doNothing(void)
{
/* dummy implementation, no need to do anything */
}
#define TclWinNToHS winNToHS
static unsigned short TclWinNToHS(unsigned short ns) {
return ntohs(ns);
}
#define TclWinGetPlatformId winGetPlatformId
static int
TclWinGetPlatformId(void)
{
return 2; /* VER_PLATFORM_WIN32_NT */;
}
#define TclWinResetInterfaces doNothing
#define TclWinSetInterfaces (void (*) (int)) doNothing
#endif
#endif /* TCL_NO_DEPRECATED */
#define TclpCreateTempFile_ TclpCreateTempFile
#define TclUnixWaitForFile_ TclUnixWaitForFile
#ifndef MAC_OSX_TCL /* On UNIX, fill with other stub entries */
#define TclMacOSXGetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj **))(void *)TclpCreateProcess
#define TclMacOSXSetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj *))(void *)isatty
#define TclMacOSXCopyFileAttributes (int (*)(const char *, const char *, const Tcl_StatBuf *))(void *)TclUnixCopyFile
#define TclMacOSXMatchType (int (*)(Tcl_Interp *, const char *, const char *, Tcl_StatBuf *, Tcl_GlobTypeData *))(void *)TclpMakeFile
#define TclMacOSXNotifierAddRunLoopMode (void (*)(const void *))(void *)TclpOpenFile
#endif
#ifdef _WIN32
# define TclUnixWaitForFile 0
# define TclUnixCopyFile 0
# define TclUnixOpenTemporaryFile 0
# define TclpReaddir 0
# define TclpIsAtty 0
#elif defined(__CYGWIN__)
# define TclpIsAtty isatty
#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
static void
doNothing(void)
{
/* dummy implementation, no need to do anything */
}
#endif
# define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing
# define TclWinFlushDirtyChannels doNothing
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
#define TclWinSetSockOpt winSetSockOpt
static int
TclWinSetSockOpt(SOCKET s, int level, int optname,
const char *optval, int optlen)
{
return setsockopt((int) s, level, optname, optval, optlen);
}
#define TclWinGetSockOpt winGetSockOpt
static int
TclWinGetSockOpt(SOCKET s, int level, int optname,
char *optval, int *optlen)
{
return getsockopt((int) s, level, optname, optval, optlen);
}
#define TclWinGetServByName winGetServByName
static struct servent *
TclWinGetServByName(const char *name, const char *proto)
{
return getservbyname(name, proto);
}
#endif /* TCL_NO_DEPRECATED */
#define TclWinNoBackslash winNoBackslash
static char *
TclWinNoBackslash(char *path)
{
char *p;
for (p = path; *p != '\0'; p++) {
if (*p == '\\') {
*p = '/';
}
}
return path;
}
void *TclWinGetTclInstance()
{
void *hInstance = NULL;
GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS,
(const wchar_t *)&TclWinNoBackslash, &hInstance);
return hInstance;
}
int
TclpGetPid(Tcl_Pid pid)
{
return (int) (size_t) pid;
}
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
#undef Tcl_WinUtfToTChar
char *
Tcl_WinUtfToTChar(
const char *string,
int len,
Tcl_DString *dsPtr)
{
Tcl_DStringInit(dsPtr);
return (char *)Tcl_UtfToChar16DString(string, len, dsPtr);
}
#undef Tcl_WinTCharToUtf
char *
Tcl_WinTCharToUtf(
const char *string,
int len,
Tcl_DString *dsPtr)
{
Tcl_DStringInit(dsPtr);
return Tcl_Char16ToUtfDString((const unsigned short *)string, len >> 1, dsPtr);
}
#endif /* !defined(TCL_NO_DEPRECATED) */
#if defined(TCL_WIDE_INT_IS_LONG)
/* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore
* we have to make sure that all stub entries on Cygwin64 follow the Win64
* signature. Tcl 9 must find a better solution, but that cannot be done
* without introducing a binary incompatibility.
*/
|
| ︙ | ︙ | |||
169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 |
"integer value too large to represent as non-long integer", -1));
result = TCL_ERROR;
}
}
return result;
}
#define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))exprIntObj
#endif /* TCL_WIDE_INT_IS_LONG */
#endif /* __CYGWIN__ */
/*
* WARNING: The contents of this file is automatically generated by the
* tools/genStubs.tcl script. Any modifications to the function declarations
* below should be made in the generic/tcl.decls script.
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 |
"integer value too large to represent as non-long integer", -1));
result = TCL_ERROR;
}
}
return result;
}
#define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))exprIntObj
#if TCL_UTF_MAX < 4 && !defined(TCL_NO_DEPRECATED)
static int uniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){
return Tcl_UniCharNcmp(ucs, uct, (unsigned long)n);
}
#define Tcl_UniCharNcmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))(void *)uniCharNcmp
static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned int n){
return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n);
}
#define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))(void *)uniCharNcasecmp
#endif
static int utfNcmp(const char *s1, const char *s2, unsigned int n){
return Tcl_UtfNcmp(s1, s2, (unsigned long)n);
}
#define Tcl_UtfNcmp (int(*)(const char*,const char*,unsigned long))(void *)utfNcmp
static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){
return Tcl_UtfNcasecmp(s1, s2, (unsigned long)n);
}
#define Tcl_UtfNcasecmp (int(*)(const char*,const char*,unsigned long))(void *)utfNcasecmp
#endif /* TCL_WIDE_INT_IS_LONG */
#endif /* __CYGWIN__ */
#if defined(TCL_NO_DEPRECATED)
# define Tcl_SeekOld 0
# define Tcl_TellOld 0
# undef Tcl_SetBooleanObj
# define Tcl_SetBooleanObj 0
# undef Tcl_PkgPresent
# define Tcl_PkgPresent 0
# undef Tcl_PkgProvide
# define Tcl_PkgProvide 0
# undef Tcl_PkgRequire
# define Tcl_PkgRequire 0
# undef Tcl_GetIndexFromObj
# define Tcl_GetIndexFromObj 0
# define Tcl_NewBooleanObj 0
# undef Tcl_DbNewBooleanObj
# define Tcl_DbNewBooleanObj 0
# undef Tcl_SetBooleanObj
# define Tcl_SetBooleanObj 0
# undef Tcl_SetVar
# define Tcl_SetVar 0
# undef Tcl_UnsetVar
# define Tcl_UnsetVar 0
# undef Tcl_GetVar
# define Tcl_GetVar 0
# undef Tcl_TraceVar
# define Tcl_TraceVar 0
# undef Tcl_UntraceVar
# define Tcl_UntraceVar 0
# undef Tcl_VarTraceInfo
# define Tcl_VarTraceInfo 0
# undef Tcl_UpVar
# define Tcl_UpVar 0
# undef Tcl_AddErrorInfo
# define Tcl_AddErrorInfo 0
# undef Tcl_AddObjErrorInfo
# define Tcl_AddObjErrorInfo 0
# undef Tcl_Eval
# define Tcl_Eval 0
# undef Tcl_GlobalEval
# define Tcl_GlobalEval 0
# undef Tcl_GetStringResult
# define Tcl_GetStringResult 0
# undef Tcl_SaveResult
# define Tcl_SaveResult 0
# undef Tcl_RestoreResult
# define Tcl_RestoreResult 0
# undef Tcl_DiscardResult
# define Tcl_DiscardResult 0
# undef Tcl_SetResult
# define Tcl_SetResult 0
# undef Tcl_EvalObj
# define Tcl_EvalObj 0
# undef Tcl_GlobalEvalObj
# define Tcl_GlobalEvalObj 0
# define TclBackgroundException 0
# undef TclpReaddir
# define TclpReaddir 0
# define TclSetStartupScript 0
# define TclGetStartupScript 0
# define TclGetIntForIndex 0
# define TclCreateNamespace 0
# define TclDeleteNamespace 0
# define TclAppendExportList 0
# define TclExport 0
# define TclImport 0
# define TclForgetImport 0
# define TclGetCurrentNamespace_ 0
# define TclGetGlobalNamespace_ 0
# define TclFindNamespace 0
# define TclFindCommand 0
# define TclGetCommandFromObj 0
# define TclGetCommandFullName 0
# define TclCopyChannelOld 0
# define Tcl_AppendResultVA 0
# define Tcl_AppendStringsToObjVA 0
# define Tcl_SetErrorCodeVA 0
# define Tcl_PanicVA 0
# define Tcl_VarEvalVA 0
# undef TclpGetDate
# define TclpGetDate 0
# undef TclpLocaltime
# define TclpLocaltime 0
# undef TclpGmtime
# define TclpGmtime 0
# define TclpLocaltime_unix 0
# define TclpGmtime_unix 0
# define Tcl_SetExitProc 0
# define Tcl_SetPanicProc 0
# define Tcl_FindExecutable 0
# define Tcl_GetUnicode 0
#if TCL_UTF_MAX < 4
# define Tcl_AppendUnicodeToObj 0
# define Tcl_UniCharCaseMatch 0
# define Tcl_UniCharLen 0
# define Tcl_UniCharNcasecmp 0
# define Tcl_UniCharNcmp 0
#endif
# undef Tcl_StringMatch
# define Tcl_StringMatch 0
# define TclBN_reverse 0
# undef TclBN_s_mp_mul_digs_fast
# define TclBN_s_mp_mul_digs_fast 0
# undef TclBN_s_mp_sqr_fast
# define TclBN_s_mp_sqr_fast 0
# undef TclBN_mp_karatsuba_mul
# define TclBN_mp_karatsuba_mul 0
# undef TclBN_mp_karatsuba_sqr
# define TclBN_mp_karatsuba_sqr 0
# undef TclBN_mp_toom_mul
# define TclBN_mp_toom_mul 0
# undef TclBN_mp_toom_sqr
# define TclBN_mp_toom_sqr 0
# undef TclBN_s_mp_add
# define TclBN_s_mp_add 0
# undef TclBN_s_mp_mul_digs
# define TclBN_s_mp_mul_digs 0
# undef TclBN_s_mp_sqr
# define TclBN_s_mp_sqr 0
# undef TclBN_s_mp_sub
# define TclBN_s_mp_sub 0
#else /* TCL_NO_DEPRECATED */
# define Tcl_SeekOld seekOld
# define Tcl_TellOld tellOld
# define TclBackgroundException Tcl_BackgroundException
# define TclSetStartupScript Tcl_SetStartupScript
# define TclGetStartupScript Tcl_GetStartupScript
# define TclGetIntForIndex Tcl_GetIntForIndex
# define TclCreateNamespace Tcl_CreateNamespace
# define TclDeleteNamespace Tcl_DeleteNamespace
# define TclAppendExportList Tcl_AppendExportList
# define TclExport Tcl_Export
# define TclImport Tcl_Import
# define TclForgetImport Tcl_ForgetImport
# define TclGetCurrentNamespace_ Tcl_GetCurrentNamespace
# define TclGetGlobalNamespace_ Tcl_GetGlobalNamespace
# define TclFindNamespace Tcl_FindNamespace
# define TclFindCommand Tcl_FindCommand
# define TclGetCommandFromObj Tcl_GetCommandFromObj
# define TclGetCommandFullName Tcl_GetCommandFullName
# define TclpLocaltime_unix TclpLocaltime
# define TclpGmtime_unix TclpGmtime
static int
seekOld(
Tcl_Channel chan, /* The channel on which to seek. */
int offset, /* Offset to seek to. */
int mode) /* Relative to which location to seek? */
{
return Tcl_Seek(chan, offset, mode);
}
static int
tellOld(
Tcl_Channel chan) /* The channel to return pos for. */
{
return Tcl_Tell(chan);
}
#endif /* !TCL_NO_DEPRECATED */
#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
#define Tcl_WinUtfToTChar 0
#define Tcl_WinTCharToUtf 0
#endif
/*
* WARNING: The contents of this file is automatically generated by the
* tools/genStubs.tcl script. Any modifications to the function declarations
* below should be made in the generic/tcl.decls script.
*/
|
| ︙ | ︙ | |||
204 205 206 207 208 209 210 |
0, /* 1 */
0, /* 2 */
TclAllocateFreeObjects, /* 3 */
0, /* 4 */
TclCleanupChildren, /* 5 */
TclCleanupCommand, /* 6 */
TclCopyAndCollapse, /* 7 */
| | | 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 |
0, /* 1 */
0, /* 2 */
TclAllocateFreeObjects, /* 3 */
0, /* 4 */
TclCleanupChildren, /* 5 */
TclCleanupCommand, /* 6 */
TclCopyAndCollapse, /* 7 */
TclCopyChannelOld, /* 8 */
TclCreatePipeline, /* 9 */
TclCreateProc, /* 10 */
TclDeleteCompiledLocalVars, /* 11 */
TclDeleteVars, /* 12 */
0, /* 13 */
TclDumpMemoryInfo, /* 14 */
0, /* 15 */
|
| ︙ | ︙ | |||
230 231 232 233 234 235 236 |
0, /* 27 */
TclpGetDefaultStdChannel, /* 28 */
0, /* 29 */
0, /* 30 */
TclGetExtension, /* 31 */
TclGetFrame, /* 32 */
0, /* 33 */
| | | 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 |
0, /* 27 */
TclpGetDefaultStdChannel, /* 28 */
0, /* 29 */
0, /* 30 */
TclGetExtension, /* 31 */
TclGetFrame, /* 32 */
0, /* 33 */
TclGetIntForIndex, /* 34 */
0, /* 35 */
0, /* 36 */
TclGetLoadedPackages, /* 37 */
TclGetNamespaceForQualName, /* 38 */
TclGetObjInterpProc, /* 39 */
TclGetOpenMode, /* 40 */
TclGetOriginalCommand, /* 41 */
|
| ︙ | ︙ | |||
273 274 275 276 277 278 279 |
0, /* 70 */
0, /* 71 */
0, /* 72 */
0, /* 73 */
TclpFree, /* 74 */
TclpGetClicks, /* 75 */
TclpGetSeconds, /* 76 */
| | | | | | | | | | | | | | | | | | 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 |
0, /* 70 */
0, /* 71 */
0, /* 72 */
0, /* 73 */
TclpFree, /* 74 */
TclpGetClicks, /* 75 */
TclpGetSeconds, /* 76 */
TclpGetTime, /* 77 */
0, /* 78 */
0, /* 79 */
0, /* 80 */
TclpRealloc, /* 81 */
0, /* 82 */
0, /* 83 */
0, /* 84 */
0, /* 85 */
0, /* 86 */
0, /* 87 */
TclPrecTraceProc, /* 88 */
TclPreventAliasLoop, /* 89 */
0, /* 90 */
TclProcCleanupProc, /* 91 */
TclProcCompileProc, /* 92 */
TclProcDeleteProc, /* 93 */
0, /* 94 */
0, /* 95 */
TclRenameCommand, /* 96 */
TclResetShadowedCmdRefs, /* 97 */
TclServiceIdle, /* 98 */
0, /* 99 */
0, /* 100 */
TclSetPreInitScript, /* 101 */
TclSetupEnv, /* 102 */
TclSockGetPort, /* 103 */
TclSockMinimumBuffersOld, /* 104 */
0, /* 105 */
0, /* 106 */
0, /* 107 */
TclTeardownNamespace, /* 108 */
TclUpdateReturnInfo, /* 109 */
TclSockMinimumBuffers, /* 110 */
Tcl_AddInterpResolvers, /* 111 */
TclAppendExportList, /* 112 */
TclCreateNamespace, /* 113 */
TclDeleteNamespace, /* 114 */
TclExport, /* 115 */
TclFindCommand, /* 116 */
TclFindNamespace, /* 117 */
Tcl_GetInterpResolvers, /* 118 */
Tcl_GetNamespaceResolvers, /* 119 */
Tcl_FindNamespaceVar, /* 120 */
TclForgetImport, /* 121 */
TclGetCommandFromObj, /* 122 */
TclGetCommandFullName, /* 123 */
TclGetCurrentNamespace_, /* 124 */
TclGetGlobalNamespace_, /* 125 */
Tcl_GetVariableFullName, /* 126 */
TclImport, /* 127 */
Tcl_PopCallFrame, /* 128 */
Tcl_PushCallFrame, /* 129 */
Tcl_RemoveInterpResolvers, /* 130 */
Tcl_SetNamespaceResolvers, /* 131 */
TclpHasSockets, /* 132 */
TclpGetDate, /* 133 */
0, /* 134 */
0, /* 135 */
0, /* 136 */
0, /* 137 */
TclGetEnv, /* 138 */
0, /* 139 */
0, /* 140 */
|
| ︙ | ︙ | |||
354 355 356 357 358 359 360 |
TclRegExpRangeUniChar, /* 151 */
TclSetLibraryPath, /* 152 */
TclGetLibraryPath, /* 153 */
0, /* 154 */
0, /* 155 */
TclRegError, /* 156 */
TclVarTraceExists, /* 157 */
| | | | | | | | | | 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 |
TclRegExpRangeUniChar, /* 151 */
TclSetLibraryPath, /* 152 */
TclGetLibraryPath, /* 153 */
0, /* 154 */
0, /* 155 */
TclRegError, /* 156 */
TclVarTraceExists, /* 157 */
TclSetStartupScriptFileName, /* 158 */
TclGetStartupScriptFileName, /* 159 */
0, /* 160 */
TclChannelTransform, /* 161 */
TclChannelEventScriptInvoker, /* 162 */
TclGetInstructionTable, /* 163 */
TclExpandCodeArray, /* 164 */
TclpSetInitialEncodings, /* 165 */
TclListObjSetElement, /* 166 */
TclSetStartupScriptPath, /* 167 */
TclGetStartupScriptPath, /* 168 */
TclpUtfNcmp2, /* 169 */
TclCheckInterpTraces, /* 170 */
TclCheckExecutionTraces, /* 171 */
TclInThreadExit, /* 172 */
TclUniCharMatch, /* 173 */
0, /* 174 */
TclCallVarTraces, /* 175 */
TclCleanupVar, /* 176 */
TclVarErrMsg, /* 177 */
TclSetStartupScript, /* 178 */
TclGetStartupScript, /* 179 */
0, /* 180 */
0, /* 181 */
TclpLocaltime, /* 182 */
TclpGmtime, /* 183 */
0, /* 184 */
0, /* 185 */
0, /* 186 */
0, /* 187 */
0, /* 188 */
0, /* 189 */
0, /* 190 */
|
| ︙ | ︙ | |||
432 433 434 435 436 437 438 |
TclPtrMakeUpvar, /* 229 */
TclObjLookupVar, /* 230 */
TclGetNamespaceFromObj, /* 231 */
TclEvalObjEx, /* 232 */
TclGetSrcInfoForPc, /* 233 */
TclVarHashCreateVar, /* 234 */
TclInitVarHashTable, /* 235 */
| | | 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 |
TclPtrMakeUpvar, /* 229 */
TclObjLookupVar, /* 230 */
TclGetNamespaceFromObj, /* 231 */
TclEvalObjEx, /* 232 */
TclGetSrcInfoForPc, /* 233 */
TclVarHashCreateVar, /* 234 */
TclInitVarHashTable, /* 235 */
TclBackgroundException, /* 236 */
TclResetCancellation, /* 237 */
TclNRInterpProc, /* 238 */
TclNRInterpProcCore, /* 239 */
TclNRRunCallbacks, /* 240 */
TclNREvalObjEx, /* 241 */
TclNREvalObjv, /* 242 */
TclDbDumpActiveObjects, /* 243 */
|
| ︙ | ︙ | |||
455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 |
TclPtrGetVar, /* 252 */
TclPtrSetVar, /* 253 */
TclPtrIncrObjVar, /* 254 */
TclPtrObjMakeUpvar, /* 255 */
TclPtrUnsetVar, /* 256 */
TclStaticPackage, /* 257 */
TclpCreateTemporaryDirectory, /* 258 */
};
static const TclIntPlatStubs tclIntPlatStubs = {
TCL_STUB_MAGIC,
0,
#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
TclGetAndDetachPids, /* 0 */
TclpCloseFile, /* 1 */
TclpCreateCommandChannel, /* 2 */
TclpCreatePipe, /* 3 */
TclpCreateProcess, /* 4 */
| > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
TclPtrGetVar, /* 252 */
TclPtrSetVar, /* 253 */
TclPtrIncrObjVar, /* 254 */
TclPtrObjMakeUpvar, /* 255 */
TclPtrUnsetVar, /* 256 */
TclStaticPackage, /* 257 */
TclpCreateTemporaryDirectory, /* 258 */
TclGetBytesFromObj, /* 259 */
TclUnusedStubEntry, /* 260 */
};
static const TclIntPlatStubs tclIntPlatStubs = {
TCL_STUB_MAGIC,
0,
#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */
TclGetAndDetachPids, /* 0 */
TclpCloseFile, /* 1 */
TclpCreateCommandChannel, /* 2 */
TclpCreatePipe, /* 3 */
TclpCreateProcess, /* 4 */
TclUnixWaitForFile_, /* 5 */
TclpMakeFile, /* 6 */
TclpOpenFile, /* 7 */
TclUnixWaitForFile, /* 8 */
TclpCreateTempFile, /* 9 */
TclpReaddir, /* 10 */
TclpLocaltime_unix, /* 11 */
TclpGmtime_unix, /* 12 */
TclpInetNtoa, /* 13 */
TclUnixCopyFile, /* 14 */
TclMacOSXGetFileAttribute, /* 15 */
TclMacOSXSetFileAttribute, /* 16 */
TclMacOSXCopyFileAttributes, /* 17 */
TclMacOSXMatchType, /* 18 */
TclMacOSXNotifierAddRunLoopMode, /* 19 */
0, /* 20 */
0, /* 21 */
TclpCreateTempFile_, /* 22 */
0, /* 23 */
0, /* 24 */
0, /* 25 */
0, /* 26 */
0, /* 27 */
0, /* 28 */
TclWinCPUID, /* 29 */
TclUnixOpenTemporaryFile, /* 30 */
#endif /* UNIX */
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
TclWinConvertError, /* 0 */
TclWinConvertWSAError, /* 1 */
TclWinGetServByName, /* 2 */
TclWinGetSockOpt, /* 3 */
TclWinGetTclInstance, /* 4 */
TclUnixWaitForFile, /* 5 */
TclWinNToHS, /* 6 */
TclWinSetSockOpt, /* 7 */
TclpGetPid, /* 8 */
TclWinGetPlatformId, /* 9 */
TclpReaddir, /* 10 */
TclGetAndDetachPids, /* 11 */
TclpCloseFile, /* 12 */
TclpCreateCommandChannel, /* 13 */
TclpCreatePipe, /* 14 */
TclpCreateProcess, /* 15 */
TclpIsAtty, /* 16 */
TclUnixCopyFile, /* 17 */
TclpMakeFile, /* 18 */
TclpOpenFile, /* 19 */
TclWinAddProcess, /* 20 */
TclpInetNtoa, /* 21 */
TclpCreateTempFile, /* 22 */
0, /* 23 */
TclWinNoBackslash, /* 24 */
0, /* 25 */
TclWinSetInterfaces, /* 26 */
TclWinFlushDirtyChannels, /* 27 */
TclWinResetInterfaces, /* 28 */
TclWinCPUID, /* 29 */
TclUnixOpenTemporaryFile, /* 30 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
TclGetAndDetachPids, /* 0 */
TclpCloseFile, /* 1 */
TclpCreateCommandChannel, /* 2 */
TclpCreatePipe, /* 3 */
TclpCreateProcess, /* 4 */
TclUnixWaitForFile_, /* 5 */
TclpMakeFile, /* 6 */
TclpOpenFile, /* 7 */
TclUnixWaitForFile, /* 8 */
TclpCreateTempFile, /* 9 */
TclpReaddir, /* 10 */
TclpLocaltime_unix, /* 11 */
TclpGmtime_unix, /* 12 */
TclpInetNtoa, /* 13 */
TclUnixCopyFile, /* 14 */
TclMacOSXGetFileAttribute, /* 15 */
TclMacOSXSetFileAttribute, /* 16 */
TclMacOSXCopyFileAttributes, /* 17 */
TclMacOSXMatchType, /* 18 */
TclMacOSXNotifierAddRunLoopMode, /* 19 */
0, /* 20 */
0, /* 21 */
TclpCreateTempFile_, /* 22 */
0, /* 23 */
0, /* 24 */
0, /* 25 */
0, /* 26 */
0, /* 27 */
0, /* 28 */
TclWinCPUID, /* 29 */
|
| ︙ | ︙ | |||
596 597 598 599 600 601 602 |
TclBN_mp_count_bits, /* 12 */
TclBN_mp_div, /* 13 */
TclBN_mp_div_d, /* 14 */
TclBN_mp_div_2, /* 15 */
TclBN_mp_div_2d, /* 16 */
TclBN_mp_div_3, /* 17 */
TclBN_mp_exch, /* 18 */
| | | 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 |
TclBN_mp_count_bits, /* 12 */
TclBN_mp_div, /* 13 */
TclBN_mp_div_d, /* 14 */
TclBN_mp_div_2, /* 15 */
TclBN_mp_div_2d, /* 16 */
TclBN_mp_div_3, /* 17 */
TclBN_mp_exch, /* 18 */
TclBN_mp_expt_u32, /* 19 */
TclBN_mp_grow, /* 20 */
TclBN_mp_init, /* 21 */
TclBN_mp_init_copy, /* 22 */
TclBN_mp_init_multi, /* 23 */
TclBN_mp_init_set, /* 24 */
TclBN_mp_init_size, /* 25 */
TclBN_mp_lshd, /* 26 */
|
| ︙ | ︙ | |||
624 625 626 627 628 629 630 |
TclBN_mp_sqr, /* 40 */
TclBN_mp_sqrt, /* 41 */
TclBN_mp_sub, /* 42 */
TclBN_mp_sub_d, /* 43 */
TclBN_mp_to_unsigned_bin, /* 44 */
TclBN_mp_to_unsigned_bin_n, /* 45 */
TclBN_mp_toradix_n, /* 46 */
| | | | | | | | | | | | | | | | | | | | | | | | | | | > > > | 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 |
TclBN_mp_sqr, /* 40 */
TclBN_mp_sqrt, /* 41 */
TclBN_mp_sub, /* 42 */
TclBN_mp_sub_d, /* 43 */
TclBN_mp_to_unsigned_bin, /* 44 */
TclBN_mp_to_unsigned_bin_n, /* 45 */
TclBN_mp_toradix_n, /* 46 */
TclBN_mp_ubin_size, /* 47 */
TclBN_mp_xor, /* 48 */
TclBN_mp_zero, /* 49 */
TclBN_reverse, /* 50 */
TclBN_s_mp_mul_digs_fast, /* 51 */
TclBN_s_mp_sqr_fast, /* 52 */
TclBN_mp_karatsuba_mul, /* 53 */
TclBN_mp_karatsuba_sqr, /* 54 */
TclBN_mp_toom_mul, /* 55 */
TclBN_mp_toom_sqr, /* 56 */
TclBN_s_mp_add, /* 57 */
TclBN_s_mp_mul_digs, /* 58 */
TclBN_s_mp_sqr, /* 59 */
TclBN_s_mp_sub, /* 60 */
TclBN_mp_init_ul, /* 61 */
TclBN_mp_set_ul, /* 62 */
TclBN_mp_cnt_lsb, /* 63 */
TclBN_mp_init_l, /* 64 */
TclBN_mp_init_i64, /* 65 */
TclBN_mp_init_u64, /* 66 */
TclBN_mp_expt_d_ex, /* 67 */
TclBN_mp_set_u64, /* 68 */
TclBN_mp_get_mag_u64, /* 69 */
TclBN_mp_set_i64, /* 70 */
0, /* 71 */
0, /* 72 */
TclBN_mp_tc_and, /* 73 */
TclBN_mp_tc_or, /* 74 */
TclBN_mp_tc_xor, /* 75 */
TclBN_mp_signed_rsh, /* 76 */
0, /* 77 */
TclBN_mp_to_ubin, /* 78 */
TclBN_mp_div_ld, /* 79 */
TclBN_mp_to_radix, /* 80 */
};
static const TclStubHooks tclStubHooks = {
&tclPlatStubs,
&tclIntStubs,
&tclIntPlatStubs
};
|
| ︙ | ︙ | |||
704 705 706 707 708 709 710 |
Tcl_AppendStringsToObj, /* 15 */
Tcl_AppendToObj, /* 16 */
Tcl_ConcatObj, /* 17 */
Tcl_ConvertToType, /* 18 */
Tcl_DbDecrRefCount, /* 19 */
Tcl_DbIncrRefCount, /* 20 */
Tcl_DbIsShared, /* 21 */
| | | | | | | | | | | | | | | | | 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 |
Tcl_AppendStringsToObj, /* 15 */
Tcl_AppendToObj, /* 16 */
Tcl_ConcatObj, /* 17 */
Tcl_ConvertToType, /* 18 */
Tcl_DbDecrRefCount, /* 19 */
Tcl_DbIncrRefCount, /* 20 */
Tcl_DbIsShared, /* 21 */
Tcl_DbNewBooleanObj, /* 22 */
Tcl_DbNewByteArrayObj, /* 23 */
Tcl_DbNewDoubleObj, /* 24 */
Tcl_DbNewListObj, /* 25 */
Tcl_DbNewLongObj, /* 26 */
Tcl_DbNewObj, /* 27 */
Tcl_DbNewStringObj, /* 28 */
Tcl_DuplicateObj, /* 29 */
TclFreeObj, /* 30 */
Tcl_GetBoolean, /* 31 */
Tcl_GetBooleanFromObj, /* 32 */
Tcl_GetByteArrayFromObj, /* 33 */
Tcl_GetDouble, /* 34 */
Tcl_GetDoubleFromObj, /* 35 */
Tcl_GetIndexFromObj, /* 36 */
Tcl_GetInt, /* 37 */
Tcl_GetIntFromObj, /* 38 */
Tcl_GetLongFromObj, /* 39 */
Tcl_GetObjType, /* 40 */
Tcl_GetStringFromObj, /* 41 */
Tcl_InvalidateStringRep, /* 42 */
Tcl_ListObjAppendList, /* 43 */
Tcl_ListObjAppendElement, /* 44 */
Tcl_ListObjGetElements, /* 45 */
Tcl_ListObjIndex, /* 46 */
Tcl_ListObjLength, /* 47 */
Tcl_ListObjReplace, /* 48 */
Tcl_NewBooleanObj, /* 49 */
Tcl_NewByteArrayObj, /* 50 */
Tcl_NewDoubleObj, /* 51 */
Tcl_NewIntObj, /* 52 */
Tcl_NewListObj, /* 53 */
Tcl_NewLongObj, /* 54 */
Tcl_NewObj, /* 55 */
Tcl_NewStringObj, /* 56 */
Tcl_SetBooleanObj, /* 57 */
Tcl_SetByteArrayLength, /* 58 */
Tcl_SetByteArrayObj, /* 59 */
Tcl_SetDoubleObj, /* 60 */
Tcl_SetIntObj, /* 61 */
Tcl_SetListObj, /* 62 */
Tcl_SetLongObj, /* 63 */
Tcl_SetObjLength, /* 64 */
Tcl_SetStringObj, /* 65 */
Tcl_AddErrorInfo, /* 66 */
Tcl_AddObjErrorInfo, /* 67 */
Tcl_AllowExceptions, /* 68 */
Tcl_AppendElement, /* 69 */
Tcl_AppendResult, /* 70 */
Tcl_AsyncCreate, /* 71 */
Tcl_AsyncDelete, /* 72 */
Tcl_AsyncInvoke, /* 73 */
Tcl_AsyncMark, /* 74 */
Tcl_AsyncReady, /* 75 */
Tcl_BackgroundError, /* 76 */
Tcl_Backslash, /* 77 */
Tcl_BadChannelOption, /* 78 */
Tcl_CallWhenDeleted, /* 79 */
Tcl_CancelIdleCall, /* 80 */
Tcl_Close, /* 81 */
Tcl_CommandComplete, /* 82 */
Tcl_Concat, /* 83 */
Tcl_ConvertElement, /* 84 */
Tcl_ConvertCountedElement, /* 85 */
Tcl_CreateAlias, /* 86 */
Tcl_CreateAliasObj, /* 87 */
Tcl_CreateChannel, /* 88 */
Tcl_CreateChannelHandler, /* 89 */
Tcl_CreateCloseHandler, /* 90 */
Tcl_CreateCommand, /* 91 */
Tcl_CreateEventSource, /* 92 */
Tcl_CreateExitHandler, /* 93 */
Tcl_CreateInterp, /* 94 */
Tcl_CreateMathFunc, /* 95 */
Tcl_CreateObjCommand, /* 96 */
Tcl_CreateSlave, /* 97 */
Tcl_CreateTimerHandler, /* 98 */
Tcl_CreateTrace, /* 99 */
Tcl_DeleteAssocData, /* 100 */
Tcl_DeleteChannelHandler, /* 101 */
Tcl_DeleteCloseHandler, /* 102 */
|
| ︙ | ︙ | |||
811 812 813 814 815 816 817 |
Tcl_DStringInit, /* 122 */
Tcl_DStringResult, /* 123 */
Tcl_DStringSetLength, /* 124 */
Tcl_DStringStartSublist, /* 125 */
Tcl_Eof, /* 126 */
Tcl_ErrnoId, /* 127 */
Tcl_ErrnoMsg, /* 128 */
| | | | | 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 |
Tcl_DStringInit, /* 122 */
Tcl_DStringResult, /* 123 */
Tcl_DStringSetLength, /* 124 */
Tcl_DStringStartSublist, /* 125 */
Tcl_Eof, /* 126 */
Tcl_ErrnoId, /* 127 */
Tcl_ErrnoMsg, /* 128 */
Tcl_Eval, /* 129 */
Tcl_EvalFile, /* 130 */
Tcl_EvalObj, /* 131 */
Tcl_EventuallyFree, /* 132 */
Tcl_Exit, /* 133 */
Tcl_ExposeCommand, /* 134 */
Tcl_ExprBoolean, /* 135 */
Tcl_ExprBooleanObj, /* 136 */
Tcl_ExprDouble, /* 137 */
Tcl_ExprDoubleObj, /* 138 */
Tcl_ExprLong, /* 139 */
Tcl_ExprLongObj, /* 140 */
Tcl_ExprObj, /* 141 */
Tcl_ExprString, /* 142 */
Tcl_Finalize, /* 143 */
Tcl_FindExecutable, /* 144 */
Tcl_FirstHashEntry, /* 145 */
Tcl_Flush, /* 146 */
Tcl_FreeResult, /* 147 */
Tcl_GetAlias, /* 148 */
Tcl_GetAliasObj, /* 149 */
Tcl_GetAssocData, /* 150 */
Tcl_GetChannel, /* 151 */
|
| ︙ | ︙ | |||
864 865 866 867 868 869 870 |
#endif /* MACOSX */
Tcl_GetPathType, /* 168 */
Tcl_Gets, /* 169 */
Tcl_GetsObj, /* 170 */
Tcl_GetServiceMode, /* 171 */
Tcl_GetSlave, /* 172 */
Tcl_GetStdChannel, /* 173 */
| | | | | | 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 |
#endif /* MACOSX */
Tcl_GetPathType, /* 168 */
Tcl_Gets, /* 169 */
Tcl_GetsObj, /* 170 */
Tcl_GetServiceMode, /* 171 */
Tcl_GetSlave, /* 172 */
Tcl_GetStdChannel, /* 173 */
Tcl_GetStringResult, /* 174 */
Tcl_GetVar, /* 175 */
Tcl_GetVar2, /* 176 */
Tcl_GlobalEval, /* 177 */
Tcl_GlobalEvalObj, /* 178 */
Tcl_HideCommand, /* 179 */
Tcl_Init, /* 180 */
Tcl_InitHashTable, /* 181 */
Tcl_InputBlocked, /* 182 */
Tcl_InputBuffered, /* 183 */
Tcl_InterpDeleted, /* 184 */
Tcl_IsSafe, /* 185 */
|
| ︙ | ︙ | |||
910 911 912 913 914 915 916 |
Tcl_RegExpExec, /* 213 */
Tcl_RegExpMatch, /* 214 */
Tcl_RegExpRange, /* 215 */
Tcl_Release, /* 216 */
Tcl_ResetResult, /* 217 */
Tcl_ScanElement, /* 218 */
Tcl_ScanCountedElement, /* 219 */
| | | | | | | | | | | | | | | | | | | | | | | 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 |
Tcl_RegExpExec, /* 213 */
Tcl_RegExpMatch, /* 214 */
Tcl_RegExpRange, /* 215 */
Tcl_Release, /* 216 */
Tcl_ResetResult, /* 217 */
Tcl_ScanElement, /* 218 */
Tcl_ScanCountedElement, /* 219 */
Tcl_SeekOld, /* 220 */
Tcl_ServiceAll, /* 221 */
Tcl_ServiceEvent, /* 222 */
Tcl_SetAssocData, /* 223 */
Tcl_SetChannelBufferSize, /* 224 */
Tcl_SetChannelOption, /* 225 */
Tcl_SetCommandInfo, /* 226 */
Tcl_SetErrno, /* 227 */
Tcl_SetErrorCode, /* 228 */
Tcl_SetMaxBlockTime, /* 229 */
Tcl_SetPanicProc, /* 230 */
Tcl_SetRecursionLimit, /* 231 */
Tcl_SetResult, /* 232 */
Tcl_SetServiceMode, /* 233 */
Tcl_SetObjErrorCode, /* 234 */
Tcl_SetObjResult, /* 235 */
Tcl_SetStdChannel, /* 236 */
Tcl_SetVar, /* 237 */
Tcl_SetVar2, /* 238 */
Tcl_SignalId, /* 239 */
Tcl_SignalMsg, /* 240 */
Tcl_SourceRCFile, /* 241 */
Tcl_SplitList, /* 242 */
Tcl_SplitPath, /* 243 */
Tcl_StaticPackage, /* 244 */
Tcl_StringMatch, /* 245 */
Tcl_TellOld, /* 246 */
Tcl_TraceVar, /* 247 */
Tcl_TraceVar2, /* 248 */
Tcl_TranslateFileName, /* 249 */
Tcl_Ungets, /* 250 */
Tcl_UnlinkVar, /* 251 */
Tcl_UnregisterChannel, /* 252 */
Tcl_UnsetVar, /* 253 */
Tcl_UnsetVar2, /* 254 */
Tcl_UntraceVar, /* 255 */
Tcl_UntraceVar2, /* 256 */
Tcl_UpdateLinkedVar, /* 257 */
Tcl_UpVar, /* 258 */
Tcl_UpVar2, /* 259 */
Tcl_VarEval, /* 260 */
Tcl_VarTraceInfo, /* 261 */
Tcl_VarTraceInfo2, /* 262 */
Tcl_Write, /* 263 */
Tcl_WrongNumArgs, /* 264 */
Tcl_DumpActiveMemory, /* 265 */
Tcl_ValidateAllMemory, /* 266 */
Tcl_AppendResultVA, /* 267 */
Tcl_AppendStringsToObjVA, /* 268 */
Tcl_HashStats, /* 269 */
Tcl_ParseVar, /* 270 */
Tcl_PkgPresent, /* 271 */
Tcl_PkgPresentEx, /* 272 */
Tcl_PkgProvide, /* 273 */
Tcl_PkgRequire, /* 274 */
Tcl_SetErrorCodeVA, /* 275 */
Tcl_VarEvalVA, /* 276 */
Tcl_WaitPid, /* 277 */
Tcl_PanicVA, /* 278 */
Tcl_GetVersion, /* 279 */
Tcl_InitMemory, /* 280 */
Tcl_StackChannel, /* 281 */
Tcl_UnstackChannel, /* 282 */
Tcl_GetStackedChannel, /* 283 */
Tcl_SetMainLoop, /* 284 */
0, /* 285 */
Tcl_AppendObjToObj, /* 286 */
Tcl_CreateEncoding, /* 287 */
Tcl_CreateThreadExitHandler, /* 288 */
Tcl_DeleteThreadExitHandler, /* 289 */
Tcl_DiscardResult, /* 290 */
Tcl_EvalEx, /* 291 */
Tcl_EvalObjv, /* 292 */
Tcl_EvalObjEx, /* 293 */
Tcl_ExitThread, /* 294 */
Tcl_ExternalToUtf, /* 295 */
Tcl_ExternalToUtfDString, /* 296 */
Tcl_FinalizeThread, /* 297 */
|
| ︙ | ︙ | |||
1004 1005 1006 1007 1008 1009 1010 |
Tcl_InitNotifier, /* 307 */
Tcl_MutexLock, /* 308 */
Tcl_MutexUnlock, /* 309 */
Tcl_ConditionNotify, /* 310 */
Tcl_ConditionWait, /* 311 */
Tcl_NumUtfChars, /* 312 */
Tcl_ReadChars, /* 313 */
| | | | | | | | | | 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 |
Tcl_InitNotifier, /* 307 */
Tcl_MutexLock, /* 308 */
Tcl_MutexUnlock, /* 309 */
Tcl_ConditionNotify, /* 310 */
Tcl_ConditionWait, /* 311 */
Tcl_NumUtfChars, /* 312 */
Tcl_ReadChars, /* 313 */
Tcl_RestoreResult, /* 314 */
Tcl_SaveResult, /* 315 */
Tcl_SetSystemEncoding, /* 316 */
Tcl_SetVar2Ex, /* 317 */
Tcl_ThreadAlert, /* 318 */
Tcl_ThreadQueueEvent, /* 319 */
Tcl_UniCharAtIndex, /* 320 */
Tcl_UniCharToLower, /* 321 */
Tcl_UniCharToTitle, /* 322 */
Tcl_UniCharToUpper, /* 323 */
Tcl_UniCharToUtf, /* 324 */
Tcl_UtfAtIndex, /* 325 */
Tcl_UtfCharComplete, /* 326 */
Tcl_UtfBackslash, /* 327 */
Tcl_UtfFindFirst, /* 328 */
Tcl_UtfFindLast, /* 329 */
Tcl_UtfNext, /* 330 */
Tcl_UtfPrev, /* 331 */
Tcl_UtfToExternal, /* 332 */
Tcl_UtfToExternalDString, /* 333 */
Tcl_UtfToLower, /* 334 */
Tcl_UtfToTitle, /* 335 */
Tcl_UtfToChar16, /* 336 */
Tcl_UtfToUpper, /* 337 */
Tcl_WriteChars, /* 338 */
Tcl_WriteObj, /* 339 */
Tcl_GetString, /* 340 */
Tcl_GetDefaultEncodingDir, /* 341 */
Tcl_SetDefaultEncodingDir, /* 342 */
Tcl_AlertNotifier, /* 343 */
Tcl_ServiceModeHook, /* 344 */
Tcl_UniCharIsAlnum, /* 345 */
Tcl_UniCharIsAlpha, /* 346 */
Tcl_UniCharIsDigit, /* 347 */
Tcl_UniCharIsLower, /* 348 */
Tcl_UniCharIsSpace, /* 349 */
Tcl_UniCharIsUpper, /* 350 */
Tcl_UniCharIsWordChar, /* 351 */
Tcl_UniCharLen, /* 352 */
Tcl_UniCharNcmp, /* 353 */
Tcl_Char16ToUtfDString, /* 354 */
Tcl_UtfToChar16DString, /* 355 */
Tcl_GetRegExpFromObj, /* 356 */
Tcl_EvalTokens, /* 357 */
Tcl_FreeParse, /* 358 */
Tcl_LogCommandInfo, /* 359 */
Tcl_ParseBraces, /* 360 */
Tcl_ParseCommand, /* 361 */
Tcl_ParseExpr, /* 362 */
Tcl_ParseQuotedString, /* 363 */
Tcl_ParseVarName, /* 364 */
|
| ︙ | ︙ | |||
1072 1073 1074 1075 1076 1077 1078 |
Tcl_UniCharIsPunct, /* 375 */
Tcl_RegExpExecObj, /* 376 */
Tcl_RegExpGetInfo, /* 377 */
Tcl_NewUnicodeObj, /* 378 */
Tcl_SetUnicodeObj, /* 379 */
Tcl_GetCharLength, /* 380 */
Tcl_GetUniChar, /* 381 */
| | | 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 |
Tcl_UniCharIsPunct, /* 375 */
Tcl_RegExpExecObj, /* 376 */
Tcl_RegExpGetInfo, /* 377 */
Tcl_NewUnicodeObj, /* 378 */
Tcl_SetUnicodeObj, /* 379 */
Tcl_GetCharLength, /* 380 */
Tcl_GetUniChar, /* 381 */
Tcl_GetUnicode, /* 382 */
Tcl_GetRange, /* 383 */
Tcl_AppendUnicodeToObj, /* 384 */
Tcl_RegExpMatchObj, /* 385 */
Tcl_SetNotifier, /* 386 */
Tcl_GetAllocMutex, /* 387 */
Tcl_GetChannelNames, /* 388 */
Tcl_GetChannelNamesEx, /* 389 */
|
| ︙ | ︙ | |||
1111 1112 1113 1114 1115 1116 1117 |
Tcl_IsChannelRegistered, /* 414 */
Tcl_CutChannel, /* 415 */
Tcl_SpliceChannel, /* 416 */
Tcl_ClearChannelHandlers, /* 417 */
Tcl_IsChannelExisting, /* 418 */
Tcl_UniCharNcasecmp, /* 419 */
Tcl_UniCharCaseMatch, /* 420 */
| | | | | | 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 |
Tcl_IsChannelRegistered, /* 414 */
Tcl_CutChannel, /* 415 */
Tcl_SpliceChannel, /* 416 */
Tcl_ClearChannelHandlers, /* 417 */
Tcl_IsChannelExisting, /* 418 */
Tcl_UniCharNcasecmp, /* 419 */
Tcl_UniCharCaseMatch, /* 420 */
Tcl_FindHashEntry, /* 421 */
Tcl_CreateHashEntry, /* 422 */
Tcl_InitCustomHashTable, /* 423 */
Tcl_InitObjHashTable, /* 424 */
Tcl_CommandTraceInfo, /* 425 */
Tcl_TraceCommand, /* 426 */
Tcl_UntraceCommand, /* 427 */
Tcl_AttemptAlloc, /* 428 */
Tcl_AttemptDbCkalloc, /* 429 */
Tcl_AttemptRealloc, /* 430 */
Tcl_AttemptDbCkrealloc, /* 431 */
Tcl_AttemptSetObjLength, /* 432 */
Tcl_GetChannelThread, /* 433 */
Tcl_GetUnicodeFromObj, /* 434 */
Tcl_GetMathFuncInfo, /* 435 */
Tcl_ListMathFuncs, /* 436 */
Tcl_SubstObj, /* 437 */
Tcl_DetachChannel, /* 438 */
Tcl_IsStandardChannel, /* 439 */
Tcl_FSCopyFile, /* 440 */
Tcl_FSCopyDirectory, /* 441 */
Tcl_FSCreateDirectory, /* 442 */
Tcl_FSDeleteFile, /* 443 */
|
| ︙ | ︙ | |||
1209 1210 1211 1212 1213 1214 1215 |
Tcl_GetCurrentNamespace, /* 512 */
Tcl_GetGlobalNamespace, /* 513 */
Tcl_FindNamespace, /* 514 */
Tcl_FindCommand, /* 515 */
Tcl_GetCommandFromObj, /* 516 */
Tcl_GetCommandFullName, /* 517 */
Tcl_FSEvalFileEx, /* 518 */
| | | 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 |
Tcl_GetCurrentNamespace, /* 512 */
Tcl_GetGlobalNamespace, /* 513 */
Tcl_FindNamespace, /* 514 */
Tcl_FindCommand, /* 515 */
Tcl_GetCommandFromObj, /* 516 */
Tcl_GetCommandFullName, /* 517 */
Tcl_FSEvalFileEx, /* 518 */
Tcl_SetExitProc, /* 519 */
Tcl_LimitAddHandler, /* 520 */
Tcl_LimitRemoveHandler, /* 521 */
Tcl_LimitReady, /* 522 */
Tcl_LimitCheck, /* 523 */
Tcl_LimitExceeded, /* 524 */
Tcl_LimitSetCommands, /* 525 */
Tcl_LimitSetTime, /* 526 */
|
| ︙ | ︙ | |||
1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 |
Tcl_StoreIntRep, /* 639 */
Tcl_HasStringRep, /* 640 */
Tcl_IncrRefCount, /* 641 */
Tcl_DecrRefCount, /* 642 */
Tcl_IsShared, /* 643 */
Tcl_LinkArray, /* 644 */
Tcl_GetIntForIndex, /* 645 */
};
/* !END!: Do not edit above this line. */
| > > > | 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 |
Tcl_StoreIntRep, /* 639 */
Tcl_HasStringRep, /* 640 */
Tcl_IncrRefCount, /* 641 */
Tcl_DecrRefCount, /* 642 */
Tcl_IsShared, /* 643 */
Tcl_LinkArray, /* 644 */
Tcl_GetIntForIndex, /* 645 */
Tcl_UtfToUniChar, /* 646 */
Tcl_UniCharToUtfDString, /* 647 */
Tcl_UtfToUniCharDString, /* 648 */
};
/* !END!: Do not edit above this line. */
|
Changes to generic/tclStubLib.c.
| ︙ | ︙ | |||
61 62 63 64 65 66 67 |
/*
* We can't optimize this check by caching tclStubsPtr because that
* prevents apps from being able to load/unload Tcl dynamically multiple
* times. [Bug 615304]
*/
| | | | | 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 |
/*
* We can't optimize this check by caching tclStubsPtr because that
* prevents apps from being able to load/unload Tcl dynamically multiple
* times. [Bug 615304]
*/
if (!stubsPtr || (stubsPtr->magic != (((exact&0xFF00) >= 0x900) ? magic : TCL_STUB_MAGIC))) {
iPtr->result = (char *)"interpreter uses an incompatible stubs mechanism";
iPtr->freeProc = 0;
return NULL;
}
actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 0, &pkgData);
if (actualVersion == NULL) {
return NULL;
}
|
| ︙ | ︙ | |||
97 98 99 100 101 102 103 |
} else {
actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
if (actualVersion == NULL) {
return NULL;
}
}
}
| | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 |
} else {
actualVersion = stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL);
if (actualVersion == NULL) {
return NULL;
}
}
}
if (((exact&0xFF00) < 0x900)) {
/* We are running Tcl 8.x */
stubsPtr = (TclStubs *)pkgData;
}
tclStubsPtr = stubsPtr;
if (stubsPtr->hooks) {
tclPlatStubsPtr = stubsPtr->hooks->tclPlatStubs;
|
| ︙ | ︙ |
Changes to generic/tclTest.c.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | */ #undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" #include "tclOO.h" #include <math.h> /* * Required for Testregexp*Cmd */ #include "tclRegexp.h" | > > > > > < < < < < < < | 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 |
*/
#undef STATIC_BUILD
#ifndef USE_TCL_STUBS
# define USE_TCL_STUBS
#endif
#include "tclInt.h"
#ifdef TCL_WITH_EXTERNAL_TOMMATH
# include "tommath.h"
#else
# include "tclTomMath.h"
#endif
#include "tclOO.h"
#include <math.h>
/*
* Required for Testregexp*Cmd
*/
#include "tclRegexp.h"
/*
* Required for the TestChannelCmd and TestChannelEventCmd
*/
#include "tclIO.h"
/*
* Declare external functions used in Windows tests.
*/
DLLEXPORT int Tcltest_Init(Tcl_Interp *interp);
DLLEXPORT int Tcltest_SafeInit(Tcl_Interp *interp);
/*
* Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect
* the results of the various deletion callbacks.
*/
static Tcl_DString delString;
static Tcl_Interp *delInterp;
/*
* One of the following structures exists for each asynchronous handler
* created by the "testasync" command".
*/
typedef struct TestAsyncHandler {
|
| ︙ | ︙ | |||
165 166 167 168 169 170 171 | #if TCL_THREADS static Tcl_ThreadCreateType AsyncThreadProc(void *); #endif static void CleanupTestSetassocdataTests( void *clientData, Tcl_Interp *interp); static void CmdDelProc1(void *clientData); static void CmdDelProc2(void *clientData); | | < | < | < < | < < | < | | < | < | < < | | | | < | | < < | < < | < | < | < | < | < | < | < | < | < < | < | < < | < < | < < | < < | < | < | < < | < | < < | < < | < | < | < | < | < | < | < | < | < < < < < | | | | < < | < | < | < | < | < | < < | < < | < < | < < | < < | < < | < < | | < < | | < | < | < | < | < < | < | < | < | < | < < | < < | < | < | < | < < | < < > > | 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 | #if TCL_THREADS static Tcl_ThreadCreateType AsyncThreadProc(void *); #endif static void CleanupTestSetassocdataTests( void *clientData, Tcl_Interp *interp); static void CmdDelProc1(void *clientData); static void CmdDelProc2(void *clientData); static Tcl_CmdProc CmdProc1; static Tcl_CmdProc CmdProc2; static void CmdTraceDeleteProc( void *clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *cmdProc, void *cmdClientData, int argc, const char *argv[]); static void CmdTraceProc(void *clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *cmdProc, void *cmdClientData, int argc, const char *argv[]); static Tcl_CmdProc CreatedCommandProc; static Tcl_CmdProc CreatedCommandProc2; static void DelCallbackProc(void *clientData, Tcl_Interp *interp); static Tcl_CmdProc DelCmdProc; static void DelDeleteProc(void *clientData); static void EncodingFreeProc(void *clientData); static int EncodingToUtfProc(void *clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); static int EncodingFromUtfProc(void *clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); static void ExitProcEven(void *clientData); static void ExitProcOdd(void *clientData); static Tcl_ObjCmdProc GetTimesObjCmd; static Tcl_ResolveCompiledVarProc InterpCompiledVarResolver; static void MainLoop(void); static Tcl_CmdProc NoopCmd; static Tcl_ObjCmdProc NoopObjCmd; static int ObjTraceProc(void *clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandToken, int objc, Tcl_Obj *const objv[]); static void ObjTraceDeleteProc(void *clientData); static void PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr); static void SpecialFree(char *blockPtr); static int StaticInitProc(Tcl_Interp *interp); static Tcl_CmdProc TestasyncCmd; static Tcl_ObjCmdProc TestbumpinterpepochObjCmd; static Tcl_ObjCmdProc TestbytestringObjCmd; static Tcl_ObjCmdProc TestsetbytearraylengthObjCmd; static Tcl_ObjCmdProc TestpurebytesobjObjCmd; static Tcl_ObjCmdProc TeststringbytesObjCmd; static Tcl_CmdProc TestcmdinfoCmd; static Tcl_CmdProc TestcmdtokenCmd; static Tcl_CmdProc TestcmdtraceCmd; static Tcl_CmdProc TestconcatobjCmd; static Tcl_CmdProc TestcreatecommandCmd; static Tcl_CmdProc TestdcallCmd; static Tcl_CmdProc TestdelCmd; static Tcl_CmdProc TestdelassocdataCmd; static Tcl_ObjCmdProc TestdoubledigitsObjCmd; static Tcl_CmdProc TestdstringCmd; static Tcl_ObjCmdProc TestencodingObjCmd; static Tcl_ObjCmdProc TestevalexObjCmd; static Tcl_ObjCmdProc TestevalobjvObjCmd; static Tcl_ObjCmdProc TesteventObjCmd; static int TesteventProc(Tcl_Event *event, int flags); static int TesteventDeleteProc(Tcl_Event *event, void *clientData); static Tcl_CmdProc TestexithandlerCmd; static Tcl_CmdProc TestexprlongCmd; static Tcl_ObjCmdProc TestexprlongobjCmd; static Tcl_CmdProc TestexprdoubleCmd; static Tcl_ObjCmdProc TestexprdoubleobjCmd; static Tcl_ObjCmdProc TestexprparserObjCmd; static Tcl_CmdProc TestexprstringCmd; static Tcl_ObjCmdProc TestfileCmd; static Tcl_ObjCmdProc TestfilelinkCmd; static Tcl_CmdProc TestfeventCmd; static Tcl_CmdProc TestgetassocdataCmd; static Tcl_CmdProc TestgetintCmd; static Tcl_CmdProc TestlongsizeCmd; static Tcl_CmdProc TestgetplatformCmd; static Tcl_ObjCmdProc TestgetvarfullnameCmd; static Tcl_CmdProc TestinterpdeleteCmd; static Tcl_CmdProc TestlinkCmd; static Tcl_ObjCmdProc TestlinkarrayCmd; static Tcl_ObjCmdProc TestlocaleCmd; static Tcl_CmdProc TestmainthreadCmd; static Tcl_CmdProc TestsetmainloopCmd; static Tcl_CmdProc TestexitmainloopCmd; static Tcl_CmdProc TestpanicCmd; static Tcl_ObjCmdProc TestparseargsCmd; static Tcl_ObjCmdProc TestparserObjCmd; static Tcl_ObjCmdProc TestparsevarObjCmd; static Tcl_ObjCmdProc TestparsevarnameObjCmd; static Tcl_ObjCmdProc TestpreferstableObjCmd; static Tcl_ObjCmdProc TestprintObjCmd; static Tcl_ObjCmdProc TestregexpObjCmd; static Tcl_ObjCmdProc TestreturnObjCmd; static void TestregexpXflags(const char *string, int length, int *cflagsPtr, int *eflagsPtr); static Tcl_ObjCmdProc TestsaveresultCmd; static void TestsaveresultFree(char *blockPtr); static Tcl_CmdProc TestsetassocdataCmd; static Tcl_CmdProc TestsetCmd; static Tcl_CmdProc Testset2Cmd; static Tcl_CmdProc TestseterrorcodeCmd; static Tcl_ObjCmdProc TestsetobjerrorcodeCmd; static Tcl_CmdProc TestsetplatformCmd; static Tcl_CmdProc TeststaticpkgCmd; static Tcl_CmdProc TesttranslatefilenameCmd; static Tcl_CmdProc TestupvarCmd; static Tcl_ObjCmdProc TestWrongNumArgsObjCmd; static Tcl_ObjCmdProc TestGetIndexFromObjStructObjCmd; static Tcl_CmdProc TestChannelCmd; static Tcl_CmdProc TestChannelEventCmd; static Tcl_CmdProc TestSocketCmd; static Tcl_ObjCmdProc TestFilesystemObjCmd; static Tcl_ObjCmdProc TestSimpleFilesystemObjCmd; static void TestReport(const char *cmd, Tcl_Obj *arg1, Tcl_Obj *arg2); static Tcl_ObjCmdProc TestgetencpathObjCmd; static Tcl_ObjCmdProc TestsetencpathObjCmd; static Tcl_Obj * TestReportGetNativePath(Tcl_Obj *pathPtr); static Tcl_FSStatProc TestReportStat; static Tcl_FSAccessProc TestReportAccess; static Tcl_FSOpenFileChannelProc TestReportOpenFileChannel; static Tcl_FSMatchInDirectoryProc TestReportMatchInDirectory; static Tcl_FSChdirProc TestReportChdir; static Tcl_FSLstatProc TestReportLstat; |
| ︙ | ︙ | |||
417 418 419 420 421 422 423 | static Tcl_FSStatProc SimpleStat; static Tcl_FSAccessProc SimpleAccess; static Tcl_FSOpenFileChannelProc SimpleOpenFileChannel; static Tcl_FSListVolumesProc SimpleListVolumes; static Tcl_FSPathInFilesystemProc SimplePathInFilesystem; static Tcl_Obj * SimpleRedirect(Tcl_Obj *pathPtr); static Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory; | | | | | < < | < < | < < | < < | < < | < < | < < | 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 |
static Tcl_FSStatProc SimpleStat;
static Tcl_FSAccessProc SimpleAccess;
static Tcl_FSOpenFileChannelProc SimpleOpenFileChannel;
static Tcl_FSListVolumesProc SimpleListVolumes;
static Tcl_FSPathInFilesystemProc SimplePathInFilesystem;
static Tcl_Obj * SimpleRedirect(Tcl_Obj *pathPtr);
static Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory;
static Tcl_ObjCmdProc TestUtfNextCmd;
static Tcl_ObjCmdProc TestUtfPrevCmd;
static Tcl_ObjCmdProc TestNumUtfCharsCmd;
static Tcl_ObjCmdProc TestFindFirstCmd;
static Tcl_ObjCmdProc TestFindLastCmd;
static Tcl_ObjCmdProc TestHashSystemHashCmd;
static Tcl_NRPostProc NREUnwind_callback;
static Tcl_ObjCmdProc TestNREUnwind;
static Tcl_ObjCmdProc TestNRELevels;
static Tcl_ObjCmdProc TestInterpResolverCmd;
#if defined(HAVE_CPUID) || defined(_WIN32)
static Tcl_ObjCmdProc TestcpuidCmd;
#endif
static const Tcl_Filesystem testReportingFilesystem = {
"reporting",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_1,
TestReportInFilesystem, /* path in */
|
| ︙ | ︙ | |||
561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 |
"-appinitprocerror", "-appinitprocdeleteinterp",
"-appinitprocclosestderr", "-appinitprocsetrcfile", NULL
};
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
if (Tcl_TomMath_InitStubs(interp, "8.5-") == NULL) {
return TCL_ERROR;
}
if (Tcl_OOInitStubs(interp) == NULL) {
return TCL_ERROR;
}
/* TIP #268: Full patchlevel instead of just major.minor */
if (Tcl_PkgProvideEx(interp, "Tcltest", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) {
return TCL_ERROR;
}
| > > < < < < < > > > | 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 |
"-appinitprocerror", "-appinitprocdeleteinterp",
"-appinitprocclosestderr", "-appinitprocsetrcfile", NULL
};
if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
#ifndef TCL_WITH_EXTERNAL_TOMMATH
if (Tcl_TomMath_InitStubs(interp, "8.5-") == NULL) {
return TCL_ERROR;
}
#endif
if (Tcl_OOInitStubs(interp) == NULL) {
return TCL_ERROR;
}
/* TIP #268: Full patchlevel instead of just major.minor */
if (Tcl_PkgProvideEx(interp, "Tcltest", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) {
return TCL_ERROR;
}
/*
* Create additional commands and math functions for testing Tcl.
*/
Tcl_CreateObjCommand(interp, "gettimes", GetTimesObjCmd, NULL, NULL);
Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testpurebytesobj", TestpurebytesobjObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsimplefilesystem", TestSimpleFilesystemObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetindexfromobjstruct",
TestGetIndexFromObjStructObjCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testasync", TestasyncCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testbumpinterpepoch",
TestbumpinterpepochObjCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testchannel", TestChannelCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testchannelevent", TestChannelEventCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, NULL,
|
| ︙ | ︙ | |||
696 697 698 699 700 701 702 703 704 705 706 707 708 709 |
INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateCommand(interp, "testset2", Testset2Cmd,
INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetobjerrorcode",
TestsetobjerrorcodeCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testnumutfchars",
TestNumUtfCharsCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindfirst",
TestFindFirstCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindlast",
TestFindLastCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
| > > > > | 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 |
INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateCommand(interp, "testset2", Testset2Cmd,
INT2PTR(TCL_LEAVE_ERR_MSG), NULL);
Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetobjerrorcode",
TestsetobjerrorcodeCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testutfnext",
TestUtfNextCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testutfprev",
TestUtfPrevCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testnumutfchars",
TestNumUtfCharsCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindfirst",
TestFindFirstCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindlast",
TestFindLastCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
|
| ︙ | ︙ | |||
726 727 728 729 730 731 732 733 734 735 736 737 738 739 |
NULL, NULL);
#endif
Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd,
NULL, NULL);
if (TclObjTest_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
if (Procbodytest_Init(interp) != TCL_OK) {
return TCL_ERROR;
| > > > > | 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 |
NULL, NULL);
#endif
Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgetencpath", TestgetencpathObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testsetencpath", TestsetencpathObjCmd,
NULL, NULL);
if (TclObjTest_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
if (Procbodytest_Init(interp) != TCL_OK) {
return TCL_ERROR;
|
| ︙ | ︙ | |||
826 827 828 829 830 831 832 | * * Side effects: * Creates, deletes, and invokes handlers. * *---------------------------------------------------------------------- */ | < < > | | | | | 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 |
*
* Side effects:
* Creates, deletes, and invokes handlers.
*
*----------------------------------------------------------------------
*/
static int
TestasyncCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
TestAsyncHandler *asyncPtr, *prevPtr;
int id, code;
static int nextId = 1;
if (argc < 2) {
wrongNumArgs:
Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
if (argc != 3) {
goto wrongNumArgs;
}
asyncPtr = (TestAsyncHandler *)ckalloc(sizeof(TestAsyncHandler));
asyncPtr->command = (char *)ckalloc(strlen(argv[2]) + 1);
strcpy(asyncPtr->command, argv[2]);
Tcl_MutexLock(&asyncTestMutex);
asyncPtr->id = nextId;
nextId++;
asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc,
INT2PTR(asyncPtr->id));
asyncPtr->nextPtr = firstHandler;
firstHandler = asyncPtr;
Tcl_MutexUnlock(&asyncTestMutex);
Tcl_SetObjResult(interp, Tcl_NewIntObj(asyncPtr->id));
} else if (strcmp(argv[1], "delete") == 0) {
if (argc == 2) {
Tcl_MutexLock(&asyncTestMutex);
while (firstHandler != NULL) {
asyncPtr = firstHandler;
firstHandler = asyncPtr->nextPtr;
Tcl_AsyncDelete(asyncPtr->handler);
ckfree(asyncPtr->command);
ckfree(asyncPtr);
}
Tcl_MutexUnlock(&asyncTestMutex);
return TCL_OK;
}
if (argc != 3) {
goto wrongNumArgs;
}
|
| ︙ | ︙ | |||
890 891 892 893 894 895 896 |
}
if (prevPtr == NULL) {
firstHandler = asyncPtr->nextPtr;
} else {
prevPtr->nextPtr = asyncPtr->nextPtr;
}
Tcl_AsyncDelete(asyncPtr->handler);
| | | | 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 |
}
if (prevPtr == NULL) {
firstHandler = asyncPtr->nextPtr;
} else {
prevPtr->nextPtr = asyncPtr->nextPtr;
}
Tcl_AsyncDelete(asyncPtr->handler);
ckfree(asyncPtr->command);
ckfree(asyncPtr);
break;
}
Tcl_MutexUnlock(&asyncTestMutex);
} else if (strcmp(argv[1], "mark") == 0) {
if (argc != 5) {
goto wrongNumArgs;
}
|
| ︙ | ︙ | |||
962 963 964 965 966 967 968 |
* in global list. */
Tcl_Interp *interp, /* Interpreter in which command was
* executed, or NULL. */
int code) /* Current return code from command. */
{
TestAsyncHandler *asyncPtr;
int id = PTR2INT(clientData);
| | < | | | 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 |
* in global list. */
Tcl_Interp *interp, /* Interpreter in which command was
* executed, or NULL. */
int code) /* Current return code from command. */
{
TestAsyncHandler *asyncPtr;
int id = PTR2INT(clientData);
const char *listArgv[4], *cmd;
char string[TCL_INTEGER_SPACE];
Tcl_MutexLock(&asyncTestMutex);
for (asyncPtr = firstHandler; asyncPtr != NULL;
asyncPtr = asyncPtr->nextPtr) {
if (asyncPtr->id == id) {
break;
}
}
Tcl_MutexUnlock(&asyncTestMutex);
if (!asyncPtr) {
/* Woops - this one was deleted between the AsyncMark and now */
return TCL_OK;
}
TclFormatInt(string, code);
listArgv[0] = asyncPtr->command;
listArgv[1] = Tcl_GetString(Tcl_GetObjResult(interp));
listArgv[2] = string;
listArgv[3] = NULL;
cmd = Tcl_Merge(3, listArgv);
if (interp != NULL) {
code = Tcl_EvalEx(interp, cmd, -1, 0);
} else {
/*
* this should not happen, but by definition of how async handlers are
* invoked, it's possible. Better error checking is needed here.
*/
}
ckfree(cmd);
return code;
}
/*
*----------------------------------------------------------------------
*
* AsyncThreadProc --
|
| ︙ | ︙ | |||
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 |
}
}
Tcl_MutexUnlock(&asyncTestMutex);
Tcl_ExitThread(TCL_OK);
TCL_THREAD_CREATE_RETURN;
}
#endif
/*
*----------------------------------------------------------------------
*
* TestcmdinfoCmd --
*
* This procedure implements the "testcmdinfo" command. It is used to
* test Tcl_GetCommandInfo, Tcl_SetCommandInfo, and command creation and
* deletion.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates and deletes various commands and modifies their data.
*
*----------------------------------------------------------------------
*/
| > > > > > > > > > > > > > > > > > < < > | 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 |
}
}
Tcl_MutexUnlock(&asyncTestMutex);
Tcl_ExitThread(TCL_OK);
TCL_THREAD_CREATE_RETURN;
}
#endif
static int
TestbumpinterpepochObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *)interp;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
}
iPtr->compileEpoch++;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestcmdinfoCmd --
*
* This procedure implements the "testcmdinfo" command. It is used to
* test Tcl_GetCommandInfo, Tcl_SetCommandInfo, and command creation and
* deletion.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates and deletes various commands and modifies their data.
*
*----------------------------------------------------------------------
*/
static int
TestcmdinfoCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_CmdInfo info;
if (argc != 3) {
|
| ︙ | ︙ | |||
1127 1128 1129 1130 1131 1132 1133 |
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create, delete, get, or modify", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
| < | | < | | | 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 |
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create, delete, get, or modify", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static int
CmdProc1(
void *clientData, /* String to return. */
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData, NULL);
return TCL_OK;
}
static int
CmdProc2(
void *clientData, /* String to return. */
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData, NULL);
return TCL_OK;
}
static void
CmdDelProc1(
|
| ︙ | ︙ | |||
1186 1187 1188 1189 1190 1191 1192 | * * Side effects: * Creates and deletes various commands and modifies their data. * *---------------------------------------------------------------------- */ | < < > | 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 |
*
* Side effects:
* Creates and deletes various commands and modifies their data.
*
*----------------------------------------------------------------------
*/
static int
TestcmdtokenCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_Command token;
int *l;
char buf[30];
|
| ︙ | ︙ | |||
1250 1251 1252 1253 1254 1255 1256 | * Side effects: * Creates and deletes a command trace, and tests the invocation of * a procedure by the command trace. * *---------------------------------------------------------------------- */ | < < > | 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 |
* Side effects:
* Creates and deletes a command trace, and tests the invocation of
* a procedure by the command trace.
*
*----------------------------------------------------------------------
*/
static int
TestcmdtraceCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_DString buffer;
int result;
|
| ︙ | ︙ | |||
1345 1346 1347 1348 1349 1350 1351 |
}
static void
CmdTraceProc(
void *clientData, /* Pointer to buffer in which the
* command and arguments are appended.
* Accumulates test result. */
| | | | | < | | | < | | < | | | | | | | | | 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 |
}
static void
CmdTraceProc(
void *clientData, /* Pointer to buffer in which the
* command and arguments are appended.
* Accumulates test result. */
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*level*/,
char *command, /* The command being traced (after
* substitutions). */
TCL_UNUSED(Tcl_CmdProc *) /*cmdProc*/,
TCL_UNUSED(ClientData),
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(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*level*/,
TCL_UNUSED(char *) /*command*/,
TCL_UNUSED(Tcl_CmdProc *),
TCL_UNUSED(ClientData),
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(ClientData),
Tcl_Interp *interp, /* Tcl interpreter */
TCL_UNUSED(int) /*level*/,
const char *command,
TCL_UNUSED(Tcl_Command),
TCL_UNUSED(int) /*objc*/,
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *word = Tcl_GetString(objv[0]);
if (!strcmp(word, "Error")) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(command, -1));
return TCL_ERROR;
} else if (!strcmp(word, "Break")) {
|
| ︙ | ︙ | |||
1448 1449 1450 1451 1452 1453 1454 | * and "value:at:"). * *---------------------------------------------------------------------- */ static int TestcreatecommandCmd( | | | 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 |
* and "value:at:").
*
*----------------------------------------------------------------------
*/
static int
TestcreatecommandCmd(
TCL_UNUSED(ClientData),
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);
|
| ︙ | ︙ | |||
1478 1479 1480 1481 1482 1483 1484 |
return TCL_ERROR;
}
return TCL_OK;
}
static int
CreatedCommandProc(
| | | | | | | | 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 |
return TCL_ERROR;
}
return TCL_OK;
}
static int
CreatedCommandProc(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
Tcl_CmdInfo info;
int found;
found = Tcl_GetCommandInfo(interp, "test_ns_basic::createdcommand",
&info);
if (!found) {
Tcl_AppendResult(interp, "CreatedCommandProc could not get command info for test_ns_basic::createdcommand",
NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp, "CreatedCommandProc in ",
info.namespacePtr->fullName, NULL);
return TCL_OK;
}
static int
CreatedCommandProc2(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
Tcl_CmdInfo info;
int found;
found = Tcl_GetCommandInfo(interp, "value:at:", &info);
if (!found) {
Tcl_AppendResult(interp, "CreatedCommandProc2 could not get command info for test_ns_basic::createdcommand",
|
| ︙ | ︙ | |||
1536 1537 1538 1539 1540 1541 1542 | * * Side effects: * Creates and deletes interpreters. * *---------------------------------------------------------------------- */ | < < > | 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 |
*
* Side effects:
* Creates and deletes interpreters.
*
*----------------------------------------------------------------------
*/
static int
TestdcallCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int i, id;
delInterp = Tcl_CreateInterp();
|
| ︙ | ︙ | |||
1601 1602 1603 1604 1605 1606 1607 | * * Side effects: * Creates a command. * *---------------------------------------------------------------------- */ | < < > | | | | | | | | | | 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 |
*
* Side effects:
* Creates a command.
*
*----------------------------------------------------------------------
*/
static int
TestdelCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
DelCmd *dPtr;
Tcl_Interp *slave;
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
}
slave = Tcl_GetSlave(interp, argv[1]);
if (slave == 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(slave, argv[2], DelCmdProc, dPtr,
DelDeleteProc);
return TCL_OK;
}
static int
DelCmdProc(
void *clientData, /* String result to return. */
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
DelCmd *dPtr = (DelCmd *) clientData;
Tcl_AppendResult(interp, dPtr->deleteCmd, NULL);
ckfree(dPtr->deleteCmd);
ckfree(dPtr);
return TCL_OK;
}
static void
DelDeleteProc(
void *clientData) /* String command to evaluate. */
{
DelCmd *dPtr = (DelCmd *)clientData;
Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, -1, 0);
Tcl_ResetResult(dPtr->interp);
ckfree(dPtr->deleteCmd);
ckfree(dPtr);
}
/*
*----------------------------------------------------------------------
*
* TestdelassocdataCmd --
*
|
| ︙ | ︙ | |||
1679 1680 1681 1682 1683 1684 1685 | * interpreter. * *---------------------------------------------------------------------- */ static int TestdelassocdataCmd( | | | 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 |
* interpreter.
*
*----------------------------------------------------------------------
*/
static int
TestdelassocdataCmd(
TCL_UNUSED(ClientData),
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);
|
| ︙ | ︙ | |||
1715 1716 1717 1718 1719 1720 1721 | * type - One of 'shortest', 'e', 'f' * shorten - Indicates that the 'shorten' flag should be passed in. * *----------------------------------------------------------------------------- */ static int | | | | < < | | < | 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 |
* type - One of 'shortest', 'e', 'f'
* shorten - Indicates that the 'shorten' flag should be passed in.
*
*-----------------------------------------------------------------------------
*/
static int
TestdoubledigitsObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj* const objv[]) /* Parameter vector */
{
static const char* options[] = {
"shortest",
"e",
"f",
NULL
};
|
| ︙ | ︙ | |||
1774 1775 1776 1777 1778 1779 1780 |
}
type = types[type];
if (objc > 4) {
if (strcmp(Tcl_GetString(objv[4]), "shorten")) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", -1));
return TCL_ERROR;
}
| | | | 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 |
}
type = types[type];
if (objc > 4) {
if (strcmp(Tcl_GetString(objv[4]), "shorten")) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("bad flag", -1));
return TCL_ERROR;
}
type |= TCL_DD_SHORTEST;
}
str = TclDoubleDigits(d, ndigits, type, &decpt, &signum, &endPtr);
strObj = Tcl_NewStringObj(str, endPtr-str);
ckfree(str);
retval = Tcl_NewListObj(1, &strObj);
Tcl_ListObjAppendElement(NULL, retval, Tcl_NewIntObj(decpt));
strObj = Tcl_NewStringObj(signum ? "-" : "+", 1);
Tcl_ListObjAppendElement(NULL, retval, strObj);
Tcl_SetObjResult(interp, retval);
return TCL_OK;
}
|
| ︙ | ︙ | |||
1804 1805 1806 1807 1808 1809 1810 | * * Side effects: * Creates, deletes, and invokes handlers. * *---------------------------------------------------------------------- */ | < < > | 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 |
*
* Side effects:
* Creates, deletes, and invokes handlers.
*
*----------------------------------------------------------------------
*/
static int
TestdstringCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int count;
if (argc < 2) {
|
| ︙ | ︙ | |||
1856 1857 1858 1859 1860 1861 1862 |
goto wrongNumArgs;
}
if (strcmp(argv[2], "staticsmall") == 0) {
Tcl_AppendResult(interp, "short", NULL);
} else if (strcmp(argv[2], "staticlarge") == 0) {
Tcl_AppendResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", NULL);
} else if (strcmp(argv[2], "free") == 0) {
| | | | 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 |
goto wrongNumArgs;
}
if (strcmp(argv[2], "staticsmall") == 0) {
Tcl_AppendResult(interp, "short", NULL);
} else if (strcmp(argv[2], "staticlarge") == 0) {
Tcl_AppendResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", NULL);
} else if (strcmp(argv[2], "free") == 0) {
char *s = (char *)ckalloc(100);
strcpy(s, "This is a malloc-ed string");
Tcl_SetResult(interp, s, TCL_DYNAMIC);
} else if (strcmp(argv[2], "special") == 0) {
char *s = (char*)ckalloc(100) + 16;
strcpy(s, "This is a specially-allocated string");
Tcl_SetResult(interp, s, SpecialFree);
} else {
Tcl_AppendResult(interp, "bad gresult option \"", argv[2],
"\": must be staticsmall, staticlarge, free, or special",
NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
1908 1909 1910 1911 1912 1913 1914 | } /* * The procedure below is used as a special freeProc to test how well * Tcl_DStringGetResult handles freeProc's other than free. */ | | | < > | < < > | 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 |
}
/*
* The procedure below is used as a special freeProc to test how well
* Tcl_DStringGetResult handles freeProc's other than free.
*/
static void SpecialFree(
char *blockPtr /* Block to free. */
) {
ckfree(blockPtr - 16);
}
/*
*----------------------------------------------------------------------
*
* TestencodingCmd --
*
* This procedure implements the "testencoding" command. It is used
* to test the encoding package.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Load encodings.
*
*----------------------------------------------------------------------
*/
static int
TestencodingObjCmd(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
1962 1963 1964 1965 1966 1967 1968 |
switch ((enum options) index) {
case ENC_CREATE: {
Tcl_EncodingType type;
if (objc != 5) {
return TCL_ERROR;
}
| | | | | 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 |
switch ((enum options) index) {
case ENC_CREATE: {
Tcl_EncodingType type;
if (objc != 5) {
return TCL_ERROR;
}
encodingPtr = (TclEncoding*)ckalloc(sizeof(TclEncoding));
encodingPtr->interp = interp;
string = Tcl_GetStringFromObj(objv[3], &length);
encodingPtr->toUtfCmd = (char *)ckalloc(length + 1);
memcpy(encodingPtr->toUtfCmd, string, length + 1);
string = Tcl_GetStringFromObj(objv[4], &length);
encodingPtr->fromUtfCmd = (char *)ckalloc(length + 1);
memcpy(encodingPtr->fromUtfCmd, string, length + 1);
string = Tcl_GetStringFromObj(objv[2], &length);
type.encodingName = string;
type.toUtfProc = EncodingToUtfProc;
type.fromUtfProc = EncodingFromUtfProc;
|
| ︙ | ︙ | |||
2003 2004 2005 2006 2007 2008 2009 |
}
return TCL_OK;
}
static int
EncodingToUtfProc(
void *clientData, /* TclEncoding structure. */
| | | | | 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 |
}
return TCL_OK;
}
static int
EncodingToUtfProc(
void *clientData, /* TclEncoding structure. */
TCL_UNUSED(const char *) /*src*/,
int srcLen, /* Source string length in bytes. */
TCL_UNUSED(int) /*flags*/,
TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer. */
int dstLen, /* The maximum length of output buffer. */
int *srcReadPtr, /* Filled with number of bytes read. */
int *dstWrotePtr, /* Filled with number of bytes stored. */
int *dstCharsPtr) /* Filled with number of chars stored. */
{
int len;
|
| ︙ | ︙ | |||
2035 2036 2037 2038 2039 2040 2041 |
*dstCharsPtr = len;
return TCL_OK;
}
static int
EncodingFromUtfProc(
void *clientData, /* TclEncoding structure. */
| | | | | 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 |
*dstCharsPtr = len;
return TCL_OK;
}
static int
EncodingFromUtfProc(
void *clientData, /* TclEncoding structure. */
TCL_UNUSED(const char *) /*src*/,
int srcLen, /* Source string length in bytes. */
TCL_UNUSED(int) /*flags*/,
TCL_UNUSED(Tcl_EncodingState *),
char *dst, /* Output buffer. */
int dstLen, /* The maximum length of output buffer. */
int *srcReadPtr, /* Filled with number of bytes read. */
int *dstWrotePtr, /* Filled with number of bytes stored. */
int *dstCharsPtr) /* Filled with number of chars stored. */
{
int len;
|
| ︙ | ︙ | |||
2068 2069 2070 2071 2072 2073 2074 |
return TCL_OK;
}
static void
EncodingFreeProc(
void *clientData) /* ClientData associated with type. */
{
| | | | | | 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 |
return TCL_OK;
}
static void
EncodingFreeProc(
void *clientData) /* ClientData associated with type. */
{
TclEncoding *encodingPtr = (TclEncoding *)clientData;
ckfree(encodingPtr->toUtfCmd);
ckfree(encodingPtr->fromUtfCmd);
ckfree(encodingPtr);
}
/*
*----------------------------------------------------------------------
*
* TestevalexObjCmd --
*
|
| ︙ | ︙ | |||
2094 2095 2096 2097 2098 2099 2100 | * None. * *---------------------------------------------------------------------- */ static int TestevalexObjCmd( | | | 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestevalexObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int length, flags;
const char *script;
|
| ︙ | ︙ | |||
2139 2140 2141 2142 2143 2144 2145 | * None. * *---------------------------------------------------------------------- */ static int TestevalobjvObjCmd( | | | 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestevalobjvObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int evalGlobal;
if (objc < 3) {
|
| ︙ | ︙ | |||
2188 2189 2190 2191 2192 2193 2194 | * Manipulates the event queue as directed. * *---------------------------------------------------------------------- */ static int TesteventObjCmd( | | | 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 |
* Manipulates the event queue as directed.
*
*----------------------------------------------------------------------
*/
static int
TesteventObjCmd(
TCL_UNUSED(ClientData),
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
};
|
| ︙ | ︙ | |||
2227 2228 2229 2230 2231 2232 2233 |
Tcl_WrongNumArgs(interp, 2, objv, "name position script");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[3], positions,
"position specifier", TCL_EXACT, &posIndex) != TCL_OK) {
return TCL_ERROR;
}
| | | 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 |
Tcl_WrongNumArgs(interp, 2, objv, "name position script");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[3], positions,
"position specifier", TCL_EXACT, &posIndex) != TCL_OK) {
return TCL_ERROR;
}
ev = (TestEvent *)ckalloc(sizeof(TestEvent));
ev->header.proc = TesteventProc;
ev->header.nextPtr = NULL;
ev->interp = interp;
ev->command = objv[4];
Tcl_IncrRefCount(ev->command);
ev->tag = objv[2];
Tcl_IncrRefCount(ev->tag);
|
| ︙ | ︙ | |||
2273 2274 2275 2276 2277 2278 2279 |
*
*----------------------------------------------------------------------
*/
static int
TesteventProc(
Tcl_Event *event, /* Event to deliver */
| | | 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 |
*
*----------------------------------------------------------------------
*/
static int
TesteventProc(
Tcl_Event *event, /* Event to deliver */
TCL_UNUSED(int) /*flags*/)
{
TestEvent *ev = (TestEvent *) event;
Tcl_Interp *interp = ev->interp;
Tcl_Obj *command = ev->command;
int result = Tcl_EvalObjEx(interp, command,
TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
int retval;
|
| ︙ | ︙ | |||
2367 2368 2369 2370 2371 2372 2373 | * None. * *---------------------------------------------------------------------- */ static int TestexithandlerCmd( | | | 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexithandlerCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int value;
if (argc != 3) {
|
| ︙ | ︙ | |||
2401 2402 2403 2404 2405 2406 2407 |
}
static void
ExitProcOdd(
void *clientData) /* Integer value to print. */
{
char buf[16 + TCL_INTEGER_SPACE];
| | | | | | | | 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 |
}
static void
ExitProcOdd(
void *clientData) /* Integer value to print. */
{
char buf[16 + TCL_INTEGER_SPACE];
int len;
sprintf(buf, "odd %d\n", (int)PTR2INT(clientData));
len = strlen(buf);
if (len != (int) write(1, buf, len)) {
Tcl_Panic("ExitProcOdd: unable to write to stdout");
}
}
static void
ExitProcEven(
void *clientData) /* Integer value to print. */
{
char buf[16 + TCL_INTEGER_SPACE];
int len;
sprintf(buf, "even %d\n", (int)PTR2INT(clientData));
len = strlen(buf);
if (len != (int) write(1, buf, len)) {
Tcl_Panic("ExitProcEven: unable to write to stdout");
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2443 2444 2445 2446 2447 2448 2449 | * None. * *---------------------------------------------------------------------- */ static int TestexprlongCmd( | | | 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprlongCmd(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
2486 2487 2488 2489 2490 2491 2492 | * None. * *---------------------------------------------------------------------- */ static int TestexprlongobjCmd( | | | 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprlongobjCmd(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
2528 2529 2530 2531 2532 2533 2534 | * None. * *---------------------------------------------------------------------- */ static int TestexprdoubleCmd( | | | 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprdoubleCmd(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
2572 2573 2574 2575 2576 2577 2578 | * None. * *---------------------------------------------------------------------- */ static int TestexprdoubleobjCmd( | | | 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprdoubleobjCmd(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
2614 2615 2616 2617 2618 2619 2620 | * None. * *---------------------------------------------------------------------- */ static int TestexprstringCmd( | | | 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprstringCmd(
TCL_UNUSED(ClientData),
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);
|
| ︙ | ︙ | |||
2646 2647 2648 2649 2650 2651 2652 | * May create a link on disk. * *---------------------------------------------------------------------- */ static int TestfilelinkCmd( | | | 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 |
* May create a link on disk.
*
*----------------------------------------------------------------------
*/
static int
TestfilelinkCmd(
TCL_UNUSED(ClientData),
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) {
|
| ︙ | ︙ | |||
2713 2714 2715 2716 2717 2718 2719 | * None. * *---------------------------------------------------------------------- */ static int TestgetassocdataCmd( | | | 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestgetassocdataCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
char *res;
if (argc != 2) {
|
| ︙ | ︙ | |||
2751 2752 2753 2754 2755 2756 2757 | * None. * *---------------------------------------------------------------------- */ static int TestgetplatformCmd( | | | 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestgetplatformCmd(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
2789 2790 2791 2792 2793 2794 2795 | * * Side effects: * Deletes one or more interpreters. * *---------------------------------------------------------------------- */ | < < > | 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 |
*
* Side effects:
* Deletes one or more interpreters.
*
*----------------------------------------------------------------------
*/
static int
TestinterpdeleteCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_Interp *slaveToDelete;
if (argc != 2) {
|
| ︙ | ︙ | |||
2830 2831 2832 2833 2834 2835 2836 | * Side effects: * Creates and deletes various variable links, plus returns * values of the linked variables. * *---------------------------------------------------------------------- */ | < < > | | 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 |
* Side effects:
* Creates and deletes various variable links, plus returns
* values of the linked variables.
*
*----------------------------------------------------------------------
*/
static int
TestlinkCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
static int intVar = 43;
static int boolVar = 4;
static double realVar = 1.23;
static Tcl_WideInt wideVar = 79;
static char *stringVar = NULL;
static char charVar = '@';
static unsigned char ucharVar = 130;
static short shortVar = 3000;
static unsigned short ushortVar = 60000;
static unsigned int uintVar = 0xBEEFFEED;
static long longVar = 123456789L;
static unsigned long ulongVar = 3456789012UL;
static float floatVar = 4.5;
static Tcl_WideUInt uwideVar = 123;
static int created = 0;
char buffer[2*TCL_DOUBLE_SPACE];
int writable, flag;
|
| ︙ | ︙ | |||
2892 2893 2894 2895 2896 2897 2898 |
Tcl_UnlinkVar(interp, "uwide");
}
created = 1;
if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
| | | | | | | | | | | | | | | | 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 |
Tcl_UnlinkVar(interp, "uwide");
}
created = 1;
if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "int", &intVar,
TCL_LINK_INT | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "real", &realVar,
TCL_LINK_DOUBLE | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "bool", &boolVar,
TCL_LINK_BOOLEAN | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "string", &stringVar,
TCL_LINK_STRING | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[6], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "wide", &wideVar,
TCL_LINK_WIDE_INT | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[7], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "char", &charVar,
TCL_LINK_CHAR | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[8], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "uchar", &ucharVar,
TCL_LINK_UCHAR | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[9], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "short", &shortVar,
TCL_LINK_SHORT | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[10], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "ushort", &ushortVar,
TCL_LINK_USHORT | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[11], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "uint", &uintVar,
TCL_LINK_UINT | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[12], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "long", &longVar,
TCL_LINK_LONG | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[13], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "ulong", &ulongVar,
TCL_LINK_ULONG | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[14], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "float", &floatVar,
TCL_LINK_FLOAT | flag) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBoolean(interp, argv[15], &writable) != TCL_OK) {
return TCL_ERROR;
}
flag = (writable != 0) ? 0 : TCL_LINK_READ_ONLY;
if (Tcl_LinkVar(interp, "uwide", &uwideVar,
TCL_LINK_WIDE_UINT | flag) != TCL_OK) {
return TCL_ERROR;
}
} else if (strcmp(argv[1], "delete") == 0) {
Tcl_UnlinkVar(interp, "int");
Tcl_UnlinkVar(interp, "real");
|
| ︙ | ︙ | |||
3080 3081 3082 3083 3084 3085 3086 |
if (argv[4][0] != 0) {
if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {
return TCL_ERROR;
}
}
if (argv[5][0] != 0) {
if (stringVar != NULL) {
| | | | 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 |
if (argv[4][0] != 0) {
if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {
return TCL_ERROR;
}
}
if (argv[5][0] != 0) {
if (stringVar != NULL) {
ckfree(stringVar);
}
if (strcmp(argv[5], "-") == 0) {
stringVar = NULL;
} else {
stringVar = (char *)ckalloc(strlen(argv[5]) + 1);
strcpy(stringVar, argv[5]);
}
}
if (argv[6][0] != 0) {
tmp = Tcl_NewStringObj(argv[6], -1);
if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
Tcl_DecrRefCount(tmp);
|
| ︙ | ︙ | |||
3187 3188 3189 3190 3191 3192 3193 |
if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {
return TCL_ERROR;
}
Tcl_UpdateLinkedVar(interp, "bool");
}
if (argv[5][0] != 0) {
if (stringVar != NULL) {
| | | | 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 |
if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {
return TCL_ERROR;
}
Tcl_UpdateLinkedVar(interp, "bool");
}
if (argv[5][0] != 0) {
if (stringVar != NULL) {
ckfree(stringVar);
}
if (strcmp(argv[5], "-") == 0) {
stringVar = NULL;
} else {
stringVar = (char *)ckalloc(strlen(argv[5]) + 1);
strcpy(stringVar, argv[5]);
}
Tcl_UpdateLinkedVar(interp, "string");
}
if (argv[6][0] != 0) {
tmp = Tcl_NewStringObj(argv[6], -1);
if (Tcl_GetWideIntFromObj(interp, tmp, &wideVar) != TCL_OK) {
|
| ︙ | ︙ | |||
3301 3302 3303 3304 3305 3306 3307 | * Creates, deletes, and invokes variable links. * *---------------------------------------------------------------------- */ static int TestlinkarrayCmd( | | | 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 |
* Creates, deletes, and invokes variable links.
*
*----------------------------------------------------------------------
*/
static int
TestlinkarrayCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *LinkOption[] = {
"update", "remove", "create", NULL
};
|
| ︙ | ︙ | |||
3419 3420 3421 3422 3423 3424 3425 | * Modifies the current C locale. * *---------------------------------------------------------------------- */ static int TestlocaleCmd( | | < | 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 |
* Modifies the current C locale.
*
*----------------------------------------------------------------------
*/
static int
TestlocaleCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int index;
const char *locale;
static const char *const optionStrings[] = {
"ctype", "numeric", "time", "collate", "monetary",
"all", NULL
};
static const int lcTypes[] = {
LC_CTYPE, LC_NUMERIC, LC_TIME, LC_COLLATE, LC_MONETARY,
LC_ALL
|
| ︙ | ︙ | |||
3478 3479 3480 3481 3482 3483 3484 | * None. * * Side effects: * Releases storage. * *---------------------------------------------------------------------- */ | | | | | 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 |
* None.
*
* Side effects:
* Releases storage.
*
*----------------------------------------------------------------------
*/
static void
CleanupTestSetassocdataTests(
void *clientData, /* Data to be released. */
TCL_UNUSED(Tcl_Interp *))
{
ckfree(clientData);
}
/*
*----------------------------------------------------------------------
*
* TestparserObjCmd --
*
|
| ︙ | ︙ | |||
3506 3507 3508 3509 3510 3511 3512 | * None. * *---------------------------------------------------------------------- */ static int TestparserObjCmd( | | | 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparserObjCmd(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
3562 3563 3564 3565 3566 3567 3568 | * None. * *---------------------------------------------------------------------- */ static int TestexprparserObjCmd( | | | 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexprparserObjCmd(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
3709 3710 3711 3712 3713 3714 3715 | * None. * *---------------------------------------------------------------------- */ static int TestparsevarObjCmd( | | | 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparsevarObjCmd(
TCL_UNUSED(ClientData),
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) {
|
| ︙ | ︙ | |||
3750 3751 3752 3753 3754 3755 3756 | * None. * *---------------------------------------------------------------------- */ static int TestparsevarnameObjCmd( | | | 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparsevarnameObjCmd(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
3813 3814 3815 3816 3817 3818 3819 | * None. * *---------------------------------------------------------------------- */ static int TestpreferstableObjCmd( | | | | > | 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestpreferstableObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
Interp *iPtr = (Interp *) interp;
iPtr->packagePrefer = PKG_PREFER_STABLE;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3842 3843 3844 3845 3846 3847 3848 | * None. * *---------------------------------------------------------------------- */ static int TestprintObjCmd( | | | 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestprintObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_WideInt argv1 = 0;
size_t argv2;
|
| ︙ | ︙ | |||
3881 3882 3883 3884 3885 3886 3887 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < < > | < | 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
TestregexpObjCmd(
TCL_UNUSED(ClientData),
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",
|
| ︙ | ︙ | |||
4003 4004 4005 4006 4007 4008 4009 |
* value 0.
*/
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
if (objc > 2 && (cflags®_EXPECT) && indices) {
const char *varName;
const char *value;
| | | | | | | | | | | | | | 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 |
* value 0.
*/
Tcl_SetIntObj(Tcl_GetObjResult(interp), 0);
if (objc > 2 && (cflags®_EXPECT) && indices) {
const char *varName;
const char *value;
int start, end;
char resinfo[TCL_INTEGER_SPACE * 2];
varName = Tcl_GetString(objv[2]);
TclRegExpRangeUniChar(regExpr, -1, &start, &end);
sprintf(resinfo, "%d %d", start, end-1);
value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
varName, "\"", NULL);
return TCL_ERROR;
}
} else if (cflags & TCL_REG_CANMATCH) {
const char *varName;
const char *value;
char resinfo[TCL_INTEGER_SPACE * 2];
Tcl_RegExpGetInfo(regExpr, &info);
varName = Tcl_GetString(objv[2]);
sprintf(resinfo, "%ld", info.extendStart);
value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0);
if (value == NULL) {
Tcl_AppendResult(interp, "couldn't set variable \"",
varName, "\"", NULL);
return TCL_ERROR;
}
}
return TCL_OK;
}
/*
* If additional variable names have been specified, return
* index information in those variables.
*/
objc -= 2;
objv += 2;
Tcl_RegExpGetInfo(regExpr, &info);
for (i = 0; i < objc; i++) {
int start, end;
Tcl_Obj *newPtr, *varPtr, *valuePtr;
varPtr = objv[i];
ii = ((cflags®_EXPECT) && i == objc-1) ? -1 : i;
if (indices) {
Tcl_Obj *objs[2];
if (ii == -1) {
TclRegExpRangeUniChar(regExpr, ii, &start, &end);
} else if (ii > info.nsubs) {
start = -1;
end = -1;
} else {
start = info.matches[ii].start;
end = info.matches[ii].end;
}
/*
* Adjust index so it refers to the last character in the match
* instead of the first character after the match.
*/
if (end >= 0) {
end--;
}
objs[0] = Tcl_NewWideIntObj(start);
objs[1] = Tcl_NewWideIntObj(end);
newPtr = Tcl_NewListObj(2, objs);
} else {
if (ii == -1) {
TclRegExpRangeUniChar(regExpr, ii, &start, &end);
newPtr = Tcl_GetRange(objPtr, start, end);
} else if (ii > info.nsubs) {
newPtr = Tcl_NewObj();
} else {
newPtr = Tcl_GetRange(objPtr, info.matches[ii].start,
info.matches[ii].end - 1);
|
| ︙ | ︙ | |||
4119 4120 4121 4122 4123 4124 4125 |
*
*----------------------------------------------------------------------
*/
static void
TestregexpXflags(
const char *string, /* The string of flags. */
| | < | | 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 |
*
*----------------------------------------------------------------------
*/
static void
TestregexpXflags(
const char *string, /* The string of flags. */
int length, /* The length of the string in bytes. */
int *cflagsPtr, /* compile flags word */
int *eflagsPtr) /* exec flags word */
{
int i, cflags, eflags;
cflags = *cflagsPtr;
eflags = *eflagsPtr;
for (i = 0; i < length; i++) {
switch (string[i]) {
case 'a':
cflags |= REG_ADVF;
|
| ︙ | ︙ | |||
4207 4208 4209 4210 4211 4212 4213 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < < > | | | | 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
TestreturnObjCmd(
TCL_UNUSED(ClientData),
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
return TCL_RETURN;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4238 4239 4240 4241 4242 4243 4244 | * data for this interpreter. * *---------------------------------------------------------------------- */ static int TestsetassocdataCmd( | | | | | 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 |
* data for this interpreter.
*
*----------------------------------------------------------------------
*/
static int
TestsetassocdataCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
char *buf, *oldData;
Tcl_InterpDeleteProc *procPtr;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
" data_key data_item\"", NULL);
return TCL_ERROR;
}
buf = (char *)ckalloc(strlen(argv[2]) + 1);
strcpy(buf, argv[2]);
/*
* If we previously associated a malloced value with the variable,
* free it before associating a new value.
*/
oldData = (char *) Tcl_GetAssocData(interp, argv[1], &procPtr);
if ((oldData != NULL) && (procPtr == CleanupTestSetassocdataTests)) {
ckfree(oldData);
}
Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, buf);
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
4289 4290 4291 4292 4293 4294 4295 | * Sets the tclPlatform global variable. * *---------------------------------------------------------------------- */ static int TestsetplatformCmd( | | | 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 |
* Sets the tclPlatform global variable.
*
*----------------------------------------------------------------------
*/
static int
TestsetplatformCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
size_t length;
TclPlatformType *platform;
|
| ︙ | ︙ | |||
4338 4339 4340 4341 4342 4343 4344 | * variable "x" in that interpreter is set to "loaded". * *---------------------------------------------------------------------- */ static int TeststaticpkgCmd( | | | 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 4239 |
* variable "x" in that interpreter is set to "loaded".
*
*----------------------------------------------------------------------
*/
static int
TeststaticpkgCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int safe, loaded;
if (argc != 4) {
|
| ︙ | ︙ | |||
4389 4390 4391 4392 4393 4394 4395 | * None. * *---------------------------------------------------------------------- */ static int TesttranslatefilenameCmd( | | | 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TesttranslatefilenameCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
Tcl_DString buffer;
const char *result;
|
| ︙ | ︙ | |||
4428 4429 4430 4431 4432 4433 4434 | * * Side effects: * Creates or modifies an "upvar" reference. * *---------------------------------------------------------------------- */ | < < > | 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 |
*
* Side effects:
* Creates or modifies an "upvar" reference.
*
*----------------------------------------------------------------------
*/
static int
TestupvarCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int flags = 0;
if ((argc != 5) && (argc != 6)) {
|
| ︙ | ︙ | |||
4481 4482 4483 4484 4485 4486 4487 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < < > | 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestseterrorcodeCmd(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
4534 4535 4536 4537 4538 4539 4540 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < < > | 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestsetobjerrorcodeCmd(
TCL_UNUSED(ClientData),
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;
}
|
| ︙ | ︙ | |||
4563 4564 4565 4566 4567 4568 4569 | * * Side effects: * Creates and deletes interpreters. * *---------------------------------------------------------------------- */ | < | | 4447 4448 4449 4450 4451 4452 4453 4454 4455 4456 4457 4458 4459 4460 4461 4462 4463 |
*
* Side effects:
* Creates and deletes interpreters.
*
*----------------------------------------------------------------------
*/
static int
TestfeventCmd(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
4638 4639 4640 4641 4642 4643 4644 | * May exit application. * *---------------------------------------------------------------------- */ static int TestpanicCmd( | | | < < | | | | 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 |
* May exit application.
*
*----------------------------------------------------------------------
*/
static int
TestpanicCmd(
TCL_UNUSED(ClientData),
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(ClientData),
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;
|
| ︙ | ︙ | |||
4741 4742 4743 4744 4745 4746 4747 | * None. * *---------------------------------------------------------------------- */ static int TestgetvarfullnameCmd( | | | 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestgetvarfullnameCmd(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
4815 4816 4817 4818 4819 4820 4821 | * Allocates and frees memory, sets a variable "a" in the interpreter. * *---------------------------------------------------------------------- */ static int GetTimesObjCmd( | | | | | | | | | | 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 |
* Allocates and frees memory, sets a variable "a" in the interpreter.
*
*----------------------------------------------------------------------
*/
static int
GetTimesObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* The current interpreter. */
TCL_UNUSED(int) /*cobjc*/,
TCL_UNUSED(Tcl_Obj *const *) /*cobjv*/)
{
Interp *iPtr = (Interp *) interp;
int i, n;
double timePer;
Tcl_Time start, stop;
Tcl_Obj *objPtr, **objv;
const char *s;
char newString[TCL_INTEGER_SPACE];
/* alloc & free 100000 times */
fprintf(stderr, "alloc & free 100000 6 word items\n");
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
objPtr = (Tcl_Obj *)ckalloc(sizeof(Tcl_Obj));
ckfree(objPtr);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per alloc+free\n", timePer/100000);
/* alloc 5000 times */
fprintf(stderr, "alloc 5000 6 word items\n");
objv = (Tcl_Obj **)ckalloc(5000 * sizeof(Tcl_Obj *));
Tcl_GetTime(&start);
for (i = 0; i < 5000; i++) {
objv[i] = (Tcl_Obj *)ckalloc(sizeof(Tcl_Obj));
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per alloc\n", timePer/5000);
/* free 5000 times */
fprintf(stderr, "free 5000 6 word items\n");
Tcl_GetTime(&start);
for (i = 0; i < 5000; i++) {
ckfree(objv[i]);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per free\n", timePer/5000);
/* Tcl_NewObj 5000 times */
fprintf(stderr, "Tcl_NewObj 5000 times\n");
|
| ︙ | ︙ | |||
4880 4881 4882 4883 4884 4885 4886 |
for (i = 0; i < 5000; i++) {
objPtr = objv[i];
Tcl_DecrRefCount(objPtr);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000);
| | | 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 |
for (i = 0; i < 5000; i++) {
objPtr = objv[i];
Tcl_DecrRefCount(objPtr);
}
Tcl_GetTime(&stop);
timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000);
ckfree(objv);
/* TclGetString 100000 times */
fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n");
objPtr = Tcl_NewStringObj("12345", -1);
Tcl_GetTime(&start);
for (i = 0; i < 100000; i++) {
(void) TclGetString(objPtr);
|
| ︙ | ︙ | |||
4994 4995 4996 4997 4998 4999 5000 | * None. * *---------------------------------------------------------------------- */ static int NoopCmd( | | | | | | 4875 4876 4877 4878 4879 4880 4881 4882 4883 4884 4885 4886 4887 4888 4889 4890 4891 4892 |
* None.
*
*----------------------------------------------------------------------
*/
static int
NoopCmd(
TCL_UNUSED(ClientData),
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
5021 5022 5023 5024 5025 5026 5027 | * None. * *---------------------------------------------------------------------- */ static int NoopObjCmd( | | | | | | 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 |
* None.
*
*----------------------------------------------------------------------
*/
static int
NoopObjCmd(
TCL_UNUSED(ClientData),
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
5046 5047 5048 5049 5050 5051 5052 | * None. * *---------------------------------------------------------------------- */ static int TeststringbytesObjCmd( | | | 4927 4928 4929 4930 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TeststringbytesObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int n;
const unsigned char *p;
|
| ︙ | ︙ | |||
5086 5087 5088 5089 5090 5091 5092 | * None. * *---------------------------------------------------------------------- */ static int TestpurebytesobjObjCmd( | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | | < | 4967 4968 4969 4970 4971 4972 4973 4974 4975 4976 4977 4978 4979 4980 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 5008 5009 5010 5011 5012 5013 5014 5015 5016 5017 5018 5019 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 5055 5056 5057 5058 5059 5060 5061 5062 5063 5064 5065 5066 5067 5068 5069 5070 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 5086 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestpurebytesobjObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
Tcl_Obj *objPtr;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?string?");
return TCL_ERROR;
}
objPtr = Tcl_NewObj();
/*
objPtr->internalRep.twoPtrValue.ptr1 = NULL;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
*/
memset(&objPtr->internalRep, 0, sizeof(objPtr->internalRep));
if (objc == 2) {
const char *s = Tcl_GetString(objv[1]);
objPtr->length = objv[1]->length;
objPtr->bytes = (char *)ckalloc(objPtr->length + 1);
memcpy(objPtr->bytes, s, objPtr->length);
objPtr->bytes[objPtr->length] = 0;
}
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestsetbytearraylengthObjCmd --
*
* Testing command 'testsetbytearraylength` used to test the public
* interface routine Tcl_SetByteArrayLength().
*
* Results:
* Returns the TCL_OK result code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestsetbytearraylengthObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int n;
Tcl_Obj *obj = NULL;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "value length");
return TCL_ERROR;
}
if (TCL_OK != Tcl_GetIntFromObj(interp, objv[2], &n)) {
return TCL_ERROR;
}
if (Tcl_IsShared(objv[1])) {
obj = Tcl_DuplicateObj(objv[1]);
} else {
obj = objv[1];
}
Tcl_SetByteArrayLength(obj, n);
Tcl_SetObjResult(interp, obj);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestbytestringObjCmd --
*
* This object-based procedure constructs a string which can
* possibly contain invalid UTF-8 bytes.
*
* Results:
* Returns the TCL_OK result code.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestbytestringObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
int n = 0;
const char *p;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "bytearray");
return TCL_ERROR;
}
p = (const char *)TclGetBytesFromObj(interp, objv[1], &n);
if (p == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(p, n));
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
5171 5172 5173 5174 5175 5176 5177 | * * Side effects: * Variables may be set. * *---------------------------------------------------------------------- */ | < | | 5096 5097 5098 5099 5100 5101 5102 5103 5104 5105 5106 5107 5108 5109 5110 5111 5112 5113 |
*
* Side effects:
* Variables may be set.
*
*----------------------------------------------------------------------
*/
static int
TestsetCmd(
void *data, /* Additional flags for Get/SetVar2. */
Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int flags = PTR2INT(data);
const char *value;
if (argc == 2) {
|
| ︙ | ︙ | |||
5207 5208 5209 5210 5211 5212 5213 |
argv[0], " varName ?newValue?\"", NULL);
return TCL_ERROR;
}
}
static int
Testset2Cmd(
void *data, /* Additional flags for Get/SetVar2. */
| | | 5131 5132 5133 5134 5135 5136 5137 5138 5139 5140 5141 5142 5143 5144 5145 |
argv[0], " varName ?newValue?\"", NULL);
return TCL_ERROR;
}
}
static int
Testset2Cmd(
void *data, /* Additional flags for Get/SetVar2. */
Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
int flags = PTR2INT(data);
const char *value;
if (argc == 3) {
|
| ︙ | ︙ | |||
5254 5255 5256 5257 5258 5259 5260 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < < > | > | 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestsaveresultCmd(
TCL_UNUSED(ClientData),
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;
Tcl_Obj *objPtr;
static const char *const optionStrings[] = {
"append", "dynamic", "free", "object", "small", NULL
};
enum options {
|
| ︙ | ︙ | |||
5298 5299 5300 5301 5302 5303 5304 |
case RESULT_SMALL:
Tcl_AppendResult(interp, "small result", NULL);
break;
case RESULT_APPEND:
Tcl_AppendResult(interp, "append result", NULL);
break;
case RESULT_FREE: {
| | | 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 |
case RESULT_SMALL:
Tcl_AppendResult(interp, "small result", NULL);
break;
case RESULT_APPEND:
Tcl_AppendResult(interp, "append result", NULL);
break;
case RESULT_FREE: {
char *buf = (char *)ckalloc(200);
strcpy(buf, "free result");
Tcl_SetResult(interp, buf, TCL_DYNAMIC);
break;
}
case RESULT_DYNAMIC:
Tcl_SetResult(interp, (char *)"dynamic result", TestsaveresultFree);
|
| ︙ | ︙ | |||
5329 5330 5331 5332 5333 5334 5335 |
Tcl_DiscardResult(&state);
} else {
Tcl_RestoreResult(interp, &state);
result = TCL_OK;
}
switch ((enum options) index) {
| | > > | > | 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 |
Tcl_DiscardResult(&state);
} else {
Tcl_RestoreResult(interp, &state);
result = TCL_OK;
}
switch ((enum options) index) {
case RESULT_DYNAMIC: {
int presentOrFreed = (iPtr->freeProc == TestsaveresultFree) ^ freeCount;
Tcl_AppendElement(interp, presentOrFreed ? "presentOrFreed" : "missingOrLeak");
break;
}
case RESULT_OBJECT:
Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr
? "same" : "different");
break;
default:
break;
}
|
| ︙ | ︙ | |||
5360 5361 5362 5363 5364 5365 5366 | * Increments the freeCount. * *---------------------------------------------------------------------- */ static void TestsaveresultFree( | | | 5287 5288 5289 5290 5291 5292 5293 5294 5295 5296 5297 5298 5299 5300 5301 |
* Increments the freeCount.
*
*----------------------------------------------------------------------
*/
static void
TestsaveresultFree(
TCL_UNUSED(char *))
{
freeCount++;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
5384 5385 5386 5387 5388 5389 5390 | * None. * *---------------------------------------------------------------------- */ static int TestmainthreadCmd( | | | | | 5311 5312 5313 5314 5315 5316 5317 5318 5319 5320 5321 5322 5323 5324 5325 5326 5327 5328 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestmainthreadCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,/* Current interpreter. */
int argc, /* Number of arguments. */
TCL_UNUSED(const char **) /*argv*/)
{
if (argc == 1) {
Tcl_Obj *idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
Tcl_SetObjResult(interp, idObj);
return TCL_OK;
} else {
|
| ︙ | ︙ | |||
5445 5446 5447 5448 5449 5450 5451 | * None. * *---------------------------------------------------------------------- */ static int TestsetmainloopCmd( | | | | | | | | | 5372 5373 5374 5375 5376 5377 5378 5379 5380 5381 5382 5383 5384 5385 5386 5387 5388 5389 5390 5391 5392 5393 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestsetmainloopCmd(
TCL_UNUSED(ClientData),
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
exitMainLoop = 0;
Tcl_SetMainLoop(MainLoop);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestexitmainloopCmd --
*
|
| ︙ | ︙ | |||
5474 5475 5476 5477 5478 5479 5480 | * None. * *---------------------------------------------------------------------- */ static int TestexitmainloopCmd( | | | | | | | < | | 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 5414 5415 5416 5417 5418 5419 5420 5421 5422 5423 5424 5425 5426 5427 5428 5429 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestexitmainloopCmd(
TCL_UNUSED(ClientData),
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
exitMainLoop = 1;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestChannelCmd --
*
* Implements the Tcl "testchannel" debugging command and its
* subcommands. This is part of the testing environment.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestChannelCmd(
TCL_UNUSED(ClientData),
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. */
|
| ︙ | ︙ | |||
5547 5548 5549 5550 5551 5552 5553 |
curPtr != NULL;
nextPtrPtr = &(curPtr->nextPtr), curPtr = curPtr->nextPtr) {
if (strcmp(argv[2], Tcl_GetChannelName(curPtr->chan)) == 0) {
*nextPtrPtr = curPtr->nextPtr;
curPtr->nextPtr = NULL;
chan = curPtr->chan;
| | < | 5473 5474 5475 5476 5477 5478 5479 5480 5481 5482 5483 5484 5485 5486 5487 5488 5489 5490 5491 5492 5493 5494 5495 5496 5497 5498 5499 5500 5501 |
curPtr != NULL;
nextPtrPtr = &(curPtr->nextPtr), curPtr = curPtr->nextPtr) {
if (strcmp(argv[2], Tcl_GetChannelName(curPtr->chan)) == 0) {
*nextPtrPtr = curPtr->nextPtr;
curPtr->nextPtr = NULL;
chan = curPtr->chan;
ckfree(curPtr);
break;
}
}
} else {
chan = Tcl_GetChannel(interp, argv[2], &mode);
}
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
chanPtr = (Channel *) chan;
statePtr = chanPtr->state;
chanPtr = statePtr->topChanPtr;
chan = (Tcl_Channel) chanPtr;
} else {
statePtr = NULL;
chan = NULL;
}
if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerror", len) == 0)) {
Tcl_Obj *msg = Tcl_NewStringObj(argv[3],-1);
|
| ︙ | ︙ | |||
5617 5618 5619 5620 5621 5622 5623 | Tcl_RegisterChannel(NULL, chan); /* prevent closing */ Tcl_UnregisterChannel(interp, chan); Tcl_CutChannel(chan); /* Remember the channel in the pool of detached channels */ | | | 5542 5543 5544 5545 5546 5547 5548 5549 5550 5551 5552 5553 5554 5555 5556 |
Tcl_RegisterChannel(NULL, chan); /* prevent closing */
Tcl_UnregisterChannel(interp, chan);
Tcl_CutChannel(chan);
/* Remember the channel in the pool of detached channels */
det = (TestChannel *)ckalloc(sizeof(TestChannel));
det->chan = chan;
det->nextPtr = firstDetached;
firstDetached = det;
return TCL_OK;
}
|
| ︙ | ︙ | |||
5809 5810 5811 5812 5813 5814 5815 |
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == NULL) {
return TCL_OK;
}
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
| | | 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 |
hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, "tclIO", NULL);
if (hTblPtr == NULL) {
return TCL_OK;
}
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
Tcl_AppendElement(interp, (char *)Tcl_GetHashKey(hTblPtr, hPtr));
}
return TCL_OK;
}
if ((cmdName[0] == 'o') &&
(strncmp(cmdName, "outputbuffered", len) == 0)) {
if (argc != 3) {
|
| ︙ | ︙ | |||
5850 5851 5852 5853 5854 5855 5856 |
}
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
chanPtr = (Channel *) Tcl_GetHashValue(hPtr);
statePtr = chanPtr->state;
if (statePtr->flags & TCL_READABLE) {
| | | 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 |
}
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != NULL;
hPtr = Tcl_NextHashEntry(&hSearch)) {
chanPtr = (Channel *) Tcl_GetHashValue(hPtr);
statePtr = chanPtr->state;
if (statePtr->flags & TCL_READABLE) {
Tcl_AppendElement(interp, (char *)Tcl_GetHashKey(hTblPtr, hPtr));
}
}
return TCL_OK;
}
if ((cmdName[0] == 'r') && (strncmp(cmdName, "refcount", len) == 0)) {
if (argc != 3) {
|
| ︙ | ︙ | |||
5907 5908 5909 5910 5911 5912 5913 |
return TCL_OK;
}
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
chanPtr = (Channel *) Tcl_GetHashValue(hPtr);
statePtr = chanPtr->state;
if (statePtr->flags & TCL_WRITABLE) {
| | | 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 |
return TCL_OK;
}
for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
chanPtr = (Channel *) Tcl_GetHashValue(hPtr);
statePtr = chanPtr->state;
if (statePtr->flags & TCL_WRITABLE) {
Tcl_AppendElement(interp, (char *)Tcl_GetHashKey(hTblPtr, hPtr));
}
}
return TCL_OK;
}
if ((cmdName[0] == 't') && (strncmp(cmdName, "transform", len) == 0)) {
/*
|
| ︙ | ︙ | |||
5969 5970 5971 5972 5973 5974 5975 | * * Side effects: * Creates, deletes and returns channel event handlers. * *---------------------------------------------------------------------- */ | < < > | 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 5908 5909 5910 |
*
* Side effects:
* Creates, deletes and returns channel event handlers.
*
*----------------------------------------------------------------------
*/
static int
TestChannelEventCmd(
TCL_UNUSED(ClientData),
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 */
|
| ︙ | ︙ | |||
6015 6016 6017 6018 6019 6020 6021 |
mask = 0;
} else {
Tcl_AppendResult(interp, "bad event name \"", argv[3],
"\": must be readable, writable, or none", NULL);
return TCL_ERROR;
}
| | | 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 |
mask = 0;
} else {
Tcl_AppendResult(interp, "bad event name \"", argv[3],
"\": must be readable, writable, or none", NULL);
return TCL_ERROR;
}
esPtr = (EventScriptRecord *)ckalloc(sizeof(EventScriptRecord));
esPtr->nextPtr = statePtr->scriptRecordPtr;
statePtr->scriptRecordPtr = esPtr;
esPtr->chanPtr = chanPtr;
esPtr->interp = interp;
esPtr->mask = mask;
esPtr->scriptPtr = Tcl_NewStringObj(argv[4], -1);
|
| ︙ | ︙ | |||
6072 6073 6074 6075 6076 6077 6078 |
Tcl_Panic("TestChannelEventCmd: damaged event script list");
}
prevEsPtr->nextPtr = esPtr->nextPtr;
}
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
| | | 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 |
Tcl_Panic("TestChannelEventCmd: damaged event script list");
}
prevEsPtr->nextPtr = esPtr->nextPtr;
}
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
ckfree(esPtr);
return TCL_OK;
}
if ((cmd[0] == 'l') && (strncmp(cmd, "list", len) == 0)) {
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
|
| ︙ | ︙ | |||
6113 6114 6115 6116 6117 6118 6119 |
for (esPtr = statePtr->scriptRecordPtr;
esPtr != NULL;
esPtr = nextEsPtr) {
nextEsPtr = esPtr->nextPtr;
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
| | | 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 |
for (esPtr = statePtr->scriptRecordPtr;
esPtr != NULL;
esPtr = nextEsPtr) {
nextEsPtr = esPtr->nextPtr;
Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
TclChannelEventScriptInvoker, esPtr);
Tcl_DecrRefCount(esPtr->scriptPtr);
ckfree(esPtr);
}
statePtr->scriptRecordPtr = NULL;
return TCL_OK;
}
if ((cmd[0] == 's') && (strncmp(cmd, "set", len) == 0)) {
if (argc != 5) {
|
| ︙ | ︙ | |||
6182 6183 6184 6185 6186 6187 6188 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < | | 6106 6107 6108 6109 6110 6111 6112 6113 6114 6115 6116 6117 6118 6119 6120 6121 6122 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestSocketCmd(
TCL_UNUSED(ClientData),
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. */
|
| ︙ | ︙ | |||
6252 6253 6254 6255 6256 6257 6258 | * Sets interpreter result. * *---------------------------------------------------------------------- */ static int TestWrongNumArgsObjCmd( | | | 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 |
* Sets interpreter result.
*
*----------------------------------------------------------------------
*/
static int
TestWrongNumArgsObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, length;
const char *msg;
|
| ︙ | ︙ | |||
6308 6309 6310 6311 6312 6313 6314 | * Sets interpreter result. * *---------------------------------------------------------------------- */ static int TestGetIndexFromObjStructObjCmd( | | | 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 |
* Sets interpreter result.
*
*----------------------------------------------------------------------
*/
static int
TestGetIndexFromObjStructObjCmd(
TCL_UNUSED(ClientData),
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
};
|
| ︙ | ︙ | |||
6362 6363 6364 6365 6366 6367 6368 | * Inserts or removes a filesystem from Tcl's stack. * *---------------------------------------------------------------------- */ static int TestFilesystemObjCmd( | | | 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 6298 6299 |
* Inserts or removes a filesystem from Tcl's stack.
*
*----------------------------------------------------------------------
*/
static int
TestFilesystemObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int res, boolVal;
const char *msg;
|
| ︙ | ︙ | |||
6441 6442 6443 6444 6445 6446 6447 |
if (nativeRep != NULL) {
/* Free the path */
Tcl_DecrRefCount(nativeRep);
}
}
| | < < < < < | 6364 6365 6366 6367 6368 6369 6370 6371 6372 6373 6374 6375 6376 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 6394 6395 6396 6397 6398 |
if (nativeRep != NULL) {
/* Free the path */
Tcl_DecrRefCount(nativeRep);
}
}
static void *
TestReportDupInternalRep(
void *clientData)
{
Tcl_Obj *original = (Tcl_Obj *) clientData;
Tcl_IncrRefCount(original);
return clientData;
}
static void
TestReport(
const char *cmd,
Tcl_Obj *path,
Tcl_Obj *arg2)
{
Tcl_Interp *interp = (Tcl_Interp *) Tcl_FSData(&testReportingFilesystem);
if (interp == NULL) {
/* This is bad, but not much we can do about it */
} else {
Tcl_Obj *savedResult;
Tcl_DString ds;
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, "lappend filesystemReport ", -1);
Tcl_DStringStartSublist(&ds);
Tcl_DStringAppendElement(&ds, cmd);
|
| ︙ | ︙ | |||
6698 6699 6700 6701 6702 6703 6704 |
{
TestReport("utime", fileName, NULL);
return Tcl_FSUtime(TestReportGetNativePath(fileName), tval);
}
static int
TestReportNormalizePath(
| | | | 6616 6617 6618 6619 6620 6621 6622 6623 6624 6625 6626 6627 6628 6629 6630 6631 6632 6633 6634 6635 6636 6637 6638 6639 6640 6641 |
{
TestReport("utime", fileName, NULL);
return Tcl_FSUtime(TestReportGetNativePath(fileName), tval);
}
static int
TestReportNormalizePath(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *pathPtr,
int nextCheckpoint)
{
TestReport("normalizepath", pathPtr, NULL);
return nextCheckpoint;
}
static int
SimplePathInFilesystem(
Tcl_Obj *pathPtr,
TCL_UNUSED(ClientData *))
{
const char *str = Tcl_GetString(pathPtr);
if (strncmp(str, "simplefs:/", 10)) {
return -1;
}
return TCL_OK;
|
| ︙ | ︙ | |||
6738 6739 6740 6741 6742 6743 6744 | * 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( | | | 6656 6657 6658 6659 6660 6661 6662 6663 6664 6665 6666 6667 6668 6669 6670 |
* 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(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int res, boolVal;
const char *msg;
|
| ︙ | ︙ | |||
6891 6892 6893 6894 6895 6896 6897 6898 6899 6900 6901 6902 6903 6904 |
/* Add one new volume */
Tcl_Obj *retVal;
retVal = Tcl_NewStringObj("simplefs:/", -1);
Tcl_IncrRefCount(retVal);
return retVal;
}
/*
* Used to check correct string-length determining in Tcl_NumUtfChars
*/
static int
TestNumUtfCharsCmd(
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > | > | > > > > | | | 6809 6810 6811 6812 6813 6814 6815 6816 6817 6818 6819 6820 6821 6822 6823 6824 6825 6826 6827 6828 6829 6830 6831 6832 6833 6834 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 6846 6847 6848 6849 6850 6851 6852 6853 6854 6855 6856 6857 6858 6859 6860 6861 6862 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 6886 6887 6888 6889 6890 6891 6892 6893 6894 6895 6896 6897 6898 6899 6900 6901 6902 6903 6904 6905 6906 6907 6908 6909 6910 6911 6912 6913 6914 6915 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 6928 6929 6930 6931 6932 6933 6934 6935 6936 6937 6938 6939 6940 6941 6942 6943 6944 6945 6946 6947 6948 6949 6950 6951 6952 6953 6954 6955 6956 6957 6958 6959 6960 |
/* Add one new volume */
Tcl_Obj *retVal;
retVal = Tcl_NewStringObj("simplefs:/", -1);
Tcl_IncrRefCount(retVal);
return retVal;
}
/*
* Used to check operations of Tcl_UtfNext.
*
* Usage: testutfnext -bytestring $bytes
*/
static int
TestUtfNextCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int numBytes;
char *bytes;
const char *result, *first;
char buffer[32];
static const char tobetested[] = "A\xA0\xC0\xC1\xC2\xD0\xE0\xE8\xF2\xF7\xF8\xFE\xFF";
const char *p = tobetested;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?-bytestring? bytes");
return TCL_ERROR;
}
bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
if (numBytes > (int)sizeof(buffer) - 4) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"testutfnext\" can only handle %d bytes",
(int)sizeof(buffer) - 4));
return TCL_ERROR;
}
memcpy(buffer + 1, bytes, numBytes);
buffer[0] = buffer[numBytes + 1] = buffer[numBytes + 2] = buffer[numBytes + 3] = '\xA0';
first = result = Tcl_UtfNext(buffer + 1);
while ((buffer[0] = *p++) != '\0') {
/* Run Tcl_UtfNext with many more possible bytes at src[-1], all should give the same result */
result = Tcl_UtfNext(buffer + 1);
if (first != result) {
Tcl_AppendResult(interp, "Tcl_UtfNext is not supposed to read src[-1]", NULL);
return TCL_ERROR;
}
}
p = tobetested;
while ((buffer[numBytes + 1] = *p++) != '\0') {
/* Run Tcl_UtfNext with many more possible bytes at src[end], all should give the same result */
result = Tcl_UtfNext(buffer + 1);
if (first != result) {
first = buffer;
break;
}
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(first - buffer - 1));
return TCL_OK;
}
/*
* Used to check operations of Tcl_UtfPrev.
*
* Usage: testutfprev $bytes $offset
*/
static int
TestUtfPrevCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int numBytes, offset;
char *bytes;
const char *result;
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "bytes ?offset?");
return TCL_ERROR;
}
bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
if (objc == 3) {
if (TCL_OK != Tcl_GetIntForIndex(interp, objv[2], numBytes, &offset)) {
return TCL_ERROR;
}
if (offset < 0) {
offset = 0;
}
if (offset > numBytes) {
offset = numBytes;
}
} else {
offset = numBytes;
}
result = TclUtfPrev(bytes + offset, bytes);
Tcl_SetObjResult(interp, Tcl_NewIntObj(result - bytes));
return TCL_OK;
}
/*
* Used to check correct string-length determining in Tcl_NumUtfChars
*/
static int
TestNumUtfCharsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc > 1) {
int numBytes, len, limit = -1;
const char *bytes = Tcl_GetStringFromObj(objv[1], &numBytes);
if (objc > 2) {
if (Tcl_GetIntForIndex(interp, objv[2], numBytes, &limit) != TCL_OK) {
return TCL_ERROR;
}
if (limit > numBytes + 1) {
limit = numBytes + 1;
}
}
len = Tcl_NumUtfChars(bytes, limit);
Tcl_SetObjResult(interp, Tcl_NewIntObj(len));
}
return TCL_OK;
}
/*
* Used to check correct operation of Tcl_UtfFindFirst
*/
static int
TestFindFirstCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc > 1) {
int len = -1;
|
| ︙ | ︙ | |||
6943 6944 6945 6946 6947 6948 6949 | /* * Used to check correct operation of Tcl_UtfFindLast */ static int TestFindLastCmd( | | | 6968 6969 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 |
/*
* Used to check correct operation of Tcl_UtfFindLast
*/
static int
TestFindLastCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
if (objc > 1) {
int len = -1;
|
| ︙ | ︙ | |||
6985 6986 6987 6988 6989 6990 6991 | * None. * *---------------------------------------------------------------------- */ static int TestcpuidCmd( | | | 7010 7011 7012 7013 7014 7015 7016 7017 7018 7019 7020 7021 7022 7023 7024 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestcpuidCmd(
TCL_UNUSED(ClientData),
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];
|
| ︙ | ︙ | |||
7021 7022 7023 7024 7025 7026 7027 | /* * Used to do basic checks of the TCL_HASH_KEY_SYSTEM_HASH flag */ static int TestHashSystemHashCmd( | | | 7046 7047 7048 7049 7050 7051 7052 7053 7054 7055 7056 7057 7058 7059 7060 |
/*
* Used to do basic checks of the TCL_HASH_KEY_SYSTEM_HASH flag
*/
static int
TestHashSystemHashCmd(
TCL_UNUSED(ClientData),
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
|
| ︙ | ︙ | |||
7057 7058 7059 7060 7061 7062 7063 |
Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem",-1);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
Tcl_SetHashValue(hPtr, INT2PTR(i+42));
}
| | | 7082 7083 7084 7085 7086 7087 7088 7089 7090 7091 7092 7093 7094 7095 7096 |
Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem",-1);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
Tcl_SetHashValue(hPtr, INT2PTR(i+42));
}
if (hash.numEntries != limit) {
Tcl_AppendResult(interp, "unexpected maximal size", NULL);
Tcl_DeleteHashTable(&hash);
return TCL_ERROR;
}
for (i=0 ; i<limit ; i++) {
hPtr = Tcl_FindHashEntry(&hash, (char *) INT2PTR(i));
|
| ︙ | ︙ | |||
7097 7098 7099 7100 7101 7102 7103 | /* * Used for testing Tcl_GetInt which is no longer used directly by the * core very much. */ static int TestgetintCmd( | | | 7122 7123 7124 7125 7126 7127 7128 7129 7130 7131 7132 7133 7134 7135 7136 |
/*
* Used for testing Tcl_GetInt which is no longer used directly by the
* core very much.
*/
static int
TestgetintCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int argc,
const char **argv)
{
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
7124 7125 7126 7127 7128 7129 7130 | } /* * Used for determining sizeof(long) at script level. */ static int TestlongsizeCmd( | | | | | | | | | | | | | | | 7149 7150 7151 7152 7153 7154 7155 7156 7157 7158 7159 7160 7161 7162 7163 7164 7165 7166 7167 7168 7169 7170 7171 7172 7173 7174 7175 7176 7177 7178 7179 7180 7181 7182 7183 7184 7185 7186 7187 7188 7189 7190 7191 7192 7193 7194 7195 7196 7197 7198 7199 7200 7201 7202 7203 7204 7205 7206 7207 7208 7209 7210 7211 7212 7213 7214 7215 7216 7217 7218 7219 7220 7221 7222 7223 7224 7225 7226 |
}
/*
* Used for determining sizeof(long) at script level.
*/
static int
TestlongsizeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int argc,
TCL_UNUSED(const char **) /*argv*/)
{
if (argc != 1) {
Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj((int)sizeof(long)));
return TCL_OK;
}
static int
NREUnwind_callback(
void *data[],
Tcl_Interp *interp,
TCL_UNUSED(int) /*result*/)
{
int none;
if (data[0] == INT2PTR(-1)) {
Tcl_NRAddCallback(interp, NREUnwind_callback, &none, INT2PTR(-1),
INT2PTR(-1), NULL);
} else if (data[1] == INT2PTR(-1)) {
Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], &none,
INT2PTR(-1), NULL);
} else if (data[2] == INT2PTR(-1)) {
Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], data[1],
&none, NULL);
} else {
Tcl_Obj *idata[3];
idata[0] = Tcl_NewIntObj((int) ((char *) data[1] - (char *) data[0]));
idata[1] = Tcl_NewIntObj((int) ((char *) data[2] - (char *) data[0]));
idata[2] = Tcl_NewIntObj((int) ((char *) &none - (char *) data[0]));
Tcl_SetObjResult(interp, Tcl_NewListObj(3, idata));
}
return TCL_OK;
}
static int
TestNREUnwind(
TCL_UNUSED(ClientData),
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(ClientData),
Tcl_Interp *interp,
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *) /*objv*/)
{
Interp *iPtr = (Interp *) interp;
static ptrdiff_t *refDepth = NULL;
ptrdiff_t depth;
Tcl_Obj *levels[6];
int i = 0;
NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr;
|
| ︙ | ︙ | |||
7240 7241 7242 7243 7244 7245 7246 | * None. * *---------------------------------------------------------------------- */ static int TestconcatobjCmd( | | | | | 7265 7266 7267 7268 7269 7270 7271 7272 7273 7274 7275 7276 7277 7278 7279 7280 7281 7282 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestconcatobjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*argc*/,
TCL_UNUSED(const char **) /*argv*/)
{
Tcl_Obj *list1Ptr, *list2Ptr, *emptyPtr, *concatPtr, *tmpPtr;
int result = TCL_OK, len;
Tcl_Obj *objv[3];
/*
* Set the start of the error message as obj result; it will be cleared at
|
| ︙ | ︙ | |||
7520 7521 7522 7523 7524 7525 7526 7527 7528 7529 7530 7531 7532 7533 7534 7535 7536 7537 7538 7539 7540 7541 7542 7543 |
}
return result;
}
/*
*----------------------------------------------------------------------
*
* TestparseargsCmd --
*
* This procedure implements the "testparseargs" command. It is used to
* test that Tcl_ParseArgsObjv does indeed return the right number of
* arguments. In other words, that [Bug 3413857] was fixed properly.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparseargsCmd(
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | 7545 7546 7547 7548 7549 7550 7551 7552 7553 7554 7555 7556 7557 7558 7559 7560 7561 7562 7563 7564 7565 7566 7567 7568 7569 7570 7571 7572 7573 7574 7575 7576 7577 7578 7579 7580 7581 7582 7583 7584 7585 7586 7587 7588 7589 7590 7591 7592 7593 7594 7595 7596 7597 7598 7599 7600 7601 7602 7603 7604 7605 7606 7607 7608 7609 7610 7611 7612 7613 7614 7615 7616 7617 7618 7619 7620 7621 7622 7623 7624 7625 7626 7627 7628 7629 7630 7631 7632 7633 7634 7635 7636 7637 7638 7639 7640 7641 7642 7643 7644 7645 7646 7647 7648 7649 7650 7651 7652 7653 7654 7655 7656 7657 7658 7659 7660 7661 7662 7663 7664 7665 7666 7667 7668 7669 7670 7671 7672 7673 7674 7675 7676 |
}
return result;
}
/*
*----------------------------------------------------------------------
*
* TestgetencpathObjCmd --
*
* This function implements the "testgetencpath" command. It is used to
* test Tcl_GetEncodingSearchPath().
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestgetencpathObjCmd(
TCL_UNUSED(ClientData),
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;
}
Tcl_SetObjResult(interp, Tcl_GetEncodingSearchPath());
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestsetencpathCmd --
*
* This function implements the "testsetencpath" command. It is used to
* test Tcl_SetDefaultEncodingDir().
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestsetencpathObjCmd(
TCL_UNUSED(ClientData),
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;
}
Tcl_SetEncodingSearchPath(objv[1]);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestparseargsCmd --
*
* This procedure implements the "testparseargs" command. It is used to
* test that Tcl_ParseArgsObjv does indeed return the right number of
* arguments. In other words, that [Bug 3413857] was fixed properly.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestparseargsCmd(
TCL_UNUSED(ClientData),
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];
Tcl_ArgvInfo argTable[] = {
{TCL_ARGV_CONSTANT, "-bool", INT2PTR(1), &foo, "booltest", NULL},
TCL_ARGV_AUTO_REST, TCL_ARGV_AUTO_HELP, TCL_ARGV_TABLE_END
};
foo = 0;
if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, &remObjv)!=TCL_OK) {
return TCL_ERROR;
}
result[0] = Tcl_NewIntObj(foo);
result[1] = Tcl_NewIntObj(count);
result[2] = Tcl_NewListObj(count, remObjv);
Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
ckfree(remObjv);
return TCL_OK;
}
/**
* Test harness for command and variable resolvers.
*/
static int
InterpCmdResolver(
Tcl_Interp *interp,
const char *name,
TCL_UNUSED(Tcl_Namespace *),
TCL_UNUSED(int) /*flags*/,
Tcl_Command *rPtr)
{
Interp *iPtr = (Interp *) interp;
CallFrame *varFramePtr = iPtr->varFramePtr;
Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ?
varFramePtr->procPtr : NULL;
Namespace *callerNsPtr = varFramePtr->nsPtr;
|
| ︙ | ︙ | |||
7661 7662 7663 7664 7665 7666 7667 |
}
}
return TCL_CONTINUE;
}
static int
InterpVarResolver(
| | | | | | | | | 7752 7753 7754 7755 7756 7757 7758 7759 7760 7761 7762 7763 7764 7765 7766 7767 7768 7769 7770 7771 7772 7773 7774 7775 7776 7777 7778 7779 7780 7781 7782 7783 7784 7785 7786 7787 7788 7789 7790 7791 7792 7793 7794 7795 7796 7797 7798 7799 7800 7801 7802 7803 7804 7805 7806 |
}
}
return TCL_CONTINUE;
}
static int
InterpVarResolver(
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(const char *),
TCL_UNUSED(Tcl_Namespace *),
TCL_UNUSED(int),
TCL_UNUSED(Tcl_Var *))
{
/*
* Don't resolve the variable; use standard rules.
*/
return TCL_CONTINUE;
}
typedef struct MyResolvedVarInfo {
Tcl_ResolvedVarInfo vInfo; /* This must be the first element. */
Tcl_Var var;
Tcl_Obj *nameObj;
} MyResolvedVarInfo;
static inline void
HashVarFree(
Tcl_Var var)
{
if (VarHashRefCount(var) < 2) {
ckfree(var);
} else {
VarHashRefCount(var)--;
}
}
static void
MyCompiledVarFree(
Tcl_ResolvedVarInfo *vInfoPtr)
{
MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vInfoPtr;
Tcl_DecrRefCount(resVarInfo->nameObj);
if (resVarInfo->var) {
HashVarFree(resVarInfo->var);
}
ckfree(vInfoPtr);
}
#define TclVarHashGetValue(hPtr) \
((Var *) ((char *)hPtr - offsetof(VarInHash, entry)))
static Tcl_Var
MyCompiledVarFetch(
|
| ︙ | ︙ | |||
7744 7745 7746 7747 7748 7749 7750 |
var = (Tcl_Var) TclVarHashGetValue(hPtr);
} else {
var = NULL;
}
resVarInfo->var = var;
/*
| | | | | | | | 7835 7836 7837 7838 7839 7840 7841 7842 7843 7844 7845 7846 7847 7848 7849 7850 7851 7852 7853 7854 7855 7856 7857 7858 7859 7860 7861 7862 7863 7864 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 7875 7876 7877 7878 7879 7880 7881 |
var = (Tcl_Var) TclVarHashGetValue(hPtr);
} else {
var = NULL;
}
resVarInfo->var = var;
/*
* Increment the reference counter to avoid ckfree() of the variable in
* Tcl's FreeVarEntry(); for cleanup, we provide our own HashVarFree();
*/
VarHashRefCount(var)++;
return var;
}
static int
InterpCompiledVarResolver(
TCL_UNUSED(Tcl_Interp *),
const char *name,
TCL_UNUSED(int) /*length*/,
TCL_UNUSED(Tcl_Namespace *),
Tcl_ResolvedVarInfo **rPtr)
{
if (*name == 'T') {
MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *)ckalloc(sizeof(MyResolvedVarInfo));
resVarInfo->vInfo.fetchProc = MyCompiledVarFetch;
resVarInfo->vInfo.deleteProc = MyCompiledVarFree;
resVarInfo->var = NULL;
resVarInfo->nameObj = Tcl_NewStringObj(name, -1);
Tcl_IncrRefCount(resVarInfo->nameObj);
*rPtr = &resVarInfo->vInfo;
return TCL_OK;
}
return TCL_CONTINUE;
}
static int
TestInterpResolverCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
static const char *const table[] = {
"down", "up", NULL
};
|
| ︙ | ︙ |
Changes to generic/tclTestObj.c.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" | > | > > > > > > > > > > > | < | < < | < | < | < | | < < | < | | | | 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 |
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#ifndef USE_TCL_STUBS
# define USE_TCL_STUBS
#endif
#include "tclInt.h"
#ifdef TCL_WITH_EXTERNAL_TOMMATH
# include "tommath.h"
#else
# include "tclTomMath.h"
#endif
#include "tclStringRep.h"
#ifdef __GNUC__
/*
* The rest of this file shouldn't warn about deprecated functions; they're
* there because we intend them to be so and know that this file is OK to
* touch those fields.
*/
#pragma GCC diagnostic ignored "-Wdeprecated-declarations"
#endif
/*
* Forward declarations for functions defined later in this file:
*/
static int CheckIfVarUnset(Tcl_Interp *interp, Tcl_Obj **varPtr, int varIndex);
static int GetVariableIndex(Tcl_Interp *interp,
const char *string, int *indexPtr);
static void SetVarToObj(Tcl_Obj **varPtr, int varIndex, Tcl_Obj *objPtr);
static Tcl_ObjCmdProc TestbignumobjCmd;
static Tcl_ObjCmdProc TestbooleanobjCmd;
static Tcl_ObjCmdProc TestdoubleobjCmd;
static Tcl_ObjCmdProc TestindexobjCmd;
static Tcl_ObjCmdProc TestintobjCmd;
static Tcl_ObjCmdProc TestlistobjCmd;
static Tcl_ObjCmdProc TestobjCmd;
static Tcl_ObjCmdProc TeststringobjCmd;
#define VARPTR_KEY "TCLOBJTEST_VARPTR"
#define NUMBER_OF_OBJECT_VARS 20
static void VarPtrDeleteProc(void *clientData, Tcl_Interp *interp)
{
int i;
Tcl_Obj **varPtr = (Tcl_Obj **) clientData;
for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
if (varPtr[i]) Tcl_DecrRefCount(varPtr[i]);
}
Tcl_DeleteAssocData(interp, VARPTR_KEY);
ckfree(varPtr);
}
static Tcl_Obj **GetVarPtr(Tcl_Interp *interp)
{
Tcl_InterpDeleteProc *proc;
return (Tcl_Obj **) Tcl_GetAssocData(interp, VARPTR_KEY, &proc);
|
| ︙ | ︙ | |||
87 88 89 90 91 92 93 |
*----------------------------------------------------------------------
*/
int
TclObjTest_Init(
Tcl_Interp *interp)
{
| | | | 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 |
*----------------------------------------------------------------------
*/
int
TclObjTest_Init(
Tcl_Interp *interp)
{
int i;
/*
* An array of Tcl_Obj pointers used in the commands that operate on or get
* the values of Tcl object-valued variables. varPtr[i] is the i-th variable's
* Tcl_Obj *.
*/
Tcl_Obj **varPtr;
varPtr = (Tcl_Obj **) ckalloc(NUMBER_OF_OBJECT_VARS *sizeof(varPtr[0]));
if (!varPtr) {
return TCL_ERROR;
}
Tcl_SetAssocData(interp, VARPTR_KEY, VarPtrDeleteProc, varPtr);
for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
varPtr[i] = NULL;
}
|
| ︙ | ︙ | |||
127 128 129 130 131 132 133 | } /* *---------------------------------------------------------------------- * * TestbignumobjCmd -- * | | | | | 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 |
}
/*
*----------------------------------------------------------------------
*
* TestbignumobjCmd --
*
* This function implements the "testbignumobj" command. It is used
* to exercise the bignum Tcl object type implementation.
*
* Results:
* Returns a standard Tcl object result.
*
* Side effects:
* Creates and frees bignum objects; converts objects to have bignum
* type.
*
*----------------------------------------------------------------------
*/
static int
TestbignumobjCmd(
TCL_UNUSED(ClientData),
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
};
enum options {
BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10, BIGNUM_ISEVEN,
BIGNUM_RADIXSIZE
};
int index, varIndex;
const char *string;
mp_int bignumValue;
Tcl_Obj **varPtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0,
|
| ︙ | ︙ | |||
229 230 231 232 233 234 235 |
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
&bignumValue) != TCL_OK) {
return TCL_ERROR;
}
| < | < < | | < | < < | | > > > > > > | | | 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 |
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
&bignumValue) != TCL_OK) {
return TCL_ERROR;
}
if (mp_mul_d(&bignumValue, 10, &bignumValue) != MP_OKAY) {
mp_clear(&bignumValue);
Tcl_SetObjResult(interp,
Tcl_NewStringObj("error in mp_mul_d", -1));
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetBignumObj(varPtr[varIndex], &bignumValue);
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&bignumValue));
}
break;
case BIGNUM_DIV10:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
&bignumValue) != TCL_OK) {
return TCL_ERROR;
}
if (mp_div_d(&bignumValue, 10, &bignumValue, NULL) != MP_OKAY) {
mp_clear(&bignumValue);
Tcl_SetObjResult(interp,
Tcl_NewStringObj("error in mp_div_d", -1));
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetBignumObj(varPtr[varIndex], &bignumValue);
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&bignumValue));
}
break;
case BIGNUM_ISEVEN:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
&bignumValue) != TCL_OK) {
return TCL_ERROR;
}
if (mp_mod_2d(&bignumValue, 1, &bignumValue) != MP_OKAY) {
mp_clear(&bignumValue);
Tcl_SetObjResult(interp,
Tcl_NewStringObj("error in mp_mod_2d", -1));
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], mp_iszero(&bignumValue));
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(mp_iszero(&bignumValue)));
}
mp_clear(&bignumValue);
break;
case BIGNUM_RADIXSIZE:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
|
| ︙ | ︙ | |||
341 342 343 344 345 346 347 | * 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(ClientData),
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;
|
| ︙ | ︙ | |||
441 442 443 444 445 446 447 | * 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(ClientData),
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;
|
| ︙ | ︙ | |||
559 560 561 562 563 564 565 | * have int type. * *---------------------------------------------------------------------- */ static int TestindexobjCmd( | | > | | | | 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 |
* have int type.
*
*----------------------------------------------------------------------
*/
static int
TestindexobjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int allowAbbrev, index, index2, setError, i, result;
const char **argv;
static const char *const tablePtr[] = {"a", "b", "check", NULL};
/*
* Keep this structure declaration in sync with tclIndexObj.c
*/
struct IndexRep {
void *tablePtr; /* Pointer to the table of strings. */
int offset; /* Offset between table entries. */
int index; /* Selected index into table. */
};
struct IndexRep *indexRep;
if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]),
"check") == 0)) {
/*
* This code checks to be sure that the results of Tcl_GetIndexFromObj
* are properly cached in the object and returned on subsequent
* lookups.
*/
if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) {
return TCL_ERROR;
}
Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index);
indexRep = (struct IndexRep *)objv[1]->internalRep.twoPtrValue.ptr1;
indexRep->index = index2;
result = Tcl_GetIndexFromObj(NULL, objv[1],
tablePtr, "token", 0, &index);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
}
return result;
|
| ︙ | ︙ | |||
612 613 614 615 616 617 618 |
if (Tcl_GetBooleanFromObj(interp, objv[1], &setError) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) {
return TCL_ERROR;
}
| | | | 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 |
if (Tcl_GetBooleanFromObj(interp, objv[1], &setError) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) {
return TCL_ERROR;
}
argv = (const char **)ckalloc((objc-3) * sizeof(char *));
for (i = 4; i < objc; i++) {
argv[i-4] = Tcl_GetString(objv[i]);
}
argv[objc-4] = NULL;
result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],
argv, "token", INDEX_TEMP_TABLE|(allowAbbrev? 0 : TCL_EXACT),
&index);
ckfree(argv);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
}
return result;
}
/*
|
| ︙ | ︙ | |||
648 649 650 651 652 653 654 | * 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(ClientData),
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;
|
| ︙ | ︙ | |||
852 853 854 855 856 857 858 | * 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(ClientData),
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",
|
| ︙ | ︙ | |||
949 950 951 952 953 954 955 | * 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(ClientData),
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;
|
| ︙ | ︙ | |||
1161 1162 1163 1164 1165 1166 1167 | * have string type. * *---------------------------------------------------------------------- */ static int TeststringobjCmd( | | | | | 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 |
* have string type.
*
*----------------------------------------------------------------------
*/
static int
TeststringobjCmd(
TCL_UNUSED(ClientData),
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
const char *index, *string, *strings[MAX_STRINGS+1];
String *strPtr;
Tcl_Obj **varPtr;
static const char *const options[] = {
"append", "appendstrings", "get", "get2", "length", "length2",
"set", "set2", "setlength", "maxchars", "appendself",
"appendself2", NULL
};
if (objc < 3) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1269 1270 1271 1272 1273 1274 1275 |
string = Tcl_GetString(varPtr[varIndex]);
Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
break;
case 4: /* length */
if (objc != 3) {
goto wrongNumArgs;
}
| | | | | 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 |
string = Tcl_GetString(varPtr[varIndex]);
Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
break;
case 4: /* length */
if (objc != 3) {
goto wrongNumArgs;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
? varPtr[varIndex]->length : -1);
break;
case 5: /* length2 */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
length = (int) strPtr->allocated;
} else {
length = -1;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
break;
case 6: /* set */
|
| ︙ | ︙ | |||
1333 1334 1335 1336 1337 1338 1339 |
case 9: /* maxchars */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
| | | < < < < < < | 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 |
case 9: /* maxchars */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1;
length = strPtr->maxChars;
} else {
length = -1;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
break;
case 10: /* appendself */
if (objc != 4) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varPtr, varIndex, Tcl_NewObj());
}
|
| ︙ | ︙ | |||
1377 1378 1379 1380 1381 1382 1383 | "index value out of range", -1)); return TCL_ERROR; } Tcl_AppendToObj(varPtr[varIndex], string + i, length - i); Tcl_SetObjResult(interp, varPtr[varIndex]); break; | | | 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 |
"index value out of range", -1));
return TCL_ERROR;
}
Tcl_AppendToObj(varPtr[varIndex], string + i, length - i);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 11: /* appendself2 */
if (objc != 4) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varPtr, varIndex, Tcl_NewObj());
}
|
| ︙ | ︙ |
Changes to generic/tclTestProcBodyObj.c.
| ︙ | ︙ | |||
31 32 33 34 35 36 37 | static const char checkCommand[] = "check"; /* * this struct describes an entry in the table of command names and command * procs */ | | | | | | 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 |
static const char checkCommand[] = "check";
/*
* this struct describes an entry in the table of command names and command
* procs
*/
typedef struct CmdTable {
const char *cmdName; /* command name */
Tcl_ObjCmdProc *proc; /* command proc */
int exportIt; /* if 1, export the command */
} CmdTable;
/*
* Declarations for functions defined in this file.
*/
static int ProcBodyTestProcObjCmd(void *dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int ProcBodyTestCheckObjCmd(void *dummy,
Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
static int ProcBodyTestInitInternal(Tcl_Interp *interp, int isSafe);
static int RegisterCommand(Tcl_Interp* interp,
const char *namesp, const CmdTable *cmdTablePtr);
/*
* List of commands to create when the package is loaded; must go after the
* declarations of the enable command procedure.
*/
static const CmdTable commands[] = {
|
| ︙ | ︙ | |||
135 136 137 138 139 140 141 |
*----------------------------------------------------------------------
*/
static int
RegisterCommand(
Tcl_Interp* interp, /* the Tcl interpreter for which the operation
* is performed */
| | | | | 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 |
*----------------------------------------------------------------------
*/
static int
RegisterCommand(
Tcl_Interp* interp, /* the Tcl interpreter for which the operation
* is performed */
const char *namesp, /* the namespace in which the command is
* registered */
const CmdTable *cmdTablePtr)/* the command to register */
{
char buf[128];
if (cmdTablePtr->exportIt) {
sprintf(buf, "namespace eval %s { namespace export %s }",
namesp, cmdTablePtr->cmdName);
if (Tcl_EvalEx(interp, buf, -1, 0) != TCL_OK) {
return TCL_ERROR;
}
}
sprintf(buf, "%s::%s", namesp, cmdTablePtr->cmdName);
Tcl_CreateObjCommand(interp, buf, cmdTablePtr->proc, 0, 0);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
186 187 188 189 190 191 192 |
cmdTablePtr = (isSafe) ? &safeCommands[0] : &commands[0];
for ( ; cmdTablePtr->cmdName ; cmdTablePtr++) {
if (RegisterCommand(interp, packageName, cmdTablePtr) != TCL_OK) {
return TCL_ERROR;
}
}
| | | 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 |
cmdTablePtr = (isSafe) ? &safeCommands[0] : &commands[0];
for ( ; cmdTablePtr->cmdName ; cmdTablePtr++) {
if (RegisterCommand(interp, packageName, cmdTablePtr) != TCL_OK) {
return TCL_ERROR;
}
}
return Tcl_PkgProvide(interp, packageName, packageVersion);
}
/*
*----------------------------------------------------------------------
*
* ProcBodyTestProcObjCmd --
*
|
| ︙ | ︙ | |||
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(ClientData),
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 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 |
* Returns a standard Tcl code.
*
*----------------------------------------------------------------------
*/
static int
ProcBodyTestCheckObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* the current interpreter */
int objc, /* argument count */
Tcl_Obj *const objv[]) /* arguments */
{
const char *version;
if (objc != 1) {
Tcl_WrongNumArgs(interp, 1, objv, "");
return TCL_ERROR;
}
version = Tcl_PkgPresent(interp, packageName, packageVersion, 1);
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
strcmp(version, packageVersion) == 0));
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclThread.c.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
*
*----------------------------------------------------------------------
*/
void *
Tcl_GetThreadData(
Tcl_ThreadDataKey *keyPtr, /* Identifier for the data chunk */
| | | | | 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 |
*
*----------------------------------------------------------------------
*/
void *
Tcl_GetThreadData(
Tcl_ThreadDataKey *keyPtr, /* Identifier for the data chunk */
int size) /* Size of storage block */
{
void *result;
#if TCL_THREADS
/*
* Initialize the key for this thread.
*/
result = TclThreadStorageKeyGet(keyPtr);
if (result == NULL) {
result = ckalloc(size);
memset(result, 0, size);
TclThreadStorageKeySet(keyPtr, result);
}
#else /* TCL_THREADS */
if (*keyPtr == NULL) {
result = ckalloc(size);
memset(result, 0, size);
*keyPtr = result;
RememberSyncObject(keyPtr, &keyRecord);
} else {
result = *keyPtr;
}
#endif /* TCL_THREADS */
|
| ︙ | ︙ | |||
160 161 162 163 164 165 166 |
/*
* Grow the list of pointers if necessary, copying only non-NULL
* pointers to the new list.
*/
if (recPtr->num >= recPtr->max) {
recPtr->max += 8;
| | | | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 |
/*
* Grow the list of pointers if necessary, copying only non-NULL
* pointers to the new list.
*/
if (recPtr->num >= recPtr->max) {
recPtr->max += 8;
newList = (void **)ckalloc(recPtr->max * sizeof(void *));
for (i=0,j=0 ; i<recPtr->num ; i++) {
if (recPtr->list[i] != NULL) {
newList[j++] = recPtr->list[i];
}
}
if (recPtr->list != NULL) {
ckfree(recPtr->list);
}
recPtr->list = newList;
recPtr->num = j;
}
recPtr->list[recPtr->num] = objPtr;
recPtr->num++;
|
| ︙ | ︙ | |||
346 347 348 349 350 351 352 353 354 355 356 357 358 359 |
#if TCL_THREADS && defined(USE_THREAD_ALLOC)
if (!quick) {
/*
* Quick exit principle makes it useless to terminate allocators
*/
TclFinalizeThreadAllocThread();
}
#endif
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeSynchronization --
| > > | 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 |
#if TCL_THREADS && defined(USE_THREAD_ALLOC)
if (!quick) {
/*
* Quick exit principle makes it useless to terminate allocators
*/
TclFinalizeThreadAllocThread();
}
#else
(void)quick;
#endif
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeSynchronization --
|
| ︙ | ︙ | |||
388 389 390 391 392 393 394 |
* their thread data keys. Free them here.
*/
if (keyRecord.list != NULL) {
for (i=0 ; i<keyRecord.num ; i++) {
keyPtr = (Tcl_ThreadDataKey *) keyRecord.list[i];
blockPtr = *keyPtr;
| | | | | | 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 |
* their thread data keys. Free them here.
*/
if (keyRecord.list != NULL) {
for (i=0 ; i<keyRecord.num ; i++) {
keyPtr = (Tcl_ThreadDataKey *) keyRecord.list[i];
blockPtr = *keyPtr;
ckfree(blockPtr);
}
ckfree(keyRecord.list);
keyRecord.list = NULL;
}
keyRecord.max = 0;
keyRecord.num = 0;
#if TCL_THREADS
/*
* Call thread storage master cleanup.
*/
TclFinalizeThreadStorage();
for (i=0 ; i<mutexRecord.num ; i++) {
mutexPtr = (Tcl_Mutex *)mutexRecord.list[i];
if (mutexPtr != NULL) {
TclpFinalizeMutex(mutexPtr);
}
}
if (mutexRecord.list != NULL) {
ckfree(mutexRecord.list);
mutexRecord.list = NULL;
}
mutexRecord.max = 0;
mutexRecord.num = 0;
for (i=0 ; i<condRecord.num ; i++) {
condPtr = (Tcl_Condition *) condRecord.list[i];
if (condPtr != NULL) {
TclpFinalizeCondition(condPtr);
}
}
if (condRecord.list != NULL) {
ckfree(condRecord.list);
condRecord.list = NULL;
}
condRecord.max = 0;
condRecord.num = 0;
TclpMasterUnlock();
#endif /* TCL_THREADS */
|
| ︙ | ︙ |
Changes to generic/tclThreadAlloc.c.
| ︙ | ︙ | |||
78 79 80 81 82 83 84 | #define MAXALLOC (MINALLOC << (NBUCKETS - 1)) /* * The following structure defines a bucket of blocks with various accounting * and statistics information. */ | | | | | | | | | 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 |
#define MAXALLOC (MINALLOC << (NBUCKETS - 1))
/*
* The following structure defines a bucket of blocks with various accounting
* and statistics information.
*/
typedef struct Bucket {
Block *firstPtr; /* First block available */
Block *lastPtr; /* End of block list */
long numFree; /* Number of blocks available */
/* All fields below for accounting only */
long numRemoves; /* Number of removes from bucket */
long numInserts; /* Number of inserts into bucket */
long numWaits; /* Number of waits to acquire a lock */
long numLocks; /* Number of locks acquired */
long totalAssigned; /* Total space assigned to bucket */
} Bucket;
/*
* The following structure defines a cache of buckets and objs, of which there
* will be (at most) one per thread. Any changes need to be reflected in the
* struct AllocCache defined in tclInt.h, possibly also in the initialisation
* code in Tcl_CreateInterp().
|
| ︙ | ︙ | |||
116 117 118 119 120 121 122 |
/*
* The following array specifies various per-bucket limits and locks. The
* values are statically initialized to avoid calculating them repeatedly.
*/
static struct {
size_t blockSize; /* Bucket blocksize. */
| | | | | | 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 |
/*
* The following array specifies various per-bucket limits and locks. The
* values are statically initialized to avoid calculating them repeatedly.
*/
static struct {
size_t blockSize; /* Bucket blocksize. */
int maxBlocks; /* Max blocks before move to share. */
int numMove; /* Num blocks to move to share. */
Tcl_Mutex *lockPtr; /* Share bucket lock. */
} bucketInfo[NBUCKETS];
/*
* Static functions defined in this file.
*/
static Cache * GetCache(void);
static void LockBucket(Cache *cachePtr, int bucket);
static void UnlockBucket(Cache *cachePtr, int bucket);
static void PutBlocks(Cache *cachePtr, int bucket, int numMove);
static int GetBlocks(Cache *cachePtr, int bucket);
static Block * Ptr2Block(void *ptr);
static void * Block2Ptr(Block *blockPtr, int bucket, unsigned int reqSize);
static void MoveObjs(Cache *fromPtr, Cache *toPtr, int numMove);
static void PutObjs(Cache *fromPtr, int numMove);
/*
* Local variables defined in this file and initialized at startup.
*/
|
| ︙ | ︙ | |||
158 159 160 161 162 163 164 |
tcachePtr = GetCache(); \
} \
(cachePtr) = tcachePtr; \
} while (0)
#else
# define GETCACHE(cachePtr) \
do { \
| | | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 |
tcachePtr = GetCache(); \
} \
(cachePtr) = tcachePtr; \
} while (0)
#else
# define GETCACHE(cachePtr) \
do { \
(cachePtr) = (Cache*)TclpGetAllocCache(); \
if ((cachePtr) == NULL) { \
(cachePtr) = GetCache(); \
} \
} while (0)
#endif
/*
|
| ︙ | ︙ | |||
205 206 207 208 209 210 211 |
Tcl_MutexUnlock(initLockPtr);
}
/*
* Get this thread's cache, allocating if necessary.
*/
| | | | 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 |
Tcl_MutexUnlock(initLockPtr);
}
/*
* Get this thread's cache, allocating if necessary.
*/
cachePtr = (Cache*)TclpGetAllocCache();
if (cachePtr == NULL) {
cachePtr = (Cache*)TclpSysAlloc(sizeof(Cache), 0);
if (cachePtr == NULL) {
Tcl_Panic("alloc: could not allocate new cache");
}
memset(cachePtr, 0, sizeof(Cache));
Tcl_MutexLock(listLockPtr);
cachePtr->nextPtr = firstCachePtr;
firstCachePtr = cachePtr;
|
| ︙ | ︙ | |||
242 243 244 245 246 247 248 |
*----------------------------------------------------------------------
*/
void
TclFreeAllocCache(
void *arg)
{
| | | | 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 |
*----------------------------------------------------------------------
*/
void
TclFreeAllocCache(
void *arg)
{
Cache *cachePtr = (Cache*)arg;
Cache **nextPtrPtr;
unsigned int bucket;
/*
* Flush blocks.
*/
for (bucket = 0; bucket < NBUCKETS; ++bucket) {
if (cachePtr->buckets[bucket].numFree > 0) {
|
| ︙ | ︙ | |||
297 298 299 300 301 302 303 | * May allocate more blocks for a bucket. * *---------------------------------------------------------------------- */ void * TclpAlloc( | | | > > > > > > > > > > > > > | | 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 |
* May allocate more blocks for a bucket.
*
*----------------------------------------------------------------------
*/
void *
TclpAlloc(
unsigned int reqSize)
{
Cache *cachePtr;
Block *blockPtr;
int bucket;
size_t size;
#ifndef __LP64__
if (sizeof(int) >= sizeof(size_t)) {
/* An unsigned int overflow can also be a size_t overflow */
const size_t zero = 0;
const size_t max = ~zero;
if (((size_t) reqSize) > max - sizeof(Block) - RCHECK) {
/* Requested allocation exceeds memory */
return NULL;
}
}
#endif
GETCACHE(cachePtr);
/*
* Increment the requested size to include room for the Block structure.
* Call TclpSysAlloc() directly if the required amount is greater than the
* largest block, otherwise pop the smallest block large enough,
* allocating more blocks if necessary.
*/
blockPtr = NULL;
size = reqSize + sizeof(Block);
#if RCHECK
size++;
#endif
if (size > MAXALLOC) {
bucket = NBUCKETS;
blockPtr = (Block *)TclpSysAlloc(size, 0);
if (blockPtr != NULL) {
cachePtr->totalAssigned += reqSize;
}
} else {
bucket = 0;
while (bucketInfo[bucket].blockSize < size) {
bucket++;
|
| ︙ | ︙ | |||
421 422 423 424 425 426 427 |
*
*----------------------------------------------------------------------
*/
void *
TclpRealloc(
void *ptr,
| | > > > > > > > > > > > > > | 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 |
*
*----------------------------------------------------------------------
*/
void *
TclpRealloc(
void *ptr,
unsigned int reqSize)
{
Cache *cachePtr;
Block *blockPtr;
void *newPtr;
size_t size, min;
int bucket;
if (ptr == NULL) {
return TclpAlloc(reqSize);
}
#ifndef __LP64__
if (sizeof(int) >= sizeof(size_t)) {
/* An unsigned int overflow can also be a size_t overflow */
const size_t zero = 0;
const size_t max = ~zero;
if (((size_t) reqSize) > max - sizeof(Block) - RCHECK) {
/* Requested allocation exceeds memory */
return NULL;
}
}
#endif
GETCACHE(cachePtr);
/*
* If the block is not a system block and fits in place, simply return the
* existing pointer. Otherwise, if the block is a system block and the new
* size would also require a system block, call TclpSysRealloc() directly.
|
| ︙ | ︙ | |||
461 462 463 464 465 466 467 |
cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize;
cachePtr->buckets[bucket].totalAssigned += reqSize;
return Block2Ptr(blockPtr, bucket, reqSize);
}
} else if (size > MAXALLOC) {
cachePtr->totalAssigned -= blockPtr->blockReqSize;
cachePtr->totalAssigned += reqSize;
| | | 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 |
cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize;
cachePtr->buckets[bucket].totalAssigned += reqSize;
return Block2Ptr(blockPtr, bucket, reqSize);
}
} else if (size > MAXALLOC) {
cachePtr->totalAssigned -= blockPtr->blockReqSize;
cachePtr->totalAssigned += reqSize;
blockPtr = (Block*)TclpSysRealloc(blockPtr, size);
if (blockPtr == NULL) {
return NULL;
}
return Block2Ptr(blockPtr, NBUCKETS, reqSize);
}
/*
|
| ︙ | ︙ | |||
507 508 509 510 511 512 513 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclThreadAllocObj(void)
{
| | | | | | | 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 |
*
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclThreadAllocObj(void)
{
Cache *cachePtr;
Tcl_Obj *objPtr;
GETCACHE(cachePtr);
/*
* Get this thread's obj list structure and move or allocate new objs if
* necessary.
*/
if (cachePtr->numObjects == 0) {
int numMove;
Tcl_MutexLock(objLockPtr);
numMove = sharedPtr->numObjects;
if (numMove > 0) {
if (numMove > NOBJALLOC) {
numMove = NOBJALLOC;
}
MoveObjs(sharedPtr, cachePtr, numMove);
}
Tcl_MutexUnlock(objLockPtr);
if (cachePtr->numObjects == 0) {
Tcl_Obj *newObjsPtr;
cachePtr->numObjects = numMove = NOBJALLOC;
newObjsPtr = (Tcl_Obj *)TclpSysAlloc(sizeof(Tcl_Obj) * numMove, 0);
if (newObjsPtr == NULL) {
Tcl_Panic("alloc: could not allocate %d new objects", numMove);
}
cachePtr->lastPtr = newObjsPtr + numMove - 1;
objPtr = cachePtr->firstObjPtr; /* NULL */
while (--numMove >= 0) {
newObjsPtr[numMove].internalRep.twoPtrValue.ptr1 = objPtr;
objPtr = newObjsPtr + numMove;
}
cachePtr->firstObjPtr = newObjsPtr;
}
}
/*
* Pop the first object.
*/
objPtr = cachePtr->firstObjPtr;
cachePtr->firstObjPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1;
cachePtr->numObjects--;
return objPtr;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
641 642 643 644 645 646 647 |
if (cachePtr == sharedPtr) {
Tcl_DStringAppendElement(dsPtr, "shared");
} else {
sprintf(buf, "thread%p", cachePtr->owner);
Tcl_DStringAppendElement(dsPtr, buf);
}
for (n = 0; n < NBUCKETS; ++n) {
| | | | 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 |
if (cachePtr == sharedPtr) {
Tcl_DStringAppendElement(dsPtr, "shared");
} else {
sprintf(buf, "thread%p", cachePtr->owner);
Tcl_DStringAppendElement(dsPtr, buf);
}
for (n = 0; n < NBUCKETS; ++n) {
sprintf(buf, "%lu %ld %ld %ld %ld %ld %ld",
(unsigned long) bucketInfo[n].blockSize,
cachePtr->buckets[n].numFree,
cachePtr->buckets[n].numRemoves,
cachePtr->buckets[n].numInserts,
cachePtr->buckets[n].totalAssigned,
cachePtr->buckets[n].numLocks,
cachePtr->buckets[n].numWaits);
Tcl_DStringAppendElement(dsPtr, buf);
|
| ︙ | ︙ | |||
679 680 681 682 683 684 685 |
static void
MoveObjs(
Cache *fromPtr,
Cache *toPtr,
int numMove)
{
| | | | | 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 |
static void
MoveObjs(
Cache *fromPtr,
Cache *toPtr,
int numMove)
{
Tcl_Obj *objPtr = fromPtr->firstObjPtr;
Tcl_Obj *fromFirstObjPtr = objPtr;
toPtr->numObjects += numMove;
fromPtr->numObjects -= numMove;
/*
* Find the last object to be moved; set the next one (the first one not
* to be moved) as the first object in the 'from' cache.
*/
while (--numMove) {
objPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1;
}
fromPtr->firstObjPtr = (Tcl_Obj *)objPtr->internalRep.twoPtrValue.ptr1;
/*
* Move all objects as a block - they are already linked to each other, we
* just have to update the first and last.
*/
toPtr->lastPtr = objPtr;
|
| ︙ | ︙ | |||
736 737 738 739 740 741 742 |
fromPtr->numObjects = keep;
firstPtr = fromPtr->firstObjPtr;
if (keep == 0) {
fromPtr->firstObjPtr = NULL;
} else {
do {
lastPtr = firstPtr;
| | | 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 |
fromPtr->numObjects = keep;
firstPtr = fromPtr->firstObjPtr;
if (keep == 0) {
fromPtr->firstObjPtr = NULL;
} else {
do {
lastPtr = firstPtr;
firstPtr = (Tcl_Obj *)firstPtr->internalRep.twoPtrValue.ptr1;
} while (--keep > 0);
lastPtr->internalRep.twoPtrValue.ptr1 = NULL;
}
/*
* Move all objects as a block - they are already linked to each other, we
* just have to update the first and last.
|
| ︙ | ︙ | |||
774 775 776 777 778 779 780 | * * Side effects: * Invalid blocks will abort the server. * *---------------------------------------------------------------------- */ | | | | | | | 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 |
*
* Side effects:
* Invalid blocks will abort the server.
*
*----------------------------------------------------------------------
*/
static void *
Block2Ptr(
Block *blockPtr,
int bucket,
unsigned int reqSize)
{
void *ptr;
blockPtr->magicNum1 = blockPtr->magicNum2 = MAGIC;
blockPtr->sourceBucket = bucket;
blockPtr->blockReqSize = reqSize;
ptr = ((void *) (blockPtr + 1));
#if RCHECK
((unsigned char *)(ptr))[reqSize] = MAGIC;
#endif
return ptr;
}
static Block *
Ptr2Block(
void *ptr)
{
Block *blockPtr;
blockPtr = (((Block *) ptr) - 1);
if (blockPtr->magicNum1 != MAGIC || blockPtr->magicNum2 != MAGIC) {
Tcl_Panic("alloc: invalid block: %p: %x %x",
blockPtr, blockPtr->magicNum1, blockPtr->magicNum2);
}
#if RCHECK
|
| ︙ | ︙ | |||
842 843 844 845 846 847 848 |
Tcl_MutexLock(bucketInfo[bucket].lockPtr);
cachePtr->buckets[bucket].numLocks++;
sharedPtr->buckets[bucket].numLocks++;
}
static void
UnlockBucket(
| | | 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 |
Tcl_MutexLock(bucketInfo[bucket].lockPtr);
cachePtr->buckets[bucket].numLocks++;
sharedPtr->buckets[bucket].numLocks++;
}
static void
UnlockBucket(
TCL_UNUSED(Cache *),
int bucket)
{
Tcl_MutexUnlock(bucketInfo[bucket].lockPtr);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
930 931 932 933 934 935 936 |
*/
static int
GetBlocks(
Cache *cachePtr,
int bucket)
{
| | | | 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 |
*/
static int
GetBlocks(
Cache *cachePtr,
int bucket)
{
Block *blockPtr;
int n;
/*
* First, atttempt to move blocks from the shared cache. Note the
* potentially dirty read of numFree before acquiring the lock which is a
* slight performance enhancement. The value is verified after the lock is
* actually acquired.
*/
|
| ︙ | ︙ | |||
976 977 978 979 980 981 982 |
blockPtr->nextBlock = NULL;
}
}
UnlockBucket(cachePtr, bucket);
}
if (cachePtr->buckets[bucket].numFree == 0) {
| | | | | | 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 |
blockPtr->nextBlock = NULL;
}
}
UnlockBucket(cachePtr, bucket);
}
if (cachePtr->buckets[bucket].numFree == 0) {
size_t size;
/*
* If no blocks could be moved from shared, first look for a larger
* block in this cache to split up.
*/
blockPtr = NULL;
n = NBUCKETS;
size = 0;
while (--n > bucket) {
if (cachePtr->buckets[n].numFree > 0) {
size = bucketInfo[n].blockSize;
blockPtr = cachePtr->buckets[n].firstPtr;
cachePtr->buckets[n].firstPtr = blockPtr->nextBlock;
cachePtr->buckets[n].numFree--;
break;
}
}
/*
* Otherwise, allocate a big new block directly.
*/
if (blockPtr == NULL) {
size = MAXALLOC;
blockPtr = (Block*)TclpSysAlloc(size, 0);
if (blockPtr == NULL) {
return 0;
}
}
/*
* Split the larger block into smaller blocks for this bucket.
|
| ︙ | ︙ | |||
1032 1033 1034 1035 1036 1037 1038 | /* *---------------------------------------------------------------------- * * TclInitThreadAlloc -- * * Initializes the allocator cache-maintenance structures. | | | | 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 |
/*
*----------------------------------------------------------------------
*
* TclInitThreadAlloc --
*
* Initializes the allocator cache-maintenance structures.
* It is done early and protected during the Tcl_InitSubsystems().
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclInitThreadAlloc(void)
{
unsigned int i;
listLockPtr = TclpNewAllocMutex();
objLockPtr = TclpNewAllocMutex();
for (i = 0; i < NBUCKETS; ++i) {
bucketInfo[i].blockSize = MINALLOC << i;
bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i);
bucketInfo[i].numMove = i < NBUCKETS - 1 ?
1 << (NBUCKETS - 2 - i) : 1;
bucketInfo[i].lockPtr = TclpNewAllocMutex();
}
TclpInitAllocCache();
}
|
| ︙ | ︙ | |||
1117 1118 1119 1120 1121 1122 1123 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadAllocThread(void)
{
| | | 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadAllocThread(void)
{
Cache *cachePtr = (Cache *)TclpGetAllocCache();
if (cachePtr != NULL) {
TclpFreeAllocCache(cachePtr);
}
}
#else /* !(TCL_THREADS && USE_THREAD_ALLOC) */
/*
|
| ︙ | ︙ | |||
1142 1143 1144 1145 1146 1147 1148 | * List appended to given dstring. * *---------------------------------------------------------------------- */ void Tcl_GetMemoryInfo( | | | 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 |
* List appended to given dstring.
*
*----------------------------------------------------------------------
*/
void
Tcl_GetMemoryInfo(
TCL_UNUSED(Tcl_DString *))
{
Tcl_Panic("Tcl_GetMemoryInfo called when threaded memory allocator not in use");
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ |
Changes to generic/tclThreadJoin.c.
| ︙ | ︙ | |||
197 198 199 200 201 202 203 |
* the structure and return.
*/
*result = threadPtr->result;
Tcl_ConditionFinalize(&threadPtr->cond);
Tcl_MutexFinalize(&threadPtr->threadMutex);
| | | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 |
* the structure and return.
*/
*result = threadPtr->result;
Tcl_ConditionFinalize(&threadPtr->cond);
Tcl_MutexFinalize(&threadPtr->threadMutex);
ckfree(threadPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
226 227 228 229 230 231 232 |
void
TclRememberJoinableThread(
Tcl_ThreadId id) /* The thread to remember as joinable */
{
JoinableThread *threadPtr;
| | | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 |
void
TclRememberJoinableThread(
Tcl_ThreadId id) /* The thread to remember as joinable */
{
JoinableThread *threadPtr;
threadPtr = (JoinableThread *)ckalloc(sizeof(JoinableThread));
threadPtr->id = id;
threadPtr->done = 0;
threadPtr->waitedUpon = 0;
threadPtr->threadMutex = (Tcl_Mutex) NULL;
threadPtr->cond = (Tcl_Condition) NULL;
Tcl_MutexLock(&joinMutex);
|
| ︙ | ︙ |
Changes to generic/tclThreadStorage.c.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 |
* which holds per-process data. */
} tsdMaster = { NULL, 0, NULL };
/*
* The type of the data held per thread in a system TSD.
*/
| | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 |
* which holds per-process data. */
} tsdMaster = { NULL, 0, NULL };
/*
* The type of the data held per thread in a system TSD.
*/
typedef struct TSDTable {
ClientData *tablePtr; /* The table of Tcl TSDs. */
sig_atomic_t allocated; /* The size of the table in the current
* thread. */
} TSDTable;
/*
* The actual type of Tcl_ThreadDataKey.
|
| ︙ | ︙ | |||
81 82 83 84 85 86 87 |
static TSDTable *
TSDTableCreate(void)
{
TSDTable *tsdTablePtr;
sig_atomic_t i;
| | | | 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 |
static TSDTable *
TSDTableCreate(void)
{
TSDTable *tsdTablePtr;
sig_atomic_t i;
tsdTablePtr = (TSDTable *)TclpSysAlloc(sizeof(TSDTable), 0);
if (tsdTablePtr == NULL) {
Tcl_Panic("unable to allocate TSDTable");
}
tsdTablePtr->allocated = 8;
tsdTablePtr->tablePtr =
(void **)TclpSysAlloc(sizeof(void *) * tsdTablePtr->allocated, 0);
if (tsdTablePtr->tablePtr == NULL) {
Tcl_Panic("unable to allocate TSDTable");
}
for (i = 0; i < tsdTablePtr->allocated; ++i) {
tsdTablePtr->tablePtr[i] = NULL;
}
|
| ︙ | ︙ | |||
113 114 115 116 117 118 119 |
for (i=0 ; i<tsdTablePtr->allocated ; i++) {
if (tsdTablePtr->tablePtr[i] != NULL) {
/*
* These values were allocated in Tcl_GetThreadData in tclThread.c
* and must now be deallocated or they will leak.
*/
| | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
for (i=0 ; i<tsdTablePtr->allocated ; i++) {
if (tsdTablePtr->tablePtr[i] != NULL) {
/*
* These values were allocated in Tcl_GetThreadData in tclThread.c
* and must now be deallocated or they will leak.
*/
ckfree(tsdTablePtr->tablePtr[i]);
}
}
TclpSysFree(tsdTablePtr->tablePtr);
TclpSysFree(tsdTablePtr);
}
|
| ︙ | ︙ | |||
144 145 146 147 148 149 150 |
static void
TSDTableGrow(
TSDTable *tsdTablePtr,
sig_atomic_t atLeast)
{
sig_atomic_t newAllocated = tsdTablePtr->allocated * 2;
| | | | | 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 |
static void
TSDTableGrow(
TSDTable *tsdTablePtr,
sig_atomic_t atLeast)
{
sig_atomic_t newAllocated = tsdTablePtr->allocated * 2;
void **newTablePtr;
sig_atomic_t i;
if (newAllocated <= atLeast) {
newAllocated = atLeast + 10;
}
newTablePtr = (void **)TclpSysRealloc(tsdTablePtr->tablePtr,
sizeof(void *) * newAllocated);
if (newTablePtr == NULL) {
Tcl_Panic("unable to reallocate TSDTable");
}
for (i = tsdTablePtr->allocated; i < newAllocated; ++i) {
newTablePtr[i] = NULL;
}
|
| ︙ | ︙ | |||
185 186 187 188 189 190 191 |
*----------------------------------------------------------------------
*/
void *
TclThreadStorageKeyGet(
Tcl_ThreadDataKey *dataKeyPtr)
{
| | | 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 |
*----------------------------------------------------------------------
*/
void *
TclThreadStorageKeyGet(
Tcl_ThreadDataKey *dataKeyPtr)
{
TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetMasterTSD(tsdMaster.key);
ClientData resultPtr = NULL;
TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;
sig_atomic_t offset = keyPtr->offset;
if ((tsdTablePtr != NULL) && (offset > 0)
&& (offset < tsdTablePtr->allocated)) {
resultPtr = tsdTablePtr->tablePtr[offset];
|
| ︙ | ︙ | |||
219 220 221 222 223 224 225 |
*/
void
TclThreadStorageKeySet(
Tcl_ThreadDataKey *dataKeyPtr,
void *value)
{
| | | 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 |
*/
void
TclThreadStorageKeySet(
Tcl_ThreadDataKey *dataKeyPtr,
void *value)
{
TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetMasterTSD(tsdMaster.key);
TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr;
if (tsdTablePtr == NULL) {
tsdTablePtr = TSDTableCreate();
TclpThreadSetMasterTSD(tsdMaster.key, tsdTablePtr);
}
|
| ︙ | ︙ | |||
284 285 286 287 288 289 290 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadDataThread(void)
{
| | | 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 |
*
*----------------------------------------------------------------------
*/
void
TclFinalizeThreadDataThread(void)
{
TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetMasterTSD(tsdMaster.key);
if (tsdTablePtr != NULL) {
TSDTableDelete(tsdTablePtr);
TclpThreadSetMasterTSD(tsdMaster.key, NULL);
}
}
|
| ︙ | ︙ |
Changes to generic/tclThreadTest.c.
| ︙ | ︙ | |||
115 116 117 118 119 120 121 | /* * Access to the list of threads and to the thread send results is guarded by * this mutex. */ TCL_DECLARE_MUTEX(threadMutex) | | | | | | | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 | /* * Access to the list of threads and to the thread send results is guarded by * this mutex. */ TCL_DECLARE_MUTEX(threadMutex) static int ThreadObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int ThreadCreate(Tcl_Interp *interp, const char *script, int joinable); static int ThreadList(Tcl_Interp *interp); static int ThreadSend(Tcl_Interp *interp, Tcl_ThreadId id, const char *script, int wait); static int ThreadCancel(Tcl_Interp *interp, Tcl_ThreadId id, const char *result, int flags); static Tcl_ThreadCreateType NewTestThread(void *clientData); static void ListRemove(ThreadSpecificData *tsdPtr); static void ListUpdateInner(ThreadSpecificData *tsdPtr); static int ThreadEventProc(Tcl_Event *evPtr, int mask); static void ThreadErrorProc(Tcl_Interp *interp); static void ThreadFreeProc(void *clientData); static int ThreadDeleteEvent(Tcl_Event *eventPtr, void *clientData); static void ThreadExitProc(void *clientData); extern int Tcltest_Init(Tcl_Interp *interp); /* *---------------------------------------------------------------------- * * TclThread_Init -- * |
| ︙ | ︙ | |||
199 200 201 202 203 204 205 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ThreadObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
int option;
static const char *const threadOptions[] = {
|
| ︙ | ︙ | |||
290 291 292 293 294 295 296 | * Possibly -joinable, then no special script, no joinable, then * its a script. */ script = Tcl_GetStringFromObj(objv[2], &len); if ((len > 1) && (script[0] == '-') && (script[1] == 'j') && | | | | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 |
* Possibly -joinable, then no special script, no joinable, then
* its a script.
*/
script = Tcl_GetStringFromObj(objv[2], &len);
if ((len > 1) && (script[0] == '-') && (script[1] == 'j') &&
(0 == strncmp(script, "-joinable", (size_t) len))) {
joinable = 1;
script = "testthread wait"; /* Just enter event loop */
} else {
/*
* Remember the script
*/
joinable = 0;
}
} else if (objc == 4) {
/*
* Definitely a script available, but is the flag -joinable?
*/
script = Tcl_GetStringFromObj(objv[2], &len);
joinable = ((len > 1) && (script[0] == '-') && (script[1] == 'j')
&& (0 == strncmp(script, "-joinable", (size_t) len)));
script = Tcl_GetString(objv[3]);
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?-joinable? ?script?");
return TCL_ERROR;
}
return ThreadCreate(interp, script, joinable);
}
|
| ︙ | ︙ | |||
428 429 430 431 432 433 434 |
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "proc");
return TCL_ERROR;
}
Tcl_MutexLock(&threadMutex);
errorThreadId = Tcl_GetCurrentThread();
if (errorProcString) {
| | | | 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 |
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "proc");
return TCL_ERROR;
}
Tcl_MutexLock(&threadMutex);
errorThreadId = Tcl_GetCurrentThread();
if (errorProcString) {
ckfree(errorProcString);
}
proc = Tcl_GetString(objv[2]);
errorProcString = (char *)ckalloc(strlen(proc) + 1);
strcpy(errorProcString, proc);
Tcl_MutexUnlock(&threadMutex);
return TCL_OK;
}
case THREAD_WAIT:
if (objc > 2) {
Tcl_WrongNumArgs(interp, 2, objv, "");
|
| ︙ | ︙ | |||
487 488 489 490 491 492 493 | * * Side effects: * Create a thread. * *---------------------------------------------------------------------- */ | < | 486 487 488 489 490 491 492 493 494 495 496 497 498 499 |
*
* Side effects:
* Create a thread.
*
*----------------------------------------------------------------------
*/
static int
ThreadCreate(
Tcl_Interp *interp, /* Current interpreter. */
const char *script, /* Script to execute */
int joinable) /* Flag, joinable thread or not */
{
ThreadCtrl ctrl;
|
| ︙ | ︙ | |||
552 553 554 555 556 557 558 | * A Tcl script is executed in a new thread. * *------------------------------------------------------------------------ */ Tcl_ThreadCreateType NewTestThread( | | | | 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 |
* A Tcl script is executed in a new thread.
*
*------------------------------------------------------------------------
*/
Tcl_ThreadCreateType
NewTestThread(
void *clientData)
{
ThreadCtrl *ctrlPtr = (ThreadCtrl *)clientData;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
int result;
char *threadEvalScript;
/*
* Initialize the interpreter. This should be more general.
*/
|
| ︙ | ︙ | |||
591 592 593 594 595 596 597 |
ListUpdateInner(tsdPtr);
/*
* We need to keep a pointer to the alloc'ed mem of the script we are
* eval'ing, for the case that we exit during evaluation
*/
| | | 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 |
ListUpdateInner(tsdPtr);
/*
* We need to keep a pointer to the alloc'ed mem of the script we are
* eval'ing, for the case that we exit during evaluation
*/
threadEvalScript = (char *)ckalloc(strlen(ctrlPtr->script) + 1);
strcpy(threadEvalScript, ctrlPtr->script);
Tcl_CreateThreadExitHandler(ThreadExitProc, threadEvalScript);
/*
* Notify the parent we are alive.
*/
|
| ︙ | ︙ | |||
666 667 668 669 670 671 672 |
Tcl_WriteChars(errChannel, "\n", 1);
} else {
argv[0] = errorProcString;
argv[1] = buf;
argv[2] = errorInfo;
script = Tcl_Merge(3, argv);
ThreadSend(interp, errorThreadId, script, 0);
| | | 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 |
Tcl_WriteChars(errChannel, "\n", 1);
} else {
argv[0] = errorProcString;
argv[1] = buf;
argv[2] = errorInfo;
script = Tcl_Merge(3, argv);
ThreadSend(interp, errorThreadId, script, 0);
ckfree(script);
}
}
/*
*------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
836 837 838 839 840 841 842 |
return Tcl_EvalEx(interp, script,-1,TCL_EVAL_GLOBAL);
}
/*
* Create the event for its event queue.
*/
| | | | | 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 |
return Tcl_EvalEx(interp, script,-1,TCL_EVAL_GLOBAL);
}
/*
* Create the event for its event queue.
*/
threadEventPtr = (ThreadEvent*)ckalloc(sizeof(ThreadEvent));
threadEventPtr->script = (char *)ckalloc(strlen(script) + 1);
strcpy(threadEventPtr->script, script);
if (!wait) {
resultPtr = threadEventPtr->resultPtr = NULL;
} else {
resultPtr = (ThreadEventResult *)ckalloc(sizeof(ThreadEventResult));
threadEventPtr->resultPtr = resultPtr;
/*
* Initialize the result fields.
*/
resultPtr->done = NULL;
|
| ︙ | ︙ | |||
914 915 916 917 918 919 920 |
resultPtr->prevPtr = NULL;
Tcl_MutexUnlock(&threadMutex);
if (resultPtr->code != TCL_OK) {
if (resultPtr->errorCode) {
Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL);
| | | | | | 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 |
resultPtr->prevPtr = NULL;
Tcl_MutexUnlock(&threadMutex);
if (resultPtr->code != TCL_OK) {
if (resultPtr->errorCode) {
Tcl_SetErrorCode(interp, resultPtr->errorCode, NULL);
ckfree(resultPtr->errorCode);
}
if (resultPtr->errorInfo) {
Tcl_AddErrorInfo(interp, resultPtr->errorInfo);
ckfree(resultPtr->errorInfo);
}
}
Tcl_AppendResult(interp, resultPtr->result, NULL);
Tcl_ConditionFinalize(&resultPtr->done);
code = resultPtr->code;
ckfree(resultPtr->result);
ckfree(resultPtr);
return code;
}
/*
*------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1006 1007 1008 1009 1010 1011 1012 |
*
*------------------------------------------------------------------------
*/
static int
ThreadEventProc(
Tcl_Event *evPtr, /* Really ThreadEvent */
| | | 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 |
*
*------------------------------------------------------------------------
*/
static int
ThreadEventProc(
Tcl_Event *evPtr, /* Really ThreadEvent */
TCL_UNUSED(int) /*mask*/)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ThreadEvent *threadEventPtr = (ThreadEvent *) evPtr;
ThreadEventResult *resultPtr = threadEventPtr->resultPtr;
Tcl_Interp *interp = tsdPtr->interp;
int code;
const char *result, *errorCode, *errorInfo;
|
| ︙ | ︙ | |||
1034 1035 1036 1037 1038 1039 1040 |
errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
} else {
errorCode = errorInfo = NULL;
}
result = Tcl_GetStringResult(interp);
}
| | | | | | 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 |
errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY);
errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
} else {
errorCode = errorInfo = NULL;
}
result = Tcl_GetStringResult(interp);
}
ckfree(threadEventPtr->script);
if (resultPtr) {
Tcl_MutexLock(&threadMutex);
resultPtr->code = code;
resultPtr->result = (char *)ckalloc(strlen(result) + 1);
strcpy(resultPtr->result, result);
if (errorCode != NULL) {
resultPtr->errorCode = (char *)ckalloc(strlen(errorCode) + 1);
strcpy(resultPtr->errorCode, errorCode);
}
if (errorInfo != NULL) {
resultPtr->errorInfo = (char *)ckalloc(strlen(errorInfo) + 1);
strcpy(resultPtr->errorInfo, errorInfo);
}
Tcl_ConditionNotify(&resultPtr->done);
Tcl_MutexUnlock(&threadMutex);
}
if (interp != NULL) {
Tcl_Release(interp);
|
| ︙ | ︙ | |||
1069 1070 1071 1072 1073 1074 1075 | * This is called from when we are exiting and memory needs * to be freed. * * Results: * None. * * Side effects: | | < | | < | | | 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 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 |
* This is called from when we are exiting and memory needs
* to be freed.
*
* Results:
* None.
*
* Side effects:
* Clears up mem specified in clientData
*
*------------------------------------------------------------------------
*/
static void
ThreadFreeProc(
void *clientData)
{
if (clientData) {
ckfree(clientData);
}
}
/*
*------------------------------------------------------------------------
*
* ThreadDeleteEvent --
*
* This is called from the ThreadExitProc to delete memory related
* to events that we put on the queue.
*
* Results:
* 1 it was our event and we want it removed, 0 otherwise.
*
* Side effects:
* It cleans up our events in the event queue for this thread.
*
*------------------------------------------------------------------------
*/
static int
ThreadDeleteEvent(
Tcl_Event *eventPtr, /* Really ThreadEvent */
TCL_UNUSED(ClientData))
{
if (eventPtr->proc == ThreadEventProc) {
ckfree(((ThreadEvent *) eventPtr)->script);
return 1;
}
/*
* If it was NULL, we were in the middle of servicing the event and it
* should be removed
*/
|
| ︙ | ︙ | |||
1137 1138 1139 1140 1141 1142 1143 | * Side effects: * It unblocks anyone that is waiting on a send to this thread. It cleans * up any events in the event queue for this thread. * *------------------------------------------------------------------------ */ | < | | | | | 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 |
* Side effects:
* It unblocks anyone that is waiting on a send to this thread. It cleans
* up any events in the event queue for this thread.
*
*------------------------------------------------------------------------
*/
static void
ThreadExitProc(
void *clientData)
{
char *threadEvalScript = (char *)clientData;
ThreadEventResult *resultPtr, *nextPtr;
Tcl_ThreadId self = Tcl_GetCurrentThread();
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->interp != NULL) {
ListRemove(tsdPtr);
}
Tcl_MutexLock(&threadMutex);
if (self == errorThreadId) {
if (errorProcString) { /* Extra safety */
ckfree(errorProcString);
errorProcString = NULL;
}
errorThreadId = 0;
}
if (threadEvalScript) {
ckfree(threadEvalScript);
threadEvalScript = NULL;
}
Tcl_DeleteEvents((Tcl_EventDeleteProc *) ThreadDeleteEvent, NULL);
for (resultPtr = resultList ; resultPtr ; resultPtr = nextPtr) {
nextPtr = resultPtr->nextPtr;
if (resultPtr->srcThreadId == self) {
|
| ︙ | ︙ | |||
1185 1186 1187 1188 1189 1190 1191 |
resultList = resultPtr->nextPtr;
}
if (resultPtr->nextPtr) {
resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
}
resultPtr->nextPtr = resultPtr->prevPtr = 0;
resultPtr->eventPtr->resultPtr = NULL;
| | | | 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 |
resultList = resultPtr->nextPtr;
}
if (resultPtr->nextPtr) {
resultPtr->nextPtr->prevPtr = resultPtr->prevPtr;
}
resultPtr->nextPtr = resultPtr->prevPtr = 0;
resultPtr->eventPtr->resultPtr = NULL;
ckfree(resultPtr);
} else if (resultPtr->dstThreadId == self) {
/*
* Dang. The target is going away. Unblock the caller. The result
* string must be dynamically allocated because the main thread is
* going to call free on it.
*/
const char *msg = "target thread died";
resultPtr->result = (char *)ckalloc(strlen(msg) + 1);
strcpy(resultPtr->result, msg);
resultPtr->code = TCL_ERROR;
Tcl_ConditionNotify(&resultPtr->done);
}
}
Tcl_MutexUnlock(&threadMutex);
}
|
| ︙ | ︙ |
Changes to generic/tclTimer.c.
| ︙ | ︙ | |||
178 179 180 181 182 183 184 |
*
*----------------------------------------------------------------------
*/
static ThreadSpecificData *
InitTimer(void)
{
| | | 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 |
*
*----------------------------------------------------------------------
*/
static ThreadSpecificData *
InitTimer(void)
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (tsdPtr == NULL) {
tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_CreateEventSource(TimerSetupProc, TimerCheckProc, NULL);
Tcl_CreateThreadExitHandler(TimerExitProc, NULL);
}
return tsdPtr;
|
| ︙ | ︙ | |||
207 208 209 210 211 212 213 | * Removes the timer and idle event sources and remaining events. * *---------------------------------------------------------------------- */ static void TimerExitProc( | | | | | | 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 |
* Removes the timer and idle event sources and remaining events.
*
*----------------------------------------------------------------------
*/
static void
TimerExitProc(
TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
Tcl_DeleteEventSource(TimerSetupProc, TimerCheckProc, NULL);
if (tsdPtr != NULL) {
TimerHandler *timerHandlerPtr;
timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
while (timerHandlerPtr != NULL) {
tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
ckfree(timerHandlerPtr);
timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
}
}
}
/*
*--------------------------------------------------------------
|
| ︙ | ︙ | |||
290 291 292 293 294 295 296 |
Tcl_TimerToken
TclCreateAbsoluteTimerHandler(
Tcl_Time *timePtr,
Tcl_TimerProc *proc,
ClientData clientData)
{
| | | | 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 |
Tcl_TimerToken
TclCreateAbsoluteTimerHandler(
Tcl_Time *timePtr,
Tcl_TimerProc *proc,
ClientData clientData)
{
TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr;
ThreadSpecificData *tsdPtr = InitTimer();
timerHandlerPtr = (TimerHandler *)ckalloc(sizeof(TimerHandler));
/*
* Fill in fields for the event.
*/
memcpy(&timerHandlerPtr->time, timePtr, sizeof(Tcl_Time));
timerHandlerPtr->proc = proc;
|
| ︙ | ︙ | |||
351 352 353 354 355 356 357 |
*/
void
Tcl_DeleteTimerHandler(
Tcl_TimerToken token) /* Result previously returned by
* Tcl_DeleteTimerHandler. */
{
| | | | 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 |
*/
void
Tcl_DeleteTimerHandler(
Tcl_TimerToken token) /* Result previously returned by
* Tcl_DeleteTimerHandler. */
{
TimerHandler *timerHandlerPtr, *prevPtr;
ThreadSpecificData *tsdPtr = InitTimer();
if (token == NULL) {
return;
}
for (timerHandlerPtr = tsdPtr->firstTimerHandlerPtr, prevPtr = NULL;
timerHandlerPtr != NULL; prevPtr = timerHandlerPtr,
timerHandlerPtr = timerHandlerPtr->nextPtr) {
if (timerHandlerPtr->token != token) {
continue;
}
if (prevPtr == NULL) {
tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
} else {
prevPtr->nextPtr = timerHandlerPtr->nextPtr;
}
ckfree(timerHandlerPtr);
return;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
394 395 396 397 398 399 400 | * May update the maximum notifier block time. * *---------------------------------------------------------------------- */ static void TimerSetupProc( | | | 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 |
* May update the maximum notifier block time.
*
*----------------------------------------------------------------------
*/
static void
TimerSetupProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
Tcl_Time blockTime;
ThreadSpecificData *tsdPtr = InitTimer();
if (((flags & TCL_IDLE_EVENTS) && tsdPtr->idleList)
|| ((flags & TCL_TIMER_EVENTS) && tsdPtr->timerPending)) {
|
| ︙ | ︙ | |||
452 453 454 455 456 457 458 | * May queue an event and update the maximum notifier block time. * *---------------------------------------------------------------------- */ static void TimerCheckProc( | | | 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 |
* May queue an event and update the maximum notifier block time.
*
*----------------------------------------------------------------------
*/
static void
TimerCheckProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
Tcl_Event *timerEvPtr;
Tcl_Time blockTime;
ThreadSpecificData *tsdPtr = InitTimer();
if ((flags & TCL_TIMER_EVENTS) && tsdPtr->firstTimerHandlerPtr) {
|
| ︙ | ︙ | |||
484 485 486 487 488 489 490 |
/*
* If the first timer has expired, stick an event on the queue.
*/
if (blockTime.sec == 0 && blockTime.usec == 0 &&
!tsdPtr->timerPending) {
tsdPtr->timerPending = 1;
| | | 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 |
/*
* If the first timer has expired, stick an event on the queue.
*/
if (blockTime.sec == 0 && blockTime.usec == 0 &&
!tsdPtr->timerPending) {
tsdPtr->timerPending = 1;
timerEvPtr = (Tcl_Event *)ckalloc(sizeof(Tcl_Event));
timerEvPtr->proc = TimerHandlerEventProc;
Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL);
}
}
}
/*
|
| ︙ | ︙ | |||
514 515 516 517 518 519 520 | * Whatever the timer handler callback functions do. * *---------------------------------------------------------------------- */ static int TimerHandlerEventProc( | | | 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 |
* Whatever the timer handler callback functions do.
*
*----------------------------------------------------------------------
*/
static int
TimerHandlerEventProc(
TCL_UNUSED(Tcl_Event *),
int flags) /* Flags that indicate what events to handle,
* such as TCL_FILE_EVENTS. */
{
TimerHandler *timerHandlerPtr, **nextPtrPtr;
Tcl_Time time;
int currentTimerId;
ThreadSpecificData *tsdPtr = InitTimer();
|
| ︙ | ︙ | |||
587 588 589 590 591 592 593 | /* * Remove the handler from the queue before invoking it, to avoid * potential reentrancy problems. */ *nextPtrPtr = timerHandlerPtr->nextPtr; timerHandlerPtr->proc(timerHandlerPtr->clientData); | | | 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 |
/*
* Remove the handler from the queue before invoking it, to avoid
* potential reentrancy problems.
*/
*nextPtrPtr = timerHandlerPtr->nextPtr;
timerHandlerPtr->proc(timerHandlerPtr->clientData);
ckfree(timerHandlerPtr);
}
TimerSetupProc(NULL, TCL_TIMER_EVENTS);
return 1;
}
/*
*--------------------------------------------------------------
|
| ︙ | ︙ | |||
617 618 619 620 621 622 623 |
*/
void
Tcl_DoWhenIdle(
Tcl_IdleProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
| | | | 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 |
*/
void
Tcl_DoWhenIdle(
Tcl_IdleProc *proc, /* Function to invoke. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
IdleHandler *idlePtr;
Tcl_Time blockTime;
ThreadSpecificData *tsdPtr = InitTimer();
idlePtr = (IdleHandler *)ckalloc(sizeof(IdleHandler));
idlePtr->proc = proc;
idlePtr->clientData = clientData;
idlePtr->generation = tsdPtr->idleGeneration;
idlePtr->nextPtr = NULL;
if (tsdPtr->lastIdlePtr == NULL) {
tsdPtr->idleList = idlePtr;
} else {
|
| ︙ | ︙ | |||
661 662 663 664 665 666 667 |
*/
void
Tcl_CancelIdleCall(
Tcl_IdleProc *proc, /* Function that was previously registered. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
| | | | 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 |
*/
void
Tcl_CancelIdleCall(
Tcl_IdleProc *proc, /* Function that was previously registered. */
ClientData clientData) /* Arbitrary value to pass to proc. */
{
IdleHandler *idlePtr, *prevPtr;
IdleHandler *nextPtr;
ThreadSpecificData *tsdPtr = InitTimer();
for (prevPtr = NULL, idlePtr = tsdPtr->idleList; idlePtr != NULL;
prevPtr = idlePtr, idlePtr = idlePtr->nextPtr) {
while ((idlePtr->proc == proc)
&& (idlePtr->clientData == clientData)) {
nextPtr = idlePtr->nextPtr;
ckfree(idlePtr);
idlePtr = nextPtr;
if (prevPtr == NULL) {
tsdPtr->idleList = idlePtr;
} else {
prevPtr->nextPtr = idlePtr;
}
if (idlePtr == NULL) {
|
| ︙ | ︙ | |||
745 746 747 748 749 750 751 |
&& ((oldGeneration - idlePtr->generation) >= 0));
idlePtr = tsdPtr->idleList) {
tsdPtr->idleList = idlePtr->nextPtr;
if (tsdPtr->idleList == NULL) {
tsdPtr->lastIdlePtr = NULL;
}
idlePtr->proc(idlePtr->clientData);
| | | 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 |
&& ((oldGeneration - idlePtr->generation) >= 0));
idlePtr = tsdPtr->idleList) {
tsdPtr->idleList = idlePtr->nextPtr;
if (tsdPtr->idleList == NULL) {
tsdPtr->lastIdlePtr = NULL;
}
idlePtr->proc(idlePtr->clientData);
ckfree(idlePtr);
}
if (tsdPtr->idleList) {
blockTime.sec = 0;
blockTime.usec = 0;
Tcl_SetMaxBlockTime(&blockTime);
}
return 1;
|
| ︙ | ︙ | |||
772 773 774 775 776 777 778 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | | | | | 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_AfterObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_WideInt ms = 0; /* Number of milliseconds to wait */
Tcl_Time wakeup;
AfterInfo *afterPtr;
AfterAssocData *assocPtr;
int length;
int index = -1;
static const char *const afterSubCmds[] = {
"cancel", "idle", "info", NULL
};
enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
ThreadSpecificData *tsdPtr = InitTimer();
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
/*
* Create the "after" information associated for this interpreter, if it
* doesn't already exist.
*/
assocPtr = (AfterAssocData *)Tcl_GetAssocData(interp, "tclAfter", NULL);
if (assocPtr == NULL) {
assocPtr = (AfterAssocData *)ckalloc(sizeof(AfterAssocData));
assocPtr->interp = interp;
assocPtr->firstAfterPtr = NULL;
Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr);
}
/*
* First lets see if the command was passed a number as the first argument.
*/
if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) {
if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index)
!= TCL_OK) {
const char *arg = Tcl_GetString(objv[1]);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad argument \"%s\": must be"
" cancel, idle, info, or an integer", arg));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument",
arg, NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
841 842 843 844 845 846 847 |
case -1: {
if (ms < 0) {
ms = 0;
}
if (objc == 2) {
return AfterDelay(interp, ms);
}
| | | 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 |
case -1: {
if (ms < 0) {
ms = 0;
}
if (objc == 2) {
return AfterDelay(interp, ms);
}
afterPtr = (AfterInfo *)ckalloc(sizeof(AfterInfo));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
} else {
afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
Tcl_IncrRefCount(afterPtr->commandPtr);
|
| ︙ | ︙ | |||
879 880 881 882 883 884 885 |
assocPtr->firstAfterPtr = afterPtr;
Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id));
return TCL_OK;
}
case AFTER_CANCEL: {
Tcl_Obj *commandPtr;
const char *command, *tempCommand;
| | | | 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 |
assocPtr->firstAfterPtr = afterPtr;
Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id));
return TCL_OK;
}
case AFTER_CANCEL: {
Tcl_Obj *commandPtr;
const char *command, *tempCommand;
int tempLength;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "id|command");
return TCL_ERROR;
}
if (objc == 3) {
commandPtr = objv[2];
} else {
commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
command = TclGetStringFromObj(commandPtr, &length);
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
tempCommand = TclGetStringFromObj(afterPtr->commandPtr,
&tempLength);
if ((length == tempLength)
|
| ︙ | ︙ | |||
921 922 923 924 925 926 927 |
break;
}
case AFTER_IDLE:
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?");
return TCL_ERROR;
}
| | | 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 |
break;
}
case AFTER_IDLE:
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?");
return TCL_ERROR;
}
afterPtr = (AfterInfo *)ckalloc(sizeof(AfterInfo));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
} else {
afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
Tcl_IncrRefCount(afterPtr->commandPtr);
|
| ︙ | ︙ | |||
1146 1147 1148 1149 1150 1151 1152 |
*----------------------------------------------------------------------
*/
static void
AfterProc(
ClientData clientData) /* Describes command to execute. */
{
| | | 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 |
*----------------------------------------------------------------------
*/
static void
AfterProc(
ClientData clientData) /* Describes command to execute. */
{
AfterInfo *afterPtr = (AfterInfo *)clientData;
AfterAssocData *assocPtr = afterPtr->assocPtr;
AfterInfo *prevPtr;
int result;
Tcl_Interp *interp;
/*
* First remove the callback from our list of callbacks; otherwise someone
|
| ︙ | ︙ | |||
1186 1187 1188 1189 1190 1191 1192 |
Tcl_Release(interp);
/*
* Free the memory for the callback.
*/
Tcl_DecrRefCount(afterPtr->commandPtr);
| | | 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 |
Tcl_Release(interp);
/*
* Free the memory for the callback.
*/
Tcl_DecrRefCount(afterPtr->commandPtr);
ckfree(afterPtr);
}
/*
*----------------------------------------------------------------------
*
* FreeAfterPtr --
*
|
| ︙ | ︙ | |||
1224 1225 1226 1227 1228 1229 1230 |
for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr;
prevPtr = prevPtr->nextPtr) {
/* Empty loop body. */
}
prevPtr->nextPtr = afterPtr->nextPtr;
}
Tcl_DecrRefCount(afterPtr->commandPtr);
| | < | | | | | 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 |
for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr;
prevPtr = prevPtr->nextPtr) {
/* Empty loop body. */
}
prevPtr->nextPtr = afterPtr->nextPtr;
}
Tcl_DecrRefCount(afterPtr->commandPtr);
ckfree(afterPtr);
}
/*
*----------------------------------------------------------------------
*
* AfterCleanupProc --
*
* This function is invoked whenever an interpreter is deleted
* to cleanup the AssocData for "tclAfter".
*
* Results:
* None.
*
* Side effects:
* After commands are removed.
*
*----------------------------------------------------------------------
*/
static void
AfterCleanupProc(
ClientData clientData, /* Points to AfterAssocData for the
* interpreter. */
TCL_UNUSED(Tcl_Interp *))
{
AfterAssocData *assocPtr = (AfterAssocData *)clientData;
AfterInfo *afterPtr;
while (assocPtr->firstAfterPtr != NULL) {
afterPtr = assocPtr->firstAfterPtr;
assocPtr->firstAfterPtr = afterPtr->nextPtr;
if (afterPtr->token != NULL) {
Tcl_DeleteTimerHandler(afterPtr->token);
} else {
Tcl_CancelIdleCall(AfterProc, afterPtr);
}
Tcl_DecrRefCount(afterPtr->commandPtr);
ckfree(afterPtr);
}
ckfree(assocPtr);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* tab-width: 8
* indent-tabs-mode: nil
* End:
*/
|
Changes to generic/tclTomMath.decls.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 |
interface tclTomMath
# hooks {tclTomMathInt}
scspec EXTERN
# Declare each of the functions in the Tcl tommath interface
declare 0 {
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | > > | < < < < < < < | | < < > | | < | > | | | | | < < | > | | > > | < < | | < < > | | > | < > | | < > | | | | | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 |
interface tclTomMath
# hooks {tclTomMathInt}
scspec EXTERN
# Declare each of the functions in the Tcl tommath interface
declare 0 {
int MP_WUR TclBN_epoch(void)
}
declare 1 {
int MP_WUR TclBN_revision(void)
}
declare 2 {
mp_err MP_WUR TclBN_mp_add(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 3 {
mp_err MP_WUR TclBN_mp_add_d(const mp_int *a, unsigned int b, mp_int *c)
}
declare 4 {
mp_err MP_WUR TclBN_mp_and(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 5 {
void TclBN_mp_clamp(mp_int *a)
}
declare 6 {
void TclBN_mp_clear(mp_int *a)
}
declare 7 {
void TclBN_mp_clear_multi(mp_int *a, ...)
}
declare 8 {
mp_ord MP_WUR TclBN_mp_cmp(const mp_int *a, const mp_int *b)
}
declare 9 {
mp_ord MP_WUR TclBN_mp_cmp_d(const mp_int *a, unsigned int b)
}
declare 10 {
mp_ord MP_WUR TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b)
}
declare 11 {
mp_err MP_WUR TclBN_mp_copy(const mp_int *a, mp_int *b)
}
declare 12 {
int MP_WUR TclBN_mp_count_bits(const mp_int *a)
}
declare 13 {
mp_err MP_WUR TclBN_mp_div(const mp_int *a, const mp_int *b, mp_int *q, mp_int *r)
}
declare 14 {
mp_err MP_WUR TclBN_mp_div_d(const mp_int *a, unsigned int b, mp_int *q, unsigned int *r)
}
declare 15 {
mp_err MP_WUR TclBN_mp_div_2(const mp_int *a, mp_int *q)
}
declare 16 {
mp_err MP_WUR TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r)
}
declare 17 {deprecated {is private function in libtommath}} {
mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q, unsigned int *r)
}
declare 18 {
void TclBN_mp_exch(mp_int *a, mp_int *b)
}
declare 19 {
mp_err MP_WUR TclBN_mp_expt_u32(const mp_int *a, unsigned int b, mp_int *c)
}
declare 20 {
mp_err MP_WUR TclBN_mp_grow(mp_int *a, int size)
}
declare 21 {
mp_err MP_WUR TclBN_mp_init(mp_int *a)
}
declare 22 {
mp_err MP_WUR TclBN_mp_init_copy(mp_int *a, const mp_int *b)
}
declare 23 {
mp_err MP_WUR TclBN_mp_init_multi(mp_int *a, ...)
}
declare 24 {
mp_err MP_WUR TclBN_mp_init_set(mp_int *a, unsigned int b)
}
declare 25 {
mp_err MP_WUR TclBN_mp_init_size(mp_int *a, int size)
}
declare 26 {
mp_err MP_WUR TclBN_mp_lshd(mp_int *a, int shift)
}
declare 27 {
mp_err MP_WUR TclBN_mp_mod(const mp_int *a, const mp_int *b, mp_int *r)
}
declare 28 {
mp_err MP_WUR TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r)
}
declare 29 {
mp_err MP_WUR TclBN_mp_mul(const mp_int *a, const mp_int *b, mp_int *p)
}
declare 30 {
mp_err MP_WUR TclBN_mp_mul_d(const mp_int *a, unsigned int b, mp_int *p)
}
declare 31 {
mp_err MP_WUR TclBN_mp_mul_2(const mp_int *a, mp_int *p)
}
declare 32 {
mp_err MP_WUR TclBN_mp_mul_2d(const mp_int *a, int d, mp_int *p)
}
declare 33 {
mp_err MP_WUR TclBN_mp_neg(const mp_int *a, mp_int *b)
}
declare 34 {
mp_err MP_WUR TclBN_mp_or(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 35 {
mp_err MP_WUR TclBN_mp_radix_size(const mp_int *a, int radix, int *size)
}
declare 36 {
mp_err MP_WUR TclBN_mp_read_radix(mp_int *a, const char *str, int radix)
}
declare 37 {
void TclBN_mp_rshd(mp_int *a, int shift)
}
declare 38 {
mp_err MP_WUR TclBN_mp_shrink(mp_int *a)
}
declare 39 {deprecated {macro calling mp_set_u64}} {
void TclBN_mp_set(mp_int *a, unsigned int b)
}
declare 40 {nostub {is private function in libtommath}} {
mp_err TclBN_mp_sqr(const mp_int *a, mp_int *b)
}
declare 41 {
mp_err MP_WUR TclBN_mp_sqrt(const mp_int *a, mp_int *b)
}
declare 42 {
mp_err MP_WUR TclBN_mp_sub(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 43 {
mp_err MP_WUR TclBN_mp_sub_d(const mp_int *a, unsigned int b, mp_int *c)
}
declare 44 {deprecated {Use mp_to_ubin}} {
mp_err TclBN_mp_to_unsigned_bin(const mp_int *a, unsigned char *b)
}
declare 45 {deprecated {Use mp_to_ubin}} {
mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b,
unsigned long *outlen)
}
declare 46 {deprecated {Use mp_to_radix}} {
mp_err TclBN_mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen)
}
declare 47 {
size_t TclBN_mp_ubin_size(const mp_int *a)
}
declare 48 {
mp_err MP_WUR TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 49 {
void TclBN_mp_zero(mp_int *a)
}
# internal routines to libtommath - should not be called but must be
# exported to accommodate the "tommath" extension
declare 50 {deprecated {is private function in libtommath}} {
void TclBN_reverse(unsigned char *s, int len)
}
declare 51 {deprecated {is private function in libtommath}} {
mp_err TclBN_s_mp_mul_digs_fast(const mp_int *a, const mp_int *b, mp_int *c, int digs)
}
declare 52 {deprecated {is private function in libtommath}} {
mp_err TclBN_s_mp_sqr_fast(const mp_int *a, mp_int *b)
}
declare 53 {deprecated {is private function in libtommath}} {
mp_err TclBN_mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 54 {deprecated {is private function in libtommath}} {
mp_err TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b)
}
declare 55 {deprecated {is private function in libtommath}} {
mp_err TclBN_mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 56 {deprecated {is private function in libtommath}} {
mp_err TclBN_mp_toom_sqr(const mp_int *a, mp_int *b)
}
declare 57 {deprecated {is private function in libtommath}} {
mp_err TclBN_s_mp_add(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 58 {deprecated {is private function in libtommath}} {
mp_err TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs)
}
declare 59 {deprecated {is private function in libtommath}} {
mp_err TclBN_s_mp_sqr(const mp_int *a, mp_int *b)
}
declare 60 {deprecated {is private function in libtommath}} {
mp_err TclBN_s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 61 {deprecated {macro calling mp_init_u64}} {
mp_err TclBN_mp_init_ul(mp_int *a, unsigned long i)
}
declare 62 {deprecated {macro calling mp_set_u64}} {
void TclBN_mp_set_ul(mp_int *a, unsigned long i)
}
declare 63 {
int MP_WUR TclBN_mp_cnt_lsb(const mp_int *a)
}
declare 64 {deprecated {macro calling mp_init_i64}} {
int TclBN_mp_init_l(mp_int *bignum, long initVal)
}
declare 65 {
int MP_WUR TclBN_mp_init_i64(mp_int *bignum, int64_t initVal)
}
declare 66 {
int MP_WUR TclBN_mp_init_u64(mp_int *bignum, uint64_t initVal)
}
# Added in libtommath 1.0
declare 67 {deprecated {Use mp_expt_u32}} {
mp_err TclBN_mp_expt_d_ex(const mp_int *a, unsigned int b, mp_int *c, int fast)
}
# Added in libtommath 1.0.1
declare 68 {
void TclBN_mp_set_u64(mp_int *a, uint64_t i)
}
declare 69 {
uint64_t MP_WUR TclBN_mp_get_mag_u64(const mp_int *a)
}
declare 70 {
void TclBN_mp_set_i64(mp_int *a, int64_t i)
}
# Added in libtommath 1.1.0
declare 73 {deprecated {merged with mp_and}} {
mp_err TclBN_mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 74 {deprecated {merged with mp_or}} {
mp_err TclBN_mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 75 {deprecated {merged with mp_xor}} {
mp_err TclBN_mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c)
}
declare 76 {
mp_err MP_WUR TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c)
}
# Added in libtommath 1.2.0
declare 78 {
int MP_WUR TclBN_mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written)
}
declare 79 {
mp_err MP_WUR TclBN_mp_div_ld(const mp_int *a, uint64_t b, mp_int *q, uint64_t *r)
}
declare 80 {
int MP_WUR TclBN_mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix)
}
# Local Variables:
# mode: tcl
# End:
|
Changes to generic/tclTomMath.h.
|
| < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < | < < < < < < < | < < < < | < < < < | | | | | | | < < < | | | | | < | | < < < < | < | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | | > | < < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
#ifndef BN_TCL_H_
#define BN_TCL_H_
#ifdef MP_NO_STDINT
# ifdef HAVE_STDINT_H
# include <stdint.h>
#else
# include "../compat/stdint.h"
# endif
#endif
#if defined(TCL_NO_TOMMATH_H)
typedef size_t mp_digit;
typedef int mp_sign;
# define MP_ZPOS 0 /* positive integer */
# define MP_NEG 1 /* negative */
typedef int mp_ord;
# define MP_LT -1 /* less than */
# define MP_EQ 0 /* equal to */
# define MP_GT 1 /* greater than */
typedef int mp_err;
# define MP_OKAY 0 /* no error */
# define MP_ERR -1 /* unknown error */
# define MP_MEM -2 /* out of mem */
# define MP_VAL -3 /* invalid input */
# define MP_ITER -4 /* maximum iterations reached */
# define MP_BUF -5 /* buffer overflow, supplied buffer too small */
# define MP_WUR /* nothing */
# define mp_iszero(a) ((a)->used == 0)
# define mp_isneg(a) ((a)->sign != 0)
/* the infamous mp_int structure */
# ifndef MP_INT_DECLARED
# define MP_INT_DECLARED
typedef struct mp_int mp_int;
# endif
struct mp_int {
int used, alloc;
mp_sign sign;
mp_digit *dp;
};
#elif !defined(BN_H_) /* If BN_H_ already defined, don't try to include tommath.h again. */
# include "tommath.h"
#endif
#include "tclTomMathDecls.h"
#endif
|
Changes to generic/tclTomMathDecls.h.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#ifndef _TCLTOMMATHDECLS
#define _TCLTOMMATHDECLS
#include "tcl.h"
/*
* Define the version of the Stubs table that's exported for tommath
*/
#define TCLTOMMATH_EPOCH 0
#define TCLTOMMATH_REVISION 0
#define Tcl_TomMath_InitStubs(interp,version) \
(TclTomMathInitializeStubs((interp),(version),\
TCLTOMMATH_EPOCH,TCLTOMMATH_REVISION))
/* Define custom memory allocation for libtommath */
| > > > > < | > > | | > > > > | | | > > > > > > > > > > > > > > > > > > > > > > < < < < < | | | | | | | | < < < > | < | < < < > < > > > | | | < | > > > > | < | < | | > > > > > > > > > < < < < < < < < < | | | | | < < < | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 |
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#ifndef _TCLTOMMATHDECLS
#define _TCLTOMMATHDECLS
#include "tcl.h"
#include <string.h>
#ifndef BN_H_
#include "tclTomMath.h"
#endif
/*
* Define the version of the Stubs table that's exported for tommath
*/
#define TCLTOMMATH_EPOCH 0
#define TCLTOMMATH_REVISION 0
#define Tcl_TomMath_InitStubs(interp,version) \
(TclTomMathInitializeStubs((interp),(version),\
TCLTOMMATH_EPOCH,TCLTOMMATH_REVISION))
/* Define custom memory allocation for libtommath */
/* MODULE_SCOPE void* TclBNAlloc( size_t ); */
#define TclBNAlloc(s) ((void*)ckalloc((size_t)(s)))
/* MODULE_SCOPE void* TclBNCalloc( size_t, size_t ); */
#define TclBNCalloc(m,s) memset(ckalloc((size_t)(m)*(size_t)(s)),0,(size_t)(m)*(size_t)(s))
/* MODULE_SCOPE void* TclBNRealloc( void*, size_t ); */
#define TclBNRealloc(x,s) ((void*)ckrealloc((char*)(x),(size_t)(s)))
/* MODULE_SCOPE void TclBNFree( void* ); */
#define TclBNFree(x) (ckfree((char*)(x)))
#undef MP_MALLOC
#undef MP_CALLOC
#undef MP_REALLOC
#undef MP_FREE
#define MP_MALLOC(size) TclBNAlloc(size)
#define MP_CALLOC(nmemb, size) TclBNCalloc(nmemb, size)
#define MP_REALLOC(mem, oldsize, newsize) TclBNRealloc(mem, newsize)
#define MP_FREE(mem, size) TclBNFree(mem)
#ifndef MODULE_SCOPE
# define MODULE_SCOPE extern
#endif
#ifdef __cplusplus
extern "C" {
#endif
MODULE_SCOPE mp_err TclBN_s_mp_add_d(const mp_int *a, mp_digit b, mp_int *c);
MODULE_SCOPE mp_ord TclBN_s_mp_cmp_d(const mp_int *a, mp_digit b);
MODULE_SCOPE mp_err TclBN_s_mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d);
MODULE_SCOPE mp_err TclBN_s_mp_div_3(const mp_int *a, mp_int *c, mp_digit *b);
MODULE_SCOPE mp_err TclBN_s_mp_expt_u32(const mp_int *a, uint32_t b, mp_int *c);
MODULE_SCOPE mp_err TclBN_s_mp_init_set(mp_int *a, mp_digit b);
MODULE_SCOPE mp_err TclBN_s_mp_mul_d(const mp_int *a, mp_digit b, mp_int *c);
MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len);
MODULE_SCOPE void TclBN_s_mp_set(mp_int *a, mp_digit b);
MODULE_SCOPE mp_err TclBN_s_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c);
#ifdef __cplusplus
}
#endif
/* Rename the global symbols in libtommath to avoid linkage conflicts */
#ifndef TCL_WITH_EXTERNAL_TOMMATH
#define bn_reverse TclBN_reverse
#define mp_add TclBN_mp_add
#define mp_add_d TclBN_s_mp_add_d
#define mp_and TclBN_mp_and
#define mp_clamp TclBN_mp_clamp
#define mp_clear TclBN_mp_clear
#define mp_clear_multi TclBN_mp_clear_multi
#define mp_cmp TclBN_mp_cmp
#define mp_cmp_d TclBN_s_mp_cmp_d
#define mp_cmp_mag TclBN_mp_cmp_mag
#define mp_cnt_lsb TclBN_mp_cnt_lsb
#define mp_copy TclBN_mp_copy
#define mp_count_bits TclBN_mp_count_bits
#define mp_div TclBN_mp_div
#define mp_div_d TclBN_s_mp_div_d
#define mp_div_2 TclBN_mp_div_2
#define mp_div_3 TclBN_s_mp_div_3
#define mp_div_2d TclBN_mp_div_2d
#define mp_exch TclBN_mp_exch
#define mp_expt_d TclBN_mp_expt_d
#define mp_expt_d_ex TclBN_mp_expt_d_ex
#define mp_expt_u32 TclBN_s_mp_expt_u32
#define mp_get_mag_u64 TclBN_mp_get_mag_u64
#define mp_grow TclBN_mp_grow
#define mp_init TclBN_mp_init
#define mp_init_copy TclBN_mp_init_copy
#define mp_init_i64 TclBN_mp_init_i64
#define mp_init_multi TclBN_mp_init_multi
#define mp_init_set TclBN_s_mp_init_set
#define mp_init_size TclBN_mp_init_size
#define mp_init_u64 TclBN_mp_init_u64
#define mp_lshd TclBN_mp_lshd
#define mp_mod TclBN_mp_mod
#define mp_mod_2d TclBN_mp_mod_2d
#define mp_mul TclBN_mp_mul
#define mp_mul_d TclBN_s_mp_mul_d
#define mp_mul_2 TclBN_mp_mul_2
#define mp_mul_2d TclBN_mp_mul_2d
#define mp_neg TclBN_mp_neg
#define mp_or TclBN_mp_or
#define mp_radix_size TclBN_mp_radix_size
#define mp_read_radix TclBN_mp_read_radix
#define mp_rshd TclBN_mp_rshd
#define mp_s_rmap TclBN_mp_s_rmap
#define mp_s_rmap_reverse TclBN_mp_s_rmap_reverse
#define mp_s_rmap_reverse_sz TclBN_mp_s_rmap_reverse_sz
#define mp_set TclBN_s_mp_set
#define mp_set_i64 TclBN_mp_set_i64
#define mp_set_u64 TclBN_mp_set_u64
#define mp_shrink TclBN_mp_shrink
#define mp_sqr TclBN_mp_sqr
#define mp_sqrt TclBN_mp_sqrt
#define mp_sub TclBN_mp_sub
#define mp_sub_d TclBN_s_mp_sub_d
#define mp_signed_rsh TclBN_mp_signed_rsh
#define mp_tc_and TclBN_mp_and
#define mp_tc_div_2d TclBN_mp_signed_rsh
#define mp_tc_or TclBN_mp_or
#define mp_tc_xor TclBN_mp_xor
#define mp_to_unsigned_bin TclBN_mp_to_unsigned_bin
#define mp_to_unsigned_bin_n TclBN_mp_to_unsigned_bin_n
#define mp_toradix_n TclBN_mp_toradix_n
#define mp_to_radix TclBN_mp_to_radix
#define mp_to_ubin TclBN_mp_to_ubin
#define mp_ubin_size TclBN_mp_ubin_size
#define mp_xor TclBN_mp_xor
#define mp_zero TclBN_mp_zero
#define s_mp_add TclBN_s_mp_add
#define s_mp_balance_mul TclBN_mp_balance_mul
#define s_mp_karatsuba_mul TclBN_mp_karatsuba_mul
#define s_mp_karatsuba_sqr TclBN_mp_karatsuba_sqr
#define s_mp_mul_digs TclBN_s_mp_mul_digs
#define s_mp_mul_digs_fast TclBN_s_mp_mul_digs_fast
#define s_mp_reverse TclBN_s_mp_reverse
#define s_mp_sqr TclBN_s_mp_sqr
#define s_mp_sqr_fast TclBN_s_mp_sqr_fast
#define s_mp_sub TclBN_s_mp_sub
#define s_mp_toom_mul TclBN_mp_toom_mul
#define s_mp_toom_sqr TclBN_mp_toom_sqr
#endif /* !TCL_WITH_EXTERNAL_TOMMATH */
#define mp_init_set_int(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_init_ul") TclBN_mp_init_u64(a,(unsigned int)(b)))
#define mp_set_int(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (TclBN_mp_set_u64((a),((unsigned int)(b))),MP_OKAY))
#define mp_set_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (TclBN_mp_set_u64((a),(long)(b)),MP_OKAY))
#define mp_set_long_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_u64") (TclBN_mp_set_u64((a),(b)),MP_OKAY))
#define mp_unsigned_bin_size(mp) (MP_DEPRECATED_PRAGMA("replaced by mp_ubin_size") (int)TclBN_mp_ubin_size(mp))
#undef TCL_STORAGE_CLASS
#ifdef BUILD_tcl
# define TCL_STORAGE_CLASS DLLEXPORT
#else
# ifdef USE_TCL_STUBS
# define TCL_STORAGE_CLASS
|
| ︙ | ︙ | |||
166 167 168 169 170 171 172 | #endif /* * Exported function declarations: */ /* 0 */ | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | > | > | > | | | | | > > | > > > | > > | > > > | > > | > > > | > > | > > > | > > > | > > | > > > > | > | | | > > | > | > > | | | | > > | > | > | > | | | > > | | | > | > > > > > > | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | > > > > | | | > | 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 |
#endif
/*
* Exported function declarations:
*/
/* 0 */
EXTERN int TclBN_epoch(void) MP_WUR;
/* 1 */
EXTERN int TclBN_revision(void) MP_WUR;
/* 2 */
EXTERN mp_err TclBN_mp_add(const mp_int *a, const mp_int *b,
mp_int *c) MP_WUR;
/* 3 */
EXTERN mp_err TclBN_mp_add_d(const mp_int *a, unsigned int b,
mp_int *c) MP_WUR;
/* 4 */
EXTERN mp_err TclBN_mp_and(const mp_int *a, const mp_int *b,
mp_int *c) MP_WUR;
/* 5 */
EXTERN void TclBN_mp_clamp(mp_int *a);
/* 6 */
EXTERN void TclBN_mp_clear(mp_int *a);
/* 7 */
EXTERN void TclBN_mp_clear_multi(mp_int *a, ...);
/* 8 */
EXTERN mp_ord TclBN_mp_cmp(const mp_int *a, const mp_int *b) MP_WUR;
/* 9 */
EXTERN mp_ord TclBN_mp_cmp_d(const mp_int *a, unsigned int b) MP_WUR;
/* 10 */
EXTERN mp_ord TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b) MP_WUR;
/* 11 */
EXTERN mp_err TclBN_mp_copy(const mp_int *a, mp_int *b) MP_WUR;
/* 12 */
EXTERN int TclBN_mp_count_bits(const mp_int *a) MP_WUR;
/* 13 */
EXTERN mp_err TclBN_mp_div(const mp_int *a, const mp_int *b,
mp_int *q, mp_int *r) MP_WUR;
/* 14 */
EXTERN mp_err TclBN_mp_div_d(const mp_int *a, unsigned int b,
mp_int *q, unsigned int *r) MP_WUR;
/* 15 */
EXTERN mp_err TclBN_mp_div_2(const mp_int *a, mp_int *q) MP_WUR;
/* 16 */
EXTERN mp_err TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q,
mp_int *r) MP_WUR;
/* 17 */
TCL_DEPRECATED("is private function in libtommath")
mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q,
unsigned int *r);
/* 18 */
EXTERN void TclBN_mp_exch(mp_int *a, mp_int *b);
/* 19 */
EXTERN mp_err TclBN_mp_expt_u32(const mp_int *a, unsigned int b,
mp_int *c) MP_WUR;
/* 20 */
EXTERN mp_err TclBN_mp_grow(mp_int *a, int size) MP_WUR;
/* 21 */
EXTERN mp_err TclBN_mp_init(mp_int *a) MP_WUR;
/* 22 */
EXTERN mp_err TclBN_mp_init_copy(mp_int *a, const mp_int *b) MP_WUR;
/* 23 */
EXTERN mp_err TclBN_mp_init_multi(mp_int *a, ...) MP_WUR;
/* 24 */
EXTERN mp_err TclBN_mp_init_set(mp_int *a, unsigned int b) MP_WUR;
/* 25 */
EXTERN mp_err TclBN_mp_init_size(mp_int *a, int size) MP_WUR;
/* 26 */
EXTERN mp_err TclBN_mp_lshd(mp_int *a, int shift) MP_WUR;
/* 27 */
EXTERN mp_err TclBN_mp_mod(const mp_int *a, const mp_int *b,
mp_int *r) MP_WUR;
/* 28 */
EXTERN mp_err TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r) MP_WUR;
/* 29 */
EXTERN mp_err TclBN_mp_mul(const mp_int *a, const mp_int *b,
mp_int *p) MP_WUR;
/* 30 */
EXTERN mp_err TclBN_mp_mul_d(const mp_int *a, unsigned int b,
mp_int *p) MP_WUR;
/* 31 */
EXTERN mp_err TclBN_mp_mul_2(const mp_int *a, mp_int *p) MP_WUR;
/* 32 */
EXTERN mp_err TclBN_mp_mul_2d(const mp_int *a, int d, mp_int *p) MP_WUR;
/* 33 */
EXTERN mp_err TclBN_mp_neg(const mp_int *a, mp_int *b) MP_WUR;
/* 34 */
EXTERN mp_err TclBN_mp_or(const mp_int *a, const mp_int *b,
mp_int *c) MP_WUR;
/* 35 */
EXTERN mp_err TclBN_mp_radix_size(const mp_int *a, int radix,
int *size) MP_WUR;
/* 36 */
EXTERN mp_err TclBN_mp_read_radix(mp_int *a, const char *str,
int radix) MP_WUR;
/* 37 */
EXTERN void TclBN_mp_rshd(mp_int *a, int shift);
/* 38 */
EXTERN mp_err TclBN_mp_shrink(mp_int *a) MP_WUR;
/* 39 */
TCL_DEPRECATED("macro calling mp_set_u64")
void TclBN_mp_set(mp_int *a, unsigned int b);
/* 40 */
EXTERN mp_err TclBN_mp_sqr(const mp_int *a, mp_int *b);
/* 41 */
EXTERN mp_err TclBN_mp_sqrt(const mp_int *a, mp_int *b) MP_WUR;
/* 42 */
EXTERN mp_err TclBN_mp_sub(const mp_int *a, const mp_int *b,
mp_int *c) MP_WUR;
/* 43 */
EXTERN mp_err TclBN_mp_sub_d(const mp_int *a, unsigned int b,
mp_int *c) MP_WUR;
/* 44 */
TCL_DEPRECATED("Use mp_to_ubin")
mp_err TclBN_mp_to_unsigned_bin(const mp_int *a,
unsigned char *b);
/* 45 */
TCL_DEPRECATED("Use mp_to_ubin")
mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a,
unsigned char *b, unsigned long *outlen);
/* 46 */
TCL_DEPRECATED("Use mp_to_radix")
mp_err TclBN_mp_toradix_n(const mp_int *a, char *str,
int radix, int maxlen);
/* 47 */
EXTERN size_t TclBN_mp_ubin_size(const mp_int *a);
/* 48 */
EXTERN mp_err TclBN_mp_xor(const mp_int *a, const mp_int *b,
mp_int *c) MP_WUR;
/* 49 */
EXTERN void TclBN_mp_zero(mp_int *a);
/* 50 */
TCL_DEPRECATED("is private function in libtommath")
void TclBN_reverse(unsigned char *s, int len);
/* 51 */
TCL_DEPRECATED("is private function in libtommath")
mp_err TclBN_s_mp_mul_digs_fast(const mp_int *a,
const mp_int *b, mp_int *c, int digs);
/* 52 */
TCL_DEPRECATED("is private function in libtommath")
mp_err TclBN_s_mp_sqr_fast(const mp_int *a, mp_int *b);
/* 53 */
TCL_DEPRECATED("is private function in libtommath")
mp_err TclBN_mp_karatsuba_mul(const mp_int *a,
const mp_int *b, mp_int *c);
/* 54 */
TCL_DEPRECATED("is private function in libtommath")
mp_err TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b);
/* 55 */
TCL_DEPRECATED("is private function in libtommath")
mp_err TclBN_mp_toom_mul(const mp_int *a, const mp_int *b,
mp_int *c);
/* 56 */
TCL_DEPRECATED("is private function in libtommath")
mp_err TclBN_mp_toom_sqr(const mp_int *a, mp_int *b);
/* 57 */
TCL_DEPRECATED("is private function in libtommath")
mp_err TclBN_s_mp_add(const mp_int *a, const mp_int *b,
mp_int *c);
/* 58 */
TCL_DEPRECATED("is private function in libtommath")
mp_err TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b,
mp_int *c, int digs);
/* 59 */
TCL_DEPRECATED("is private function in libtommath")
mp_err TclBN_s_mp_sqr(const mp_int *a, mp_int *b);
/* 60 */
TCL_DEPRECATED("is private function in libtommath")
mp_err TclBN_s_mp_sub(const mp_int *a, const mp_int *b,
mp_int *c);
/* 61 */
TCL_DEPRECATED("macro calling mp_init_u64")
mp_err TclBN_mp_init_ul(mp_int *a, unsigned long i);
/* 62 */
TCL_DEPRECATED("macro calling mp_set_u64")
void TclBN_mp_set_ul(mp_int *a, unsigned long i);
/* 63 */
EXTERN int TclBN_mp_cnt_lsb(const mp_int *a) MP_WUR;
/* 64 */
TCL_DEPRECATED("macro calling mp_init_i64")
int TclBN_mp_init_l(mp_int *bignum, long initVal);
/* 65 */
EXTERN int TclBN_mp_init_i64(mp_int *bignum, int64_t initVal) MP_WUR;
/* 66 */
EXTERN int TclBN_mp_init_u64(mp_int *bignum, uint64_t initVal) MP_WUR;
/* 67 */
TCL_DEPRECATED("Use mp_expt_u32")
mp_err TclBN_mp_expt_d_ex(const mp_int *a, unsigned int b,
mp_int *c, int fast);
/* 68 */
EXTERN void TclBN_mp_set_u64(mp_int *a, uint64_t i);
/* 69 */
EXTERN uint64_t TclBN_mp_get_mag_u64(const mp_int *a) MP_WUR;
/* 70 */
EXTERN void TclBN_mp_set_i64(mp_int *a, int64_t i);
/* Slot 71 is reserved */
/* Slot 72 is reserved */
/* 73 */
TCL_DEPRECATED("merged with mp_and")
mp_err TclBN_mp_tc_and(const mp_int *a, const mp_int *b,
mp_int *c);
/* 74 */
TCL_DEPRECATED("merged with mp_or")
mp_err TclBN_mp_tc_or(const mp_int *a, const mp_int *b,
mp_int *c);
/* 75 */
TCL_DEPRECATED("merged with mp_xor")
mp_err TclBN_mp_tc_xor(const mp_int *a, const mp_int *b,
mp_int *c);
/* 76 */
EXTERN mp_err TclBN_mp_signed_rsh(const mp_int *a, int b,
mp_int *c) MP_WUR;
/* Slot 77 is reserved */
/* 78 */
EXTERN int TclBN_mp_to_ubin(const mp_int *a, unsigned char *buf,
size_t maxlen, size_t *written) MP_WUR;
/* 79 */
EXTERN mp_err TclBN_mp_div_ld(const mp_int *a, uint64_t b,
mp_int *q, uint64_t *r) MP_WUR;
/* 80 */
EXTERN int TclBN_mp_to_radix(const mp_int *a, char *str,
size_t maxlen, size_t *written, int radix) MP_WUR;
typedef struct TclTomMathStubs {
int magic;
void *hooks;
int (*tclBN_epoch) (void) MP_WUR; /* 0 */
int (*tclBN_revision) (void) MP_WUR; /* 1 */
mp_err (*tclBN_mp_add) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 2 */
mp_err (*tclBN_mp_add_d) (const mp_int *a, unsigned int b, mp_int *c) MP_WUR; /* 3 */
mp_err (*tclBN_mp_and) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 4 */
void (*tclBN_mp_clamp) (mp_int *a); /* 5 */
void (*tclBN_mp_clear) (mp_int *a); /* 6 */
void (*tclBN_mp_clear_multi) (mp_int *a, ...); /* 7 */
mp_ord (*tclBN_mp_cmp) (const mp_int *a, const mp_int *b) MP_WUR; /* 8 */
mp_ord (*tclBN_mp_cmp_d) (const mp_int *a, unsigned int b) MP_WUR; /* 9 */
mp_ord (*tclBN_mp_cmp_mag) (const mp_int *a, const mp_int *b) MP_WUR; /* 10 */
mp_err (*tclBN_mp_copy) (const mp_int *a, mp_int *b) MP_WUR; /* 11 */
int (*tclBN_mp_count_bits) (const mp_int *a) MP_WUR; /* 12 */
mp_err (*tclBN_mp_div) (const mp_int *a, const mp_int *b, mp_int *q, mp_int *r) MP_WUR; /* 13 */
mp_err (*tclBN_mp_div_d) (const mp_int *a, unsigned int b, mp_int *q, unsigned int *r) MP_WUR; /* 14 */
mp_err (*tclBN_mp_div_2) (const mp_int *a, mp_int *q) MP_WUR; /* 15 */
mp_err (*tclBN_mp_div_2d) (const mp_int *a, int b, mp_int *q, mp_int *r) MP_WUR; /* 16 */
TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_div_3) (const mp_int *a, mp_int *q, unsigned int *r); /* 17 */
void (*tclBN_mp_exch) (mp_int *a, mp_int *b); /* 18 */
mp_err (*tclBN_mp_expt_u32) (const mp_int *a, unsigned int b, mp_int *c) MP_WUR; /* 19 */
mp_err (*tclBN_mp_grow) (mp_int *a, int size) MP_WUR; /* 20 */
mp_err (*tclBN_mp_init) (mp_int *a) MP_WUR; /* 21 */
mp_err (*tclBN_mp_init_copy) (mp_int *a, const mp_int *b) MP_WUR; /* 22 */
mp_err (*tclBN_mp_init_multi) (mp_int *a, ...) MP_WUR; /* 23 */
mp_err (*tclBN_mp_init_set) (mp_int *a, unsigned int b) MP_WUR; /* 24 */
mp_err (*tclBN_mp_init_size) (mp_int *a, int size) MP_WUR; /* 25 */
mp_err (*tclBN_mp_lshd) (mp_int *a, int shift) MP_WUR; /* 26 */
mp_err (*tclBN_mp_mod) (const mp_int *a, const mp_int *b, mp_int *r) MP_WUR; /* 27 */
mp_err (*tclBN_mp_mod_2d) (const mp_int *a, int b, mp_int *r) MP_WUR; /* 28 */
mp_err (*tclBN_mp_mul) (const mp_int *a, const mp_int *b, mp_int *p) MP_WUR; /* 29 */
mp_err (*tclBN_mp_mul_d) (const mp_int *a, unsigned int b, mp_int *p) MP_WUR; /* 30 */
mp_err (*tclBN_mp_mul_2) (const mp_int *a, mp_int *p) MP_WUR; /* 31 */
mp_err (*tclBN_mp_mul_2d) (const mp_int *a, int d, mp_int *p) MP_WUR; /* 32 */
mp_err (*tclBN_mp_neg) (const mp_int *a, mp_int *b) MP_WUR; /* 33 */
mp_err (*tclBN_mp_or) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 34 */
mp_err (*tclBN_mp_radix_size) (const mp_int *a, int radix, int *size) MP_WUR; /* 35 */
mp_err (*tclBN_mp_read_radix) (mp_int *a, const char *str, int radix) MP_WUR; /* 36 */
void (*tclBN_mp_rshd) (mp_int *a, int shift); /* 37 */
mp_err (*tclBN_mp_shrink) (mp_int *a) MP_WUR; /* 38 */
TCL_DEPRECATED_API("macro calling mp_set_u64") void (*tclBN_mp_set) (mp_int *a, unsigned int b); /* 39 */
TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_sqr) (const mp_int *a, mp_int *b); /* 40 */
mp_err (*tclBN_mp_sqrt) (const mp_int *a, mp_int *b) MP_WUR; /* 41 */
mp_err (*tclBN_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 42 */
mp_err (*tclBN_mp_sub_d) (const mp_int *a, unsigned int b, mp_int *c) MP_WUR; /* 43 */
TCL_DEPRECATED_API("Use mp_to_ubin") mp_err (*tclBN_mp_to_unsigned_bin) (const mp_int *a, unsigned char *b); /* 44 */
TCL_DEPRECATED_API("Use mp_to_ubin") mp_err (*tclBN_mp_to_unsigned_bin_n) (const mp_int *a, unsigned char *b, unsigned long *outlen); /* 45 */
TCL_DEPRECATED_API("Use mp_to_radix") mp_err (*tclBN_mp_toradix_n) (const mp_int *a, char *str, int radix, int maxlen); /* 46 */
size_t (*tclBN_mp_ubin_size) (const mp_int *a); /* 47 */
mp_err (*tclBN_mp_xor) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 48 */
void (*tclBN_mp_zero) (mp_int *a); /* 49 */
TCL_DEPRECATED_API("is private function in libtommath") void (*tclBN_reverse) (unsigned char *s, int len); /* 50 */
TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_mul_digs_fast) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 51 */
TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_sqr_fast) (const mp_int *a, mp_int *b); /* 52 */
TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_karatsuba_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 53 */
TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_karatsuba_sqr) (const mp_int *a, mp_int *b); /* 54 */
TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_toom_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 55 */
TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_toom_sqr) (const mp_int *a, mp_int *b); /* 56 */
TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_add) (const mp_int *a, const mp_int *b, mp_int *c); /* 57 */
TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_mul_digs) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 58 */
TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_sqr) (const mp_int *a, mp_int *b); /* 59 */
TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c); /* 60 */
TCL_DEPRECATED_API("macro calling mp_init_u64") mp_err (*tclBN_mp_init_ul) (mp_int *a, unsigned long i); /* 61 */
TCL_DEPRECATED_API("macro calling mp_set_u64") void (*tclBN_mp_set_ul) (mp_int *a, unsigned long i); /* 62 */
int (*tclBN_mp_cnt_lsb) (const mp_int *a) MP_WUR; /* 63 */
TCL_DEPRECATED_API("macro calling mp_init_i64") int (*tclBN_mp_init_l) (mp_int *bignum, long initVal); /* 64 */
int (*tclBN_mp_init_i64) (mp_int *bignum, int64_t initVal) MP_WUR; /* 65 */
int (*tclBN_mp_init_u64) (mp_int *bignum, uint64_t initVal) MP_WUR; /* 66 */
TCL_DEPRECATED_API("Use mp_expt_u32") mp_err (*tclBN_mp_expt_d_ex) (const mp_int *a, unsigned int b, mp_int *c, int fast); /* 67 */
void (*tclBN_mp_set_u64) (mp_int *a, uint64_t i); /* 68 */
uint64_t (*tclBN_mp_get_mag_u64) (const mp_int *a) MP_WUR; /* 69 */
void (*tclBN_mp_set_i64) (mp_int *a, int64_t i); /* 70 */
void (*reserved71)(void);
void (*reserved72)(void);
TCL_DEPRECATED_API("merged with mp_and") mp_err (*tclBN_mp_tc_and) (const mp_int *a, const mp_int *b, mp_int *c); /* 73 */
TCL_DEPRECATED_API("merged with mp_or") mp_err (*tclBN_mp_tc_or) (const mp_int *a, const mp_int *b, mp_int *c); /* 74 */
TCL_DEPRECATED_API("merged with mp_xor") mp_err (*tclBN_mp_tc_xor) (const mp_int *a, const mp_int *b, mp_int *c); /* 75 */
mp_err (*tclBN_mp_signed_rsh) (const mp_int *a, int b, mp_int *c) MP_WUR; /* 76 */
void (*reserved77)(void);
int (*tclBN_mp_to_ubin) (const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR; /* 78 */
mp_err (*tclBN_mp_div_ld) (const mp_int *a, uint64_t b, mp_int *q, uint64_t *r) MP_WUR; /* 79 */
int (*tclBN_mp_to_radix) (const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) MP_WUR; /* 80 */
} TclTomMathStubs;
extern const TclTomMathStubs *tclTomMathStubsPtr;
#ifdef __cplusplus
}
#endif
|
| ︙ | ︙ | |||
461 462 463 464 465 466 467 | (tclTomMathStubsPtr->tclBN_mp_div_2) /* 15 */ #define TclBN_mp_div_2d \ (tclTomMathStubsPtr->tclBN_mp_div_2d) /* 16 */ #define TclBN_mp_div_3 \ (tclTomMathStubsPtr->tclBN_mp_div_3) /* 17 */ #define TclBN_mp_exch \ (tclTomMathStubsPtr->tclBN_mp_exch) /* 18 */ | | | | 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 | (tclTomMathStubsPtr->tclBN_mp_div_2) /* 15 */ #define TclBN_mp_div_2d \ (tclTomMathStubsPtr->tclBN_mp_div_2d) /* 16 */ #define TclBN_mp_div_3 \ (tclTomMathStubsPtr->tclBN_mp_div_3) /* 17 */ #define TclBN_mp_exch \ (tclTomMathStubsPtr->tclBN_mp_exch) /* 18 */ #define TclBN_mp_expt_u32 \ (tclTomMathStubsPtr->tclBN_mp_expt_u32) /* 19 */ #define TclBN_mp_grow \ (tclTomMathStubsPtr->tclBN_mp_grow) /* 20 */ #define TclBN_mp_init \ (tclTomMathStubsPtr->tclBN_mp_init) /* 21 */ #define TclBN_mp_init_copy \ (tclTomMathStubsPtr->tclBN_mp_init_copy) /* 22 */ #define TclBN_mp_init_multi \ |
| ︙ | ︙ | |||
517 518 519 520 521 522 523 | (tclTomMathStubsPtr->tclBN_mp_sub_d) /* 43 */ #define TclBN_mp_to_unsigned_bin \ (tclTomMathStubsPtr->tclBN_mp_to_unsigned_bin) /* 44 */ #define TclBN_mp_to_unsigned_bin_n \ (tclTomMathStubsPtr->tclBN_mp_to_unsigned_bin_n) /* 45 */ #define TclBN_mp_toradix_n \ (tclTomMathStubsPtr->tclBN_mp_toradix_n) /* 46 */ | | | | | | | | | | | | | | > > > > > > > > > > > | | | | > > | < < > > > | | | | | | > > | | | | > > > > | < < | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 |
(tclTomMathStubsPtr->tclBN_mp_sub_d) /* 43 */
#define TclBN_mp_to_unsigned_bin \
(tclTomMathStubsPtr->tclBN_mp_to_unsigned_bin) /* 44 */
#define TclBN_mp_to_unsigned_bin_n \
(tclTomMathStubsPtr->tclBN_mp_to_unsigned_bin_n) /* 45 */
#define TclBN_mp_toradix_n \
(tclTomMathStubsPtr->tclBN_mp_toradix_n) /* 46 */
#define TclBN_mp_ubin_size \
(tclTomMathStubsPtr->tclBN_mp_ubin_size) /* 47 */
#define TclBN_mp_xor \
(tclTomMathStubsPtr->tclBN_mp_xor) /* 48 */
#define TclBN_mp_zero \
(tclTomMathStubsPtr->tclBN_mp_zero) /* 49 */
#define TclBN_reverse \
(tclTomMathStubsPtr->tclBN_reverse) /* 50 */
#define TclBN_s_mp_mul_digs_fast \
(tclTomMathStubsPtr->tclBN_s_mp_mul_digs_fast) /* 51 */
#define TclBN_s_mp_sqr_fast \
(tclTomMathStubsPtr->tclBN_s_mp_sqr_fast) /* 52 */
#define TclBN_mp_karatsuba_mul \
(tclTomMathStubsPtr->tclBN_mp_karatsuba_mul) /* 53 */
#define TclBN_mp_karatsuba_sqr \
(tclTomMathStubsPtr->tclBN_mp_karatsuba_sqr) /* 54 */
#define TclBN_mp_toom_mul \
(tclTomMathStubsPtr->tclBN_mp_toom_mul) /* 55 */
#define TclBN_mp_toom_sqr \
(tclTomMathStubsPtr->tclBN_mp_toom_sqr) /* 56 */
#define TclBN_s_mp_add \
(tclTomMathStubsPtr->tclBN_s_mp_add) /* 57 */
#define TclBN_s_mp_mul_digs \
(tclTomMathStubsPtr->tclBN_s_mp_mul_digs) /* 58 */
#define TclBN_s_mp_sqr \
(tclTomMathStubsPtr->tclBN_s_mp_sqr) /* 59 */
#define TclBN_s_mp_sub \
(tclTomMathStubsPtr->tclBN_s_mp_sub) /* 60 */
#define TclBN_mp_init_ul \
(tclTomMathStubsPtr->tclBN_mp_init_ul) /* 61 */
#define TclBN_mp_set_ul \
(tclTomMathStubsPtr->tclBN_mp_set_ul) /* 62 */
#define TclBN_mp_cnt_lsb \
(tclTomMathStubsPtr->tclBN_mp_cnt_lsb) /* 63 */
#define TclBN_mp_init_l \
(tclTomMathStubsPtr->tclBN_mp_init_l) /* 64 */
#define TclBN_mp_init_i64 \
(tclTomMathStubsPtr->tclBN_mp_init_i64) /* 65 */
#define TclBN_mp_init_u64 \
(tclTomMathStubsPtr->tclBN_mp_init_u64) /* 66 */
#define TclBN_mp_expt_d_ex \
(tclTomMathStubsPtr->tclBN_mp_expt_d_ex) /* 67 */
#define TclBN_mp_set_u64 \
(tclTomMathStubsPtr->tclBN_mp_set_u64) /* 68 */
#define TclBN_mp_get_mag_u64 \
(tclTomMathStubsPtr->tclBN_mp_get_mag_u64) /* 69 */
#define TclBN_mp_set_i64 \
(tclTomMathStubsPtr->tclBN_mp_set_i64) /* 70 */
/* Slot 71 is reserved */
/* Slot 72 is reserved */
#define TclBN_mp_tc_and \
(tclTomMathStubsPtr->tclBN_mp_tc_and) /* 73 */
#define TclBN_mp_tc_or \
(tclTomMathStubsPtr->tclBN_mp_tc_or) /* 74 */
#define TclBN_mp_tc_xor \
(tclTomMathStubsPtr->tclBN_mp_tc_xor) /* 75 */
#define TclBN_mp_signed_rsh \
(tclTomMathStubsPtr->tclBN_mp_signed_rsh) /* 76 */
/* Slot 77 is reserved */
#define TclBN_mp_to_ubin \
(tclTomMathStubsPtr->tclBN_mp_to_ubin) /* 78 */
#define TclBN_mp_div_ld \
(tclTomMathStubsPtr->tclBN_mp_div_ld) /* 79 */
#define TclBN_mp_to_radix \
(tclTomMathStubsPtr->tclBN_mp_to_radix) /* 80 */
#endif /* defined(USE_TCL_STUBS) */
/* !END!: Do not edit above this line. */
#if defined(USE_TCL_STUBS)
#undef mp_add_d
#define mp_add_d TclBN_mp_add_d
#undef mp_cmp_d
#define mp_cmp_d TclBN_mp_cmp_d
#undef mp_div_d
#ifdef MP_64BIT
#define mp_div_d TclBN_mp_div_ld
#else
#define mp_div_d TclBN_mp_div_d
#endif
#undef mp_sub_d
#define mp_sub_d TclBN_mp_sub_d
#undef mp_init_set
#define mp_init_set TclBN_mp_init_set
#undef mp_mul_d
#define mp_mul_d TclBN_mp_mul_d
#undef mp_set
#define mp_set TclBN_mp_set
#undef mp_expt_u32
#define mp_expt_u32 TclBN_mp_expt_u32
#endif /* USE_TCL_STUBS */
#define TclBNInitBignumFromLong(a,b) \
do { \
(a)->dp = NULL; \
(void)mp_init_i64((a),(b)); \
if ((a)->dp == NULL) { \
Tcl_Panic("initialization failure in TclBNInitBignumFromLong"); \
} \
} while (0)
#undef TclBNInitBignumFromWideInt
#define TclBNInitBignumFromWideInt(a,b) \
do { \
(a)->dp = NULL; \
(void)mp_init_i64((a),(b)); \
if ((a)->dp == NULL) { \
Tcl_Panic("initialization failure in TclBNInitBignumFromWideInt"); \
} \
} while (0)
#undef TclBNInitBignumFromWideUInt
#define TclBNInitBignumFromWideUInt(a,b) \
do { \
(a)->dp = NULL; \
(void)mp_init_u64((a),(b)); \
if ((a)->dp == NULL) { \
Tcl_Panic("initialization failure in TclBNInitBignumFromWideUInt"); \
} \
} while (0)
#undef mp_get_ll
#define mp_get_ll(a) ((long long)mp_get_i64(a))
#undef mp_set_ll
#define mp_set_ll(a,b) mp_set_i64(a,b)
#undef mp_init_ll
#define mp_init_ll(a,b) mp_init_i64(a,b)
#undef mp_get_ull
#define mp_get_ull(a) ((unsigned long long)mp_get_i64(a))
#undef mp_set_ull
#define mp_set_ull(a,b) mp_set_u64(a,b)
#undef mp_init_ull
#define mp_init_ull(a,b) mp_init_u64(a,b)
#undef mp_set
#define mp_set(a,b) mp_set_i64((a),(int32_t)(b))
#define mp_set_i32(a,b) mp_set_i64((a),(int32_t)(b))
#define mp_set_l(a,b) mp_set_i64((a),(long)(b))
#define mp_set_u32(a,b) mp_set_u64((a),(uint32_t)(b))
#define mp_set_ul(a,b) mp_set_u64((a),(unsigned long)(b))
#define mp_init_i32(a,b) mp_init_i64((a),(int32_t)(b))
#define mp_init_l(a,b) mp_init_i64((a),(long)(b))
#define mp_init_u32(a,b) mp_init_u64((a),(uint32_t)(b))
#define mp_init_ul(a,b) mp_init_u64((a),(unsigned long)(b))
#undef mp_iseven
#undef mp_isodd
#define mp_iseven(a) (!mp_isodd(a))
#define mp_isodd(a) (((a)->used != 0) && (((a)->dp[0] & 1) != 0))
#undef mp_sqr
#define mp_sqr(a,b) mp_mul(a,a,b)
#undef TCL_STORAGE_CLASS
#define TCL_STORAGE_CLASS DLLIMPORT
#endif /* _TCLINTDECLS */
|
Changes to generic/tclTomMathInterface.c.
| ︙ | ︙ | |||
9 10 11 12 13 14 15 | * Copyright (c) 2005 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. */ #include "tclInt.h" | | | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * Copyright (c) 2005 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. */ #include "tclInt.h" #include "tclTomMath.h" MODULE_SCOPE const TclTomMathStubs tclTomMathStubs; /* *---------------------------------------------------------------------- * * TclTommath_Init -- |
| ︙ | ︙ | |||
85 86 87 88 89 90 91 |
*/
int
TclBN_revision(void)
{
return TCLTOMMATH_REVISION;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 |
*/
int
TclBN_revision(void)
{
return TCLTOMMATH_REVISION;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclTomMathStubLib.c.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 15 16 17 18 19 20 21 | * Copyright (c) 1998 Paul Duffin. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" MODULE_SCOPE const TclTomMathStubs *tclTomMathStubsPtr; const TclTomMathStubs *tclTomMathStubsPtr = NULL; /* | > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | * Copyright (c) 1998 Paul Duffin. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclTomMath.h" MODULE_SCOPE const TclTomMathStubs *tclTomMathStubsPtr; const TclTomMathStubs *tclTomMathStubsPtr = NULL; /* |
| ︙ | ︙ |
Changes to generic/tclTrace.c.
| ︙ | ︙ | |||
75 76 77 78 79 80 81 | * TCL_TRACE_ANY_EXEC - OR'd combination of all EXEC flags. * TCL_TRACE_EXEC_IN_PROGRESS - The callback function on this trace is * currently executing. Therefore we don't let * further traces execute. * TCL_TRACE_EXEC_DIRECT - This execution trace is triggered directly * by the command being traced, not because of * an internal trace. | < | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 | * TCL_TRACE_ANY_EXEC - OR'd combination of all EXEC flags. * TCL_TRACE_EXEC_IN_PROGRESS - The callback function on this trace is * currently executing. Therefore we don't let * further traces execute. * TCL_TRACE_EXEC_DIRECT - This execution trace is triggered directly * by the command being traced, not because of * an internal trace. * The flag 'TCL_TRACE_DESTROYED' may also be used in command execution traces. */ #define TCL_TRACE_ENTER_DURING_EXEC 4 #define TCL_TRACE_LEAVE_DURING_EXEC 8 #define TCL_TRACE_ANY_EXEC 15 #define TCL_TRACE_EXEC_IN_PROGRESS 0x10 #define TCL_TRACE_EXEC_DIRECT 0x20 |
| ︙ | ︙ | |||
117 118 119 120 121 122 123 | }; /* * Declarations for local functions to this file: */ static int CallTraceFunction(Tcl_Interp *interp, Trace *tracePtr, | | | | 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 |
};
/*
* Declarations for local functions to this file:
*/
static int CallTraceFunction(Tcl_Interp *interp, Trace *tracePtr,
Command *cmdPtr, const char *command, int numChars,
int objc, Tcl_Obj *const objv[]);
static char * TraceVarProc(ClientData clientData, Tcl_Interp *interp,
const char *name1, const char *name2, int flags);
static void TraceCommandProc(ClientData clientData,
Tcl_Interp *interp, const char *oldName,
const char *newName, int flags);
static Tcl_CmdObjTraceProc TraceExecutionProc;
static int StringTraceProc(ClientData clientData,
Tcl_Interp *interp, int level,
const char *command, Tcl_Command commandInfo,
int objc, Tcl_Obj *const objv[]);
static void StringTraceDeleteProc(ClientData clientData);
static void DisposeTraceResult(int flags, char *result);
static int TraceVarEx(Tcl_Interp *interp, const char *part1,
const char *part2, VarTrace *tracePtr);
/*
* The following structure holds the client data for string-based
* trace procs
*/
typedef struct {
|
| ︙ | ︙ | |||
178 179 180 181 182 183 184 | * A standard Tcl result. * * Side effects: * See the user documentation. *---------------------------------------------------------------------- */ | < | | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 |
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*----------------------------------------------------------------------
*/
int
Tcl_TraceObjCmd(
TCL_UNUSED(ClientData),
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;
|
| ︙ | ︙ | |||
267 268 269 270 271 272 273 |
}
#ifndef TCL_REMOVE_OBSOLETE_TRACES
case TRACE_OLD_VARIABLE:
case TRACE_OLD_VDELETE: {
Tcl_Obj *copyObjv[6];
Tcl_Obj *opsList;
| | < | 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 |
}
#ifndef TCL_REMOVE_OBSOLETE_TRACES
case TRACE_OLD_VARIABLE:
case TRACE_OLD_VDELETE: {
Tcl_Obj *copyObjv[6];
Tcl_Obj *opsList;
int code, numFlags;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "name ops command");
return TCL_ERROR;
}
opsList = Tcl_NewObj();
|
| ︙ | ︙ | |||
320 321 322 323 324 325 326 |
Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
resultListPtr = Tcl_NewObj();
| | | | 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 |
Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
resultListPtr = Tcl_NewObj();
name = Tcl_GetString(objv[2]);
FOREACH_VAR_TRACE(interp, name, clientData) {
TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData;
char *q = ops;
pairObjPtr = Tcl_NewListObj(0, NULL);
if (tvarPtr->flags & TCL_TRACE_READS) {
*q = 'r';
q++;
}
|
| ︙ | ︙ | |||
400 401 402 403 404 405 406 |
static int
TraceExecutionObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
int optionIndex, /* Add, info or remove */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 |
static int
TraceExecutionObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
int optionIndex, /* Add, info or remove */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int commandLength, index;
const char *name, *command;
size_t length;
enum traceOptions {
TRACE_ADD, TRACE_INFO, TRACE_REMOVE
};
static const char *const opStrings[] = {
"enter", "leave", "enterstep", "leavestep", NULL
};
enum operations {
|
| ︙ | ︙ | |||
464 465 466 467 468 469 470 | break; case TRACE_EXEC_LEAVE_STEP: flags |= TCL_TRACE_LEAVE_DURING_EXEC; break; } } command = TclGetStringFromObj(objv[5], &commandLength); | | | | | | | | | | | | | 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 |
break;
case TRACE_EXEC_LEAVE_STEP:
flags |= TCL_TRACE_LEAVE_DURING_EXEC;
break;
}
}
command = TclGetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)ckalloc(
offsetof(TraceCommandInfo, command) + 1 + length);
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
tcmdPtr->startLevel = 0;
tcmdPtr->startCmd = NULL;
tcmdPtr->length = length;
tcmdPtr->refCount = 1;
flags |= TCL_TRACE_DELETE;
if (flags & (TCL_TRACE_ENTER_DURING_EXEC |
TCL_TRACE_LEAVE_DURING_EXEC)) {
flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
}
memcpy(tcmdPtr->command, command, length+1);
name = Tcl_GetString(objv[3]);
if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
tcmdPtr) != TCL_OK) {
ckfree(tcmdPtr);
return TCL_ERROR;
}
} else {
/*
* Search through all of our traces on this command to see if
* there's one with the given command. If so, then delete the
* first one that matches.
*/
ClientData clientData;
/*
* First ensure the name given is valid.
*/
name = Tcl_GetString(objv[3]);
if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
FOREACH_COMMAND_TRACE(interp, name, clientData) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
/*
* In checking the 'flags' field we must remove any extraneous
* flags which may have been temporarily added by various
* pieces of the trace mechanism.
*/
if ((tcmdPtr->length == length)
&& ((tcmdPtr->flags & (TCL_TRACE_ANY_EXEC |
TCL_TRACE_RENAME | TCL_TRACE_DELETE)) == flags)
&& (strncmp(command, tcmdPtr->command,
(size_t) length) == 0)) {
flags |= TCL_TRACE_DELETE;
if (flags & (TCL_TRACE_ENTER_DURING_EXEC |
TCL_TRACE_LEAVE_DURING_EXEC)) {
flags |= (TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC);
}
Tcl_UntraceCommand(interp, name, flags,
TraceCommandProc, clientData);
if (tcmdPtr->stepTrace != NULL) {
/*
* We need to remove the interpreter-wide trace which
* we created to allow 'step' traces.
*/
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
ckfree(tcmdPtr->startCmd);
}
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
/*
* Postpone deletion.
*/
tcmdPtr->flags = 0;
}
if (tcmdPtr->refCount-- <= 1) {
ckfree(tcmdPtr);
}
break;
}
}
}
break;
}
case TRACE_INFO: {
ClientData clientData;
Tcl_Obj *resultListPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
name = Tcl_GetString(objv[3]);
/*
* First ensure the name given is valid.
*/
if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
resultListPtr = Tcl_NewListObj(0, NULL);
FOREACH_COMMAND_TRACE(interp, name, clientData) {
int numOps = 0;
Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
/*
* Build a list with the ops list as the first obj element and the
* tcmdPtr->command string as the second obj element. Append this
* list (as an element) to the end of the result object list.
*/
|
| ︙ | ︙ | |||
648 649 650 651 652 653 654 |
static int
TraceCommandObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
int optionIndex, /* Add, info or remove */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 |
static int
TraceCommandObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
int optionIndex, /* Add, info or remove */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int commandLength, index;
const char *name, *command;
size_t length;
enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
static const char *const opStrings[] = { "delete", "rename", NULL };
enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME };
switch ((enum traceOptions) optionIndex) {
case TRACE_ADD:
case TRACE_REMOVE: {
|
| ︙ | ︙ | |||
701 702 703 704 705 706 707 | case TRACE_CMD_DELETE: flags |= TCL_TRACE_DELETE; break; } } command = TclGetStringFromObj(objv[5], &commandLength); | | | | | | | | | | | | 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 |
case TRACE_CMD_DELETE:
flags |= TCL_TRACE_DELETE;
break;
}
}
command = TclGetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)ckalloc(
offsetof(TraceCommandInfo, command) + 1 + length);
tcmdPtr->flags = flags;
tcmdPtr->stepTrace = NULL;
tcmdPtr->startLevel = 0;
tcmdPtr->startCmd = NULL;
tcmdPtr->length = length;
tcmdPtr->refCount = 1;
flags |= TCL_TRACE_DELETE;
memcpy(tcmdPtr->command, command, length+1);
name = Tcl_GetString(objv[3]);
if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
tcmdPtr) != TCL_OK) {
ckfree(tcmdPtr);
return TCL_ERROR;
}
} else {
/*
* Search through all of our traces on this command to see if
* there's one with the given command. If so, then delete the
* first one that matches.
*/
ClientData clientData;
/*
* First ensure the name given is valid.
*/
name = Tcl_GetString(objv[3]);
if (Tcl_FindCommand(interp,name,NULL,TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
FOREACH_COMMAND_TRACE(interp, name, clientData) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
if ((tcmdPtr->length == length) && (tcmdPtr->flags == flags)
&& (strncmp(command, tcmdPtr->command,
(size_t) length) == 0)) {
Tcl_UntraceCommand(interp, name, flags | TCL_TRACE_DELETE,
TraceCommandProc, clientData);
tcmdPtr->flags |= TCL_TRACE_DESTROYED;
if (tcmdPtr->refCount-- <= 1) {
ckfree(tcmdPtr);
}
break;
}
}
}
break;
}
case TRACE_INFO: {
ClientData clientData;
Tcl_Obj *resultListPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
/*
* First ensure the name given is valid.
*/
name = Tcl_GetString(objv[3]);
if (Tcl_FindCommand(interp, name, NULL, TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
resultListPtr = Tcl_NewListObj(0, NULL);
FOREACH_COMMAND_TRACE(interp, name, clientData) {
int numOps = 0;
Tcl_Obj *opObj, *eachTraceObjPtr, *elemObjPtr;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
/*
* Build a list with the ops list as the first obj element and the
* tcmdPtr->command string as the second obj element. Append this
* list (as an element) to the end of the result object list.
*/
|
| ︙ | ︙ | |||
842 843 844 845 846 847 848 |
static int
TraceVariableObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
int optionIndex, /* Add, info or remove */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
| | | | 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 |
static int
TraceVariableObjCmd(
Tcl_Interp *interp, /* Current interpreter. */
int optionIndex, /* Add, info or remove */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int commandLength, index;
const char *name, *command;
size_t length;
ClientData clientData;
enum traceOptions { TRACE_ADD, TRACE_INFO, TRACE_REMOVE };
static const char *const opStrings[] = {
"array", "read", "unset", "write", NULL
};
enum operations {
TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, TRACE_VAR_WRITE
|
| ︙ | ︙ | |||
904 905 906 907 908 909 910 | break; case TRACE_VAR_WRITE: flags |= TCL_TRACE_WRITES; break; } } command = TclGetStringFromObj(objv[5], &commandLength); | | | | | | | | | | | 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 |
break;
case TRACE_VAR_WRITE:
flags |= TCL_TRACE_WRITES;
break;
}
}
command = TclGetStringFromObj(objv[5], &commandLength);
length = (size_t) commandLength;
if ((enum traceOptions) optionIndex == TRACE_ADD) {
CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)ckalloc(
offsetof(CombinedTraceVarInfo, traceCmdInfo.command)
+ 1 + length);
ctvarPtr->traceCmdInfo.flags = flags;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
if (objv[0] == NULL) {
ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE;
}
#endif
ctvarPtr->traceCmdInfo.length = length;
flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT;
memcpy(ctvarPtr->traceCmdInfo.command, command, length+1);
ctvarPtr->traceInfo.traceProc = TraceVarProc;
ctvarPtr->traceInfo.clientData = &ctvarPtr->traceCmdInfo;
ctvarPtr->traceInfo.flags = flags;
name = Tcl_GetString(objv[3]);
if (TraceVarEx(interp, name, NULL, (VarTrace *) ctvarPtr)
!= TCL_OK) {
ckfree(ctvarPtr);
return TCL_ERROR;
}
} else {
/*
* Search through all of our traces on this variable to see if
* there's one with the given command. If so, then delete the
* first one that matches.
*/
name = Tcl_GetString(objv[3]);
FOREACH_VAR_TRACE(interp, name, clientData) {
TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData;
if ((tvarPtr->length == length)
&& ((tvarPtr->flags
#ifndef TCL_REMOVE_OBSOLETE_TRACES
& ~TCL_TRACE_OLD_STYLE
#endif
)==flags)
&& (strncmp(command, tvarPtr->command,
(size_t) length) == 0)) {
Tcl_UntraceVar2(interp, name, NULL,
flags | TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT,
TraceVarProc, clientData);
break;
}
}
}
break;
}
case TRACE_INFO: {
Tcl_Obj *resultListPtr;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "name");
return TCL_ERROR;
}
resultListPtr = Tcl_NewObj();
name = Tcl_GetString(objv[3]);
FOREACH_VAR_TRACE(interp, name, clientData) {
Tcl_Obj *opObjPtr, *eachTraceObjPtr, *elemObjPtr;
TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData;
/*
* Build a list with the ops list as the first obj element and the
* tcmdPtr->command string as the second obj element. Append this
* list (as an element) to the end of the result object list.
*/
|
| ︙ | ︙ | |||
1037 1038 1039 1040 1041 1042 1043 |
*----------------------------------------------------------------------
*/
ClientData
Tcl_CommandTraceInfo(
Tcl_Interp *interp, /* Interpreter containing command. */
const char *cmdName, /* Name of command. */
| | < | | 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 |
*----------------------------------------------------------------------
*/
ClientData
Tcl_CommandTraceInfo(
Tcl_Interp *interp, /* Interpreter containing command. */
const char *cmdName, /* Name of command. */
TCL_UNUSED(int) /*flags*/,
Tcl_CommandTraceProc *proc, /* Function assocated with trace. */
ClientData prevClientData) /* If non-NULL, gives last value returned by
* this function, so this call will return the
* next trace after that one. If NULL, this
* call will return the first trace. */
{
Command *cmdPtr;
CommandTrace *tracePtr;
cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL,
TCL_LEAVE_ERR_MSG);
if (cmdPtr == NULL) {
return NULL;
}
|
| ︙ | ︙ | |||
1111 1112 1113 1114 1115 1116 1117 |
* TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any
* of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc, /* Function to call when specified ops are
* invoked upon cmdName. */
ClientData clientData) /* Arbitrary argument to pass to proc. */
{
Command *cmdPtr;
| | | | 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 |
* TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any
* of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc, /* Function to call when specified ops are
* invoked upon cmdName. */
ClientData clientData) /* Arbitrary argument to pass to proc. */
{
Command *cmdPtr;
CommandTrace *tracePtr;
cmdPtr = (Command *) Tcl_FindCommand(interp, cmdName, NULL,
TCL_LEAVE_ERR_MSG);
if (cmdPtr == NULL) {
return TCL_ERROR;
}
/*
* Set up trace information.
*/
tracePtr = (CommandTrace *)ckalloc(sizeof(CommandTrace));
tracePtr->traceProc = proc;
tracePtr->clientData = clientData;
tracePtr->flags = flags &
(TCL_TRACE_RENAME | TCL_TRACE_DELETE | TCL_TRACE_ANY_EXEC);
tracePtr->nextPtr = cmdPtr->tracePtr;
tracePtr->refCount = 1;
cmdPtr->tracePtr = tracePtr;
|
| ︙ | ︙ | |||
1174 1175 1176 1177 1178 1179 1180 |
const char *cmdName, /* Name of command. */
int flags, /* OR-ed collection of bits, including any of
* TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any
* of the TRACE_*_EXEC flags */
Tcl_CommandTraceProc *proc, /* Function assocated with trace. */
ClientData clientData) /* Arbitrary argument to pass to proc. */
{
| | | 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 |
const char *cmdName, /* Name of command. */
int flags, /* OR-ed collection of bits, including any of
* TCL_TRACE_RENAME, TCL_TRACE_DELETE, and any
* 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,
|
| ︙ | ︙ | |||
1229 1230 1231 1232 1233 1234 1235 |
cmdPtr->tracePtr = tracePtr->nextPtr;
} else {
prevPtr->nextPtr = tracePtr->nextPtr;
}
tracePtr->flags = 0;
if (tracePtr->refCount-- <= 1) {
| | | 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 |
cmdPtr->tracePtr = tracePtr->nextPtr;
} else {
prevPtr->nextPtr = tracePtr->nextPtr;
}
tracePtr->flags = 0;
if (tracePtr->refCount-- <= 1) {
ckfree(tracePtr);
}
if (hasExecTraces) {
for (tracePtr = cmdPtr->tracePtr, prevPtr = NULL; tracePtr != NULL ;
prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
return;
|
| ︙ | ︙ | |||
1276 1277 1278 1279 1280 1281 1282 | * * Side effects: * Depends on the command associated with the trace. * *---------------------------------------------------------------------- */ | < | | | 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 |
*
* Side effects:
* Depends on the command associated with the trace.
*
*----------------------------------------------------------------------
*/
static void
TraceCommandProc(
ClientData clientData, /* Information about the command trace. */
Tcl_Interp *interp, /* Interpreter containing command. */
const char *oldName, /* Name of command being changed. */
const char *newName, /* New name of command. Empty string or NULL
* means command is being deleted (renamed to
* ""). */
int flags) /* OR-ed bits giving operation and other
* information. */
{
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
int code;
Tcl_DString cmd;
tcmdPtr->refCount++;
if ((tcmdPtr->flags & flags) && !Tcl_InterpDeleted(interp)
&& !Tcl_LimitExceeded(interp)) {
/*
* Generate a command to execute by appending list elements for the
* old and new command name and the operation.
*/
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tcmdPtr->command, (int) tcmdPtr->length);
Tcl_DStringAppendElement(&cmd, oldName);
Tcl_DStringAppendElement(&cmd, (newName ? newName : ""));
if (flags & TCL_TRACE_RENAME) {
TclDStringAppendLiteral(&cmd, " rename");
} else if (flags & TCL_TRACE_DELETE) {
TclDStringAppendLiteral(&cmd, " delete");
}
|
| ︙ | ︙ | |||
1344 1345 1346 1347 1348 1349 1350 |
if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) {
int untraceFlags = tcmdPtr->flags;
Tcl_InterpState state;
if (tcmdPtr->stepTrace != NULL) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
| | | 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 |
if (flags & (TCL_TRACE_DESTROYED | TCL_TRACE_DELETE)) {
int untraceFlags = tcmdPtr->flags;
Tcl_InterpState state;
if (tcmdPtr->stepTrace != NULL) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
ckfree(tcmdPtr->startCmd);
}
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
/*
* Postpone deletion, until exec trace returns.
*/
tcmdPtr->flags = 0;
|
| ︙ | ︙ | |||
1386 1387 1388 1389 1390 1391 1392 |
state = Tcl_SaveInterpState(interp, TCL_OK);
Tcl_UntraceCommand(interp, oldName, untraceFlags,
TraceCommandProc, clientData);
Tcl_RestoreInterpState(interp, state);
tcmdPtr->refCount--;
}
if (tcmdPtr->refCount-- <= 1) {
| | | 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 |
state = Tcl_SaveInterpState(interp, TCL_OK);
Tcl_UntraceCommand(interp, oldName, untraceFlags,
TraceCommandProc, clientData);
Tcl_RestoreInterpState(interp, state);
tcmdPtr->refCount--;
}
if (tcmdPtr->refCount-- <= 1) {
ckfree(tcmdPtr);
}
}
/*
*----------------------------------------------------------------------
*
* TclCheckExecutionTraces --
|
| ︙ | ︙ | |||
1420 1421 1422 1423 1424 1425 1426 |
*/
int
TclCheckExecutionTraces(
Tcl_Interp *interp, /* The current interpreter. */
const char *command, /* Pointer to beginning of the current command
* string. */
| | < | 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 |
*/
int
TclCheckExecutionTraces(
Tcl_Interp *interp, /* The current interpreter. */
const char *command, /* Pointer to beginning of the current command
* string. */
TCL_UNUSED(int) /*numChars*/,
Command *cmdPtr, /* Points to command's Command struct. */
int code, /* The current result code. */
int traceFlags, /* Current tracing situation. */
int objc, /* Number of arguments for the command. */
Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
|
| ︙ | ︙ | |||
1466 1467 1468 1469 1470 1471 1472 |
tracePtr = tracePtr->nextPtr;
}
} else {
active.reverseScan = 0;
active.nextTracePtr = tracePtr->nextPtr;
}
if (tracePtr->traceProc == TraceCommandProc) {
| | | | 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 |
tracePtr = tracePtr->nextPtr;
}
} else {
active.reverseScan = 0;
active.nextTracePtr = tracePtr->nextPtr;
}
if (tracePtr->traceProc == TraceCommandProc) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)tracePtr->clientData;
if (tcmdPtr->flags != 0) {
tcmdPtr->curFlags = traceFlags | TCL_TRACE_EXEC_DIRECT;
tcmdPtr->curCode = code;
tcmdPtr->refCount++;
if (state == NULL) {
state = Tcl_SaveInterpState(interp, code);
}
traceCode = TraceExecutionProc(tcmdPtr, interp, curLevel,
command, (Tcl_Command) cmdPtr, objc, objv);
if (tcmdPtr->refCount-- <= 1) {
ckfree(tcmdPtr);
}
}
}
if (active.nextTracePtr) {
lastTracePtr = active.nextTracePtr->nextPtr;
}
}
|
| ︙ | ︙ | |||
1526 1527 1528 1529 1530 1531 1532 |
*/
int
TclCheckInterpTraces(
Tcl_Interp *interp, /* The current interpreter. */
const char *command, /* Pointer to beginning of the current command
* string. */
| | | 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 |
*/
int
TclCheckInterpTraces(
Tcl_Interp *interp, /* The current interpreter. */
const char *command, /* Pointer to beginning of the current command
* string. */
int numChars, /* The number of characters in 'command' which
* are part of the command string. */
Command *cmdPtr, /* Points to command's Command struct. */
int code, /* The current result code. */
int traceFlags, /* Current tracing situation. */
int objc, /* Number of arguments for the command. */
Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */
{
|
| ︙ | ︙ | |||
1607 1608 1609 1610 1611 1612 1613 |
(TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) {
/*
* New style trace.
*/
if (tracePtr->flags & traceFlags) {
if (tracePtr->proc == TraceExecutionProc) {
| | | 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 |
(TCL_TRACE_ENTER_EXEC | TCL_TRACE_LEAVE_EXEC)) {
/*
* New style trace.
*/
if (tracePtr->flags & traceFlags) {
if (tracePtr->proc == TraceExecutionProc) {
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)tracePtr->clientData;
tcmdPtr->curFlags = traceFlags;
tcmdPtr->curCode = code;
}
traceCode = tracePtr->proc(tracePtr->clientData, interp,
curLevel, command, (Tcl_Command) cmdPtr, objc,
objv);
|
| ︙ | ︙ | |||
1669 1670 1671 1672 1673 1674 1675 |
*
*----------------------------------------------------------------------
*/
static int
CallTraceFunction(
Tcl_Interp *interp, /* The current interpreter. */
| | | | | | 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 |
*
*----------------------------------------------------------------------
*/
static int
CallTraceFunction(
Tcl_Interp *interp, /* The current interpreter. */
Trace *tracePtr, /* Describes the trace function to call. */
Command *cmdPtr, /* Points to command's Command struct. */
const char *command, /* Points to the first character of the
* command's source before substitutions. */
int numChars, /* The number of characters in the command's
* source. */
int objc, /* Number of arguments for the command. */
Tcl_Obj *const objv[]) /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
char *commandCopy;
int traceCode;
/*
* Copy the command characters into a new string.
*/
commandCopy = (char *)TclStackAlloc(interp, numChars + 1);
memcpy(commandCopy, command, numChars);
commandCopy[numChars] = '\0';
/*
* Call the trace function then free allocated storage.
*/
|
| ︙ | ︙ | |||
1722 1723 1724 1725 1726 1727 1728 |
*----------------------------------------------------------------------
*/
static void
CommandObjTraceDeleted(
ClientData clientData)
{
| | | | 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 |
*----------------------------------------------------------------------
*/
static void
CommandObjTraceDeleted(
ClientData clientData)
{
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
if (tcmdPtr->refCount-- <= 1) {
ckfree(tcmdPtr);
}
}
/*
*----------------------------------------------------------------------
*
* TraceExecutionProc --
|
| ︙ | ︙ | |||
1760 1761 1762 1763 1764 1765 1766 |
static int
TraceExecutionProc(
ClientData clientData,
Tcl_Interp *interp,
int level,
const char *command,
| | | | 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 |
static int
TraceExecutionProc(
ClientData clientData,
Tcl_Interp *interp,
int level,
const char *command,
TCL_UNUSED(Tcl_Command),
int objc,
struct Tcl_Obj *const objv[])
{
int call = 0;
Interp *iPtr = (Interp *) interp;
TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData;
int flags = tcmdPtr->curFlags;
int code = tcmdPtr->curCode;
int traceCode = TCL_OK;
if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
/*
* Inside any kind of execution trace callback, we do not allow any
|
| ︙ | ︙ | |||
1807 1808 1809 1810 1811 1812 1813 |
*/
if ((flags & TCL_TRACE_LEAVE_EXEC) && (tcmdPtr->stepTrace != NULL)
&& (level == tcmdPtr->startLevel)
&& (strcmp(command, tcmdPtr->startCmd) == 0)) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
| | | | | 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 |
*/
if ((flags & TCL_TRACE_LEAVE_EXEC) && (tcmdPtr->stepTrace != NULL)
&& (level == tcmdPtr->startLevel)
&& (strcmp(command, tcmdPtr->startCmd) == 0)) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
ckfree(tcmdPtr->startCmd);
}
/*
* Second, create the tcl callback, if required.
*/
if (call) {
Tcl_DString cmd, sub;
int i, saveInterpFlags;
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tcmdPtr->command, (int)tcmdPtr->length);
/*
* Append command with arguments.
*/
Tcl_DStringInit(&sub);
for (i = 0; i < objc; i++) {
Tcl_DStringAppendElement(&sub, Tcl_GetString(objv[i]));
}
Tcl_DStringAppendElement(&cmd, Tcl_DStringValue(&sub));
Tcl_DStringFree(&sub);
if (flags & TCL_TRACE_ENTER_EXEC) {
/*
* Append trace operation.
|
| ︙ | ︙ | |||
1851 1852 1853 1854 1855 1856 1857 | const char *resultCodeStr; /* * Append result code. */ resultCode = Tcl_NewIntObj(code); | | | 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 | const char *resultCodeStr; /* * Append result code. */ resultCode = Tcl_NewIntObj(code); resultCodeStr = Tcl_GetString(resultCode); Tcl_DStringAppendElement(&cmd, resultCodeStr); Tcl_DecrRefCount(resultCode); /* * Append result string. */ |
| ︙ | ︙ | |||
1917 1918 1919 1920 1921 1922 1923 |
* string in startLevel and startCmd so that we can delete this
* interpreter trace when it reaches the end of this proc.
*/
if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL)
&& (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC |
TCL_TRACE_LEAVE_DURING_EXEC))) {
| | | | | | 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 |
* string in startLevel and startCmd so that we can delete this
* interpreter trace when it reaches the end of this proc.
*/
if ((flags & TCL_TRACE_ENTER_EXEC) && (tcmdPtr->stepTrace == NULL)
&& (tcmdPtr->flags & (TCL_TRACE_ENTER_DURING_EXEC |
TCL_TRACE_LEAVE_DURING_EXEC))) {
unsigned len = strlen(command) + 1;
tcmdPtr->startLevel = level;
tcmdPtr->startCmd = (char *)ckalloc(len);
memcpy(tcmdPtr->startCmd, command, len);
tcmdPtr->refCount++;
tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0,
(tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2,
TraceExecutionProc, tcmdPtr, CommandObjTraceDeleted);
}
}
if (flags & TCL_TRACE_DESTROYED) {
if (tcmdPtr->stepTrace != NULL) {
Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
tcmdPtr->stepTrace = NULL;
ckfree(tcmdPtr->startCmd);
}
}
if (call) {
if (tcmdPtr->refCount-- <= 1) {
ckfree(tcmdPtr);
}
}
return traceCode;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1961 1962 1963 1964 1965 1966 1967 | * * Side effects: * Depends on the command associated with the trace. * *---------------------------------------------------------------------- */ | < | | | | 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 |
*
* Side effects:
* Depends on the command associated with the trace.
*
*----------------------------------------------------------------------
*/
static char *
TraceVarProc(
ClientData clientData, /* Information about the variable trace. */
Tcl_Interp *interp, /* Interpreter containing variable. */
const char *name1, /* Name of variable or array. */
const char *name2, /* Name of element within array; NULL means
* scalar variable is being referenced. */
int flags) /* OR-ed bits giving operation and other
* information. */
{
TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData;
char *result;
int code, destroy = 0;
Tcl_DString cmd;
int rewind = ((Interp *)interp)->execEnvPtr->rewind;
/*
* We might call Tcl_Eval() below, and that might evaluate [trace vdelete]
* which might try to free tvarPtr. We want to use tvarPtr until the end
* of this function, so we use Tcl_Preserve() and Tcl_Release() to be sure
* it is not freed while we still need it.
*/
result = NULL;
if ((tvarPtr->flags & flags) && !Tcl_InterpDeleted(interp)
&& !Tcl_LimitExceeded(interp)) {
if (tvarPtr->length != (size_t) 0) {
/*
* Generate a command to execute by appending list elements for
* the two variable names and the operation.
*/
Tcl_DStringInit(&cmd);
Tcl_DStringAppend(&cmd, tvarPtr->command, (int) tvarPtr->length);
Tcl_DStringAppendElement(&cmd, name1);
Tcl_DStringAppendElement(&cmd, (name2 ? name2 : ""));
#ifndef TCL_REMOVE_OBSOLETE_TRACES
if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) {
if (flags & TCL_TRACE_ARRAY) {
TclDStringAppendLiteral(&cmd, " a");
} else if (flags & TCL_TRACE_READS) {
|
| ︙ | ︙ | |||
2062 2063 2064 2065 2066 2067 2068 |
Tcl_IncrRefCount(errMsgObj);
result = (char *) errMsgObj;
}
Tcl_DStringFree(&cmd);
}
}
if (destroy && result != NULL) {
| | | 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 |
Tcl_IncrRefCount(errMsgObj);
result = (char *) errMsgObj;
}
Tcl_DStringFree(&cmd);
}
}
if (destroy && result != NULL) {
Tcl_Obj *errMsgObj = (Tcl_Obj *) result;
Tcl_DecrRefCount(errMsgObj);
result = NULL;
}
return result;
}
|
| ︙ | ︙ | |||
2139 2140 2141 2142 2143 2144 2145 |
int level, /* Maximum nesting level */
int flags, /* Flags, see above */
Tcl_CmdObjTraceProc *proc, /* Trace callback */
ClientData clientData, /* Client data for the callback */
Tcl_CmdObjTraceDeleteProc *delProc)
/* Function to call when trace is deleted */
{
| | | | 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 |
int level, /* Maximum nesting level */
int flags, /* Flags, see above */
Tcl_CmdObjTraceProc *proc, /* Trace callback */
ClientData clientData, /* Client data for the callback */
Tcl_CmdObjTraceDeleteProc *delProc)
/* Function to call when trace is deleted */
{
Trace *tracePtr;
Interp *iPtr = (Interp *) interp;
/*
* Test if this trace allows inline compilation of commands.
*/
if (!(flags & TCL_ALLOW_INLINE_COMPILATION)) {
if (iPtr->tracesForbiddingInline == 0) {
|
| ︙ | ︙ | |||
2164 2165 2166 2167 2168 2169 2170 |
iPtr->compileEpoch++;
iPtr->flags |= DONT_COMPILE_CMDS_INLINE;
}
iPtr->tracesForbiddingInline++;
}
| | | 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 |
iPtr->compileEpoch++;
iPtr->flags |= DONT_COMPILE_CMDS_INLINE;
}
iPtr->tracesForbiddingInline++;
}
tracePtr = (Trace *)ckalloc(sizeof(Trace));
tracePtr->level = level;
tracePtr->proc = proc;
tracePtr->clientData = clientData;
tracePtr->delProc = delProc;
tracePtr->nextPtr = iPtr->tracePtr;
tracePtr->flags = flags;
iPtr->tracePtr = tracePtr;
|
| ︙ | ︙ | |||
2227 2228 2229 2230 2231 2232 2233 |
Tcl_Interp *interp, /* Interpreter in which to create trace. */
int level, /* Only call proc for commands at nesting
* level<=argument level (1=>top level). */
Tcl_CmdTraceProc *proc, /* Function to call before executing each
* command. */
ClientData clientData) /* Arbitrary value word to pass to proc. */
{
| | | 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 |
Tcl_Interp *interp, /* Interpreter in which to create trace. */
int level, /* Only call proc for commands at nesting
* level<=argument level (1=>top level). */
Tcl_CmdTraceProc *proc, /* Function to call before executing each
* command. */
ClientData clientData) /* Arbitrary value word to pass to proc. */
{
StringTraceData *data = (StringTraceData *)ckalloc(sizeof(StringTraceData));
data->clientData = clientData;
data->proc = proc;
return Tcl_CreateObjTrace(interp, level, 0, StringTraceProc,
data, StringTraceDeleteProc);
}
|
| ︙ | ︙ | |||
2261 2262 2263 2264 2265 2266 2267 |
Tcl_Interp *interp,
int level,
const char *command,
Tcl_Command commandInfo,
int objc,
Tcl_Obj *const *objv)
{
| | | | 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 |
Tcl_Interp *interp,
int level,
const char *command,
Tcl_Command commandInfo,
int objc,
Tcl_Obj *const *objv)
{
StringTraceData *data = (StringTraceData *)clientData;
Command *cmdPtr = (Command *) commandInfo;
const char **argv; /* Args to pass to string trace proc */
int i;
/*
* This is a bit messy because we have to emulate the old trace interface,
* which uses strings for everything.
*/
argv = (const char **) TclStackAlloc(interp,
(objc + 1) * sizeof(const char *));
for (i = 0; i < objc; i++) {
argv[i] = Tcl_GetString(objv[i]);
}
argv[objc] = 0;
/*
* Invoke the command function. Note that we cast away const-ness on two
* parameters for compatibility with legacy code; the code MUST NOT modify
* either command or argv.
|
| ︙ | ︙ | |||
2311 2312 2313 2314 2315 2316 2317 |
*----------------------------------------------------------------------
*/
static void
StringTraceDeleteProc(
ClientData clientData)
{
| | | 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 |
*----------------------------------------------------------------------
*/
static void
StringTraceDeleteProc(
ClientData clientData)
{
ckfree(clientData);
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteTrace --
*
|
| ︙ | ︙ | |||
2339 2340 2341 2342 2343 2344 2345 |
Tcl_DeleteTrace(
Tcl_Interp *interp, /* Interpreter that contains trace. */
Tcl_Trace trace) /* Token for trace (returned previously by
* Tcl_CreateTrace). */
{
Interp *iPtr = (Interp *) interp;
Trace *prevPtr, *tracePtr = (Trace *) trace;
| | | 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 |
Tcl_DeleteTrace(
Tcl_Interp *interp, /* Interpreter that contains trace. */
Tcl_Trace trace) /* Token for trace (returned previously by
* Tcl_CreateTrace). */
{
Interp *iPtr = (Interp *) interp;
Trace *prevPtr, *tracePtr = (Trace *) trace;
Trace **tracePtr2 = &iPtr->tracePtr;
ActiveInterpTrace *activePtr;
/*
* Locate the trace entry in the interpreter's trace list, and remove it
* from the list.
*/
|
| ︙ | ︙ | |||
2531 2532 2533 2534 2535 2536 2537 |
*
*----------------------------------------------------------------------
*/
int
TclObjCallVarTraces(
Interp *iPtr, /* Interpreter containing variable. */
| | | 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 |
*
*----------------------------------------------------------------------
*/
int
TclObjCallVarTraces(
Interp *iPtr, /* Interpreter containing variable. */
Var *arrayPtr, /* Pointer to array variable that contains the
* variable, or NULL if the variable isn't an
* element of an array. */
Var *varPtr, /* Variable whose traces are to be invoked. */
Tcl_Obj *part1Ptr,
Tcl_Obj *part2Ptr, /* Variable's two-part name. */
int flags, /* Flags passed to trace functions: indicates
* what's happening to variable, plus maybe
|
| ︙ | ︙ | |||
2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 |
part1 = TclGetString(part1Ptr);
part2 = part2Ptr? TclGetString(part2Ptr) : NULL;
return TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags,
leaveErrMsg);
}
int
TclCallVarTraces(
Interp *iPtr, /* Interpreter containing variable. */
| > > > | | | 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 |
part1 = TclGetString(part1Ptr);
part2 = part2Ptr? TclGetString(part2Ptr) : NULL;
return TclCallVarTraces(iPtr, arrayPtr, varPtr, part1, part2, flags,
leaveErrMsg);
}
#undef TCL_INTERP_DESTROYED
#define TCL_INTERP_DESTROYED 0x100
int
TclCallVarTraces(
Interp *iPtr, /* Interpreter containing variable. */
Var *arrayPtr, /* Pointer to array variable that contains the
* variable, or NULL if the variable isn't an
* element of an array. */
Var *varPtr, /* Variable whose traces are to be invoked. */
const char *part1,
const char *part2, /* Variable's two-part name. */
int flags, /* Flags passed to trace functions: indicates
* what's happening to variable, plus maybe
* TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY */
int leaveErrMsg) /* If true, and one of the traces indicates an
* error, then leave an error message and
* stack trace information in *iPTr. */
{
VarTrace *tracePtr;
ActiveVarTrace active;
char *result;
const char *openParen, *p;
Tcl_DString nameCopy;
int copiedName;
int code = TCL_OK;
int disposeFlags = 0;
|
| ︙ | ︙ | |||
2659 2660 2661 2662 2663 2664 2665 |
active.nextPtr = iPtr->activeVarTracePtr;
iPtr->activeVarTracePtr = &active;
Tcl_Preserve(iPtr);
if (arrayPtr && !TclIsVarTraceActive(arrayPtr)
&& (arrayPtr->flags & traceflags)) {
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) arrayPtr);
active.varPtr = arrayPtr;
| | | 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 |
active.nextPtr = iPtr->activeVarTracePtr;
iPtr->activeVarTracePtr = &active;
Tcl_Preserve(iPtr);
if (arrayPtr && !TclIsVarTraceActive(arrayPtr)
&& (arrayPtr->flags & traceflags)) {
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) arrayPtr);
active.varPtr = arrayPtr;
for (tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr);
tracePtr != NULL; tracePtr = active.nextTracePtr) {
active.nextTracePtr = tracePtr->nextPtr;
if (!(tracePtr->flags & flags)) {
continue;
}
Tcl_Preserve(tracePtr);
if (state == NULL) {
|
| ︙ | ︙ | |||
2703 2704 2705 2706 2707 2708 2709 |
if (flags & TCL_TRACE_UNSETS) {
flags |= TCL_TRACE_DESTROYED;
}
active.varPtr = varPtr;
if (varPtr->flags & traceflags) {
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
| | | 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 |
if (flags & TCL_TRACE_UNSETS) {
flags |= TCL_TRACE_DESTROYED;
}
active.varPtr = varPtr;
if (varPtr->flags & traceflags) {
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
for (tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr);
tracePtr != NULL; tracePtr = active.nextTracePtr) {
active.nextTracePtr = tracePtr->nextPtr;
if (!(tracePtr->flags & flags)) {
continue;
}
Tcl_Preserve(tracePtr);
if (state == NULL) {
|
| ︙ | ︙ | |||
2777 2778 2779 2780 2781 2782 2783 |
Tcl_AppendObjToErrorInfo((Tcl_Interp *)iPtr, Tcl_ObjPrintf(
"\n (%s trace on \"%s%s%s%s\")", type, part1,
(part2 ? "(" : ""), (part2 ? part2 : ""),
(part2 ? ")" : "") ));
if (disposeFlags & TCL_TRACE_RESULT_OBJECT) {
TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb,
| | | 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 |
Tcl_AppendObjToErrorInfo((Tcl_Interp *)iPtr, Tcl_ObjPrintf(
"\n (%s trace on \"%s%s%s%s\")", type, part1,
(part2 ? "(" : ""), (part2 ? part2 : ""),
(part2 ? ")" : "") ));
if (disposeFlags & TCL_TRACE_RESULT_OBJECT) {
TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb,
Tcl_GetString((Tcl_Obj *) result));
} else {
TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, result);
}
iPtr->flags &= ~(ERR_ALREADY_LOGGED);
Tcl_DiscardInterpState(state);
} else {
Tcl_RestoreInterpState((Tcl_Interp *) iPtr, state);
|
| ︙ | ︙ | |||
2836 2837 2838 2839 2840 2841 2842 |
DisposeTraceResult(
int flags, /* Indicates type of result to determine
* proper disposal method. */
char *result) /* The result returned from a trace function
* to be disposed. */
{
if (flags & TCL_TRACE_RESULT_DYNAMIC) {
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
DisposeTraceResult(
int flags, /* Indicates type of result to determine
* proper disposal method. */
char *result) /* The result returned from a trace function
* to be disposed. */
{
if (flags & TCL_TRACE_RESULT_DYNAMIC) {
ckfree(result);
} else if (flags & TCL_TRACE_RESULT_OBJECT) {
Tcl_DecrRefCount((Tcl_Obj *) result);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_UntraceVar --
*
* Remove a previously-created trace for a variable.
*
* Results:
* None.
*
* Side effects:
* If there exists a trace for the variable given by varName with the
* given flags, proc, and clientData, then that trace is removed.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
#undef Tcl_UntraceVar
void
Tcl_UntraceVar(
Tcl_Interp *interp, /* Interpreter containing variable. */
const char *varName, /* Name of variable; may end with "(index)" to
* signify an array reference. */
int flags, /* OR-ed collection of bits describing current
* trace, including any of TCL_TRACE_READS,
* TCL_TRACE_WRITES, TCL_TRACE_UNSETS,
* TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc, /* Function assocated with trace. */
ClientData clientData) /* Arbitrary argument to pass to proc. */
{
Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData);
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_UntraceVar2 --
*
* Remove a previously-created trace for a variable.
*
|
| ︙ | ︙ | |||
2873 2874 2875 2876 2877 2878 2879 |
int flags, /* OR-ed collection of bits describing current
* trace, including any of TCL_TRACE_READS,
* TCL_TRACE_WRITES, TCL_TRACE_UNSETS,
* TCL_GLOBAL_ONLY, and TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc, /* Function assocated with trace. */
ClientData clientData) /* Arbitrary argument to pass to proc. */
{
| | | 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 |
int flags, /* OR-ed collection of bits describing current
* trace, including any of TCL_TRACE_READS,
* TCL_TRACE_WRITES, TCL_TRACE_UNSETS,
* TCL_GLOBAL_ONLY, and TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc, /* Function assocated with trace. */
ClientData clientData) /* Arbitrary argument to pass to proc. */
{
VarTrace *tracePtr;
VarTrace *prevPtr, *nextPtr;
Var *varPtr, *arrayPtr;
Interp *iPtr = (Interp *) interp;
ActiveVarTrace *activePtr;
int flagMask, allFlags = 0;
Tcl_HashEntry *hPtr;
|
| ︙ | ︙ | |||
2906 2907 2908 2909 2910 2911 2912 |
TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
flagMask |= TCL_TRACE_OLD_STYLE;
#endif
flags &= flagMask;
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
| | | 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 |
TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT;
#ifndef TCL_REMOVE_OBSOLETE_TRACES
flagMask |= TCL_TRACE_OLD_STYLE;
#endif
flags &= flagMask;
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
for (tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr), prevPtr = NULL; ;
prevPtr = tracePtr, tracePtr = tracePtr->nextPtr) {
if (tracePtr == NULL) {
goto updateFlags;
}
if ((tracePtr->traceProc == proc) && (tracePtr->flags == flags)
&& (tracePtr->clientData == clientData)) {
break;
|
| ︙ | ︙ | |||
2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 |
TclCleanupVar(varPtr, NULL);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_VarTraceInfo2 --
*
* Same as Tcl_VarTraceInfo, except takes name in two pieces instead of
* one.
*
* Results:
* Same as Tcl_VarTraceInfo.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
TclCleanupVar(varPtr, NULL);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_VarTraceInfo --
*
* Return the clientData value associated with a trace on a variable.
* This function can also be used to step through all of the traces on a
* particular variable that have the same trace function.
*
* Results:
* The return value is the clientData value associated with a trace on
* the given variable. Information will only be returned for a trace with
* proc as trace function. If the clientData argument is NULL then the
* first such trace is returned; otherwise, the next relevant one after
* the one given by clientData will be returned. If the variable doesn't
* exist, or if there are no (more) traces for it, then NULL is returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
#undef Tcl_VarTraceInfo
ClientData
Tcl_VarTraceInfo(
Tcl_Interp *interp, /* Interpreter containing variable. */
const char *varName, /* Name of variable; may end with "(index)" to
* signify an array reference. */
int flags, /* OR-ed combo or TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY (can be 0). */
Tcl_VarTraceProc *proc, /* Function assocated with trace. */
ClientData prevClientData) /* If non-NULL, gives last value returned by
* this function, so this call will return the
* next trace after that one. If NULL, this
* call will return the first trace. */
{
return Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc,
prevClientData);
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_VarTraceInfo2 --
*
* Same as Tcl_VarTraceInfo, except takes name in two pieces instead of
* one.
*
* Results:
* Same as Tcl_VarTraceInfo.
|
| ︙ | ︙ | |||
3022 3023 3024 3025 3026 3027 3028 |
/*
* Find the relevant trace, if any, and return its clientData.
*/
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
if (hPtr) {
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
/*
* Find the relevant trace, if any, and return its clientData.
*/
hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
if (hPtr) {
VarTrace *tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr);
if (prevClientData != NULL) {
for (; tracePtr != NULL; tracePtr = tracePtr->nextPtr) {
if ((tracePtr->clientData == prevClientData)
&& (tracePtr->traceProc == proc)) {
tracePtr = tracePtr->nextPtr;
break;
}
}
}
for (; tracePtr != NULL ; tracePtr = tracePtr->nextPtr) {
if (tracePtr->traceProc == proc) {
return tracePtr->clientData;
}
}
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_TraceVar --
*
* Arrange for reads and/or writes to a variable to cause a function to
* be invoked, which can monitor the operations and/or change their
* actions.
*
* Results:
* A standard Tcl return value.
*
* Side effects:
* A trace is set up on the variable given by varName, such that future
* references to the variable will be intermediated by proc. See the
* manual entry for complete details on the calling sequence for proc.
* The variable's flags are updated.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
#undef Tcl_TraceVar
int
Tcl_TraceVar(
Tcl_Interp *interp, /* Interpreter in which variable is to be
* traced. */
const char *varName, /* Name of variable; may end with "(index)" to
* signify an array reference. */
int flags, /* OR-ed collection of bits, including any of
* TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and
* TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc, /* Function to call when specified ops are
* invoked upon varName. */
ClientData clientData) /* Arbitrary argument to pass to proc. */
{
return Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData);
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_TraceVar2 --
*
* Arrange for reads and/or writes to a variable to cause a function to
* be invoked, which can monitor the operations and/or change their
|
| ︙ | ︙ | |||
3079 3080 3081 3082 3083 3084 3085 |
* TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and
* TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc, /* Function to call when specified ops are
* invoked upon varName. */
ClientData clientData) /* Arbitrary argument to pass to proc. */
{
| | | | | 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 |
* TCL_TRACE_READS, TCL_TRACE_WRITES,
* TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and
* TCL_NAMESPACE_ONLY. */
Tcl_VarTraceProc *proc, /* Function to call when specified ops are
* invoked upon varName. */
ClientData clientData) /* Arbitrary argument to pass to proc. */
{
VarTrace *tracePtr;
int result;
tracePtr = (VarTrace *)ckalloc(sizeof(VarTrace));
tracePtr->traceProc = proc;
tracePtr->clientData = clientData;
tracePtr->flags = flags;
result = TraceVarEx(interp, part1, part2, tracePtr);
if (result != TCL_OK) {
ckfree(tracePtr);
}
return result;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3124 3125 3126 3127 3128 3129 3130 |
TraceVarEx(
Tcl_Interp *interp, /* Interpreter in which variable is to be
* traced. */
const char *part1, /* Name of scalar variable or array. */
const char *part2, /* Name of element within array; NULL means
* trace applies to scalar variable or array
* as-a-whole. */
| | | | 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 |
TraceVarEx(
Tcl_Interp *interp, /* Interpreter in which variable is to be
* traced. */
const char *part1, /* Name of scalar variable or array. */
const char *part2, /* Name of element within array; NULL means
* trace applies to scalar variable or array
* as-a-whole. */
VarTrace *tracePtr)/* Structure containing flags, traceProc and
* clientData fields. Others should be left
* blank. Will be ckfree()d (eventually) if
* this function returns TCL_OK, and up to
* caller to free if this function returns
* TCL_ERROR. */
{
Interp *iPtr = (Interp *) interp;
Var *varPtr, *arrayPtr;
int flagMask, isNew;
|
| ︙ | ︙ | |||
3176 3177 3178 3179 3180 3181 3182 |
#endif
tracePtr->flags = tracePtr->flags & flagMask;
hPtr = Tcl_CreateHashEntry(&iPtr->varTraces, varPtr, &isNew);
if (isNew) {
tracePtr->nextPtr = NULL;
} else {
| | | 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 |
#endif
tracePtr->flags = tracePtr->flags & flagMask;
hPtr = Tcl_CreateHashEntry(&iPtr->varTraces, varPtr, &isNew);
if (isNew) {
tracePtr->nextPtr = NULL;
} else {
tracePtr->nextPtr = (VarTrace *)Tcl_GetHashValue(hPtr);
}
Tcl_SetHashValue(hPtr, tracePtr);
/*
* Mark the variable as traced so we know to call them.
*/
|
| ︙ | ︙ |
Changes to generic/tclUniData.c.
| ︙ | ︙ | |||
37 38 39 40 41 42 43 |
3616, 1824, 1344, 3648, 3680, 3712, 3744, 3776, 3808, 3840, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 3872, 1344, 3904, 3936,
3968, 1344, 4000, 1344, 4032, 4064, 4096, 4128, 4128, 4160, 4192, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 4224, 4256, 1344, 1344, 4288, 4320, 4352,
4384, 4416, 1344, 4448, 4480, 4512, 4544, 1344, 4576, 4608, 4640, 4672,
1344, 4704, 4736, 4768, 4800, 4832, 1344, 4864, 4896, 4928, 4960, 1344,
| | | | | | | | | | | | | | | | | | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 |
3616, 1824, 1344, 3648, 3680, 3712, 3744, 3776, 3808, 3840, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 3872, 1344, 3904, 3936,
3968, 1344, 4000, 1344, 4032, 4064, 4096, 4128, 4128, 4160, 4192, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 4224, 4256, 1344, 1344, 4288, 4320, 4352,
4384, 4416, 1344, 4448, 4480, 4512, 4544, 1344, 4576, 4608, 4640, 4672,
1344, 4704, 4736, 4768, 4800, 4832, 1344, 4864, 4896, 4928, 4960, 1344,
4992, 5024, 5056, 5088, 5120, 1824, 5152, 5184, 5216, 5248, 5280, 5312,
1344, 5344, 1344, 5376, 5408, 5440, 5472, 5504, 5536, 5568, 5600, 5632,
5664, 5696, 5728, 5664, 704, 5760, 224, 224, 224, 224, 5792, 224, 224,
224, 5824, 5856, 5888, 5920, 5952, 5984, 6016, 6048, 6080, 6112, 6144,
6176, 6208, 6240, 6272, 6304, 6336, 6368, 6400, 6432, 6464, 6496, 6528,
6560, 6592, 6592, 6592, 6592, 6592, 6592, 6592, 6592, 6624, 6656, 4928,
6688, 6720, 6752, 6784, 6816, 4928, 6848, 6880, 6912, 6944, 6976, 7008,
7040, 4928, 4928, 4928, 4928, 4928, 7072, 7104, 7136, 4928, 4928, 4928,
7168, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 7200, 7232, 4928, 7264,
7296, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 6592, 6592, 6592,
6592, 7328, 6592, 7360, 7392, 6592, 6592, 6592, 6592, 6592, 6592, 6592,
6592, 4928, 7424, 7456, 7488, 7520, 4928, 4928, 4928, 7552, 7584, 7616,
7648, 224, 224, 224, 7680, 7712, 7744, 1344, 7776, 7808, 7840, 7840,
704, 7872, 7904, 7936, 1824, 7968, 4928, 4928, 8000, 4928, 4928, 4928,
4928, 4928, 4928, 8032, 8064, 8096, 8128, 3232, 1344, 8160, 4192, 1344,
8192, 8224, 8256, 1344, 1344, 8288, 1344, 4928, 8320, 8352, 8384, 8416,
4928, 8384, 8448, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928,
4928, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 4928, 4928, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
|
| ︙ | ︙ | |||
129 130 131 132 133 134 135 |
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
8480, 8512, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
| | | | | | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 |
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
8480, 8512, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 8544, 4928, 8576, 5440, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 8608, 8640, 224, 8672, 8704, 1344, 1344, 8736, 8768, 8800, 224,
8832, 8864, 8896, 8928, 8960, 8992, 9024, 1344, 9056, 9088, 9120, 9152,
9184, 1632, 9216, 9248, 8480, 1952, 9280, 9312, 9344, 1344, 9376, 9408,
9440, 1344, 9472, 9504, 9536, 9568, 9600, 9632, 9664, 9696, 9696, 1344,
9728, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
|
| ︙ | ︙ | |||
163 164 165 166 167 168 169 |
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
| > > > > > > | > > > > > > > > > > > < < < < < < < < < < < < < < < < < | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > | | | | > > > > > > > > > > > > > | | < < < < < | < < | < | | | | > | > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > | > > | > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > > > > > > > | | | > > > > > > | > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > < < < | < < < < < < < < < < < < < < < < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 |
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 9760, 9792, 9824, 9856, 9856, 9856, 9856, 9856, 9856, 9856,
9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856,
9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856,
9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856,
9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856,
9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9856, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888, 9888,
9888, 9888, 9888, 9888, 9888, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 9920, 1344, 1344, 9952, 1824, 9984, 10016,
10048, 1344, 1344, 10080, 10112, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 10144, 10176, 1344, 10208, 1344, 10240, 10272,
10304, 10336, 10368, 10400, 1344, 1344, 1344, 10432, 10464, 64, 10496,
10528, 10560, 4736, 10592, 10624
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
,10656, 10688, 10720, 1824, 1344, 1344, 1344, 10752, 10784, 10816,
10848, 10880, 10912, 10944, 10976, 11008, 1824, 1824, 1824, 1824, 8480,
1344, 11040, 11072, 1344, 11104, 11136, 11168, 11200, 1344, 11232,
1824, 11264, 11296, 11328, 1344, 11360, 11392, 11424, 11456, 1344,
11488, 1344, 11520, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 7808, 4704, 10240, 1824, 1824, 1824,
1824, 11552, 11584, 11616, 11648, 4736, 11680, 1824, 11712, 11744,
11776, 1824, 1824, 1344, 11808, 11840, 6912, 11872, 11904, 11936, 11968,
12000, 1824, 12032, 12064, 1344, 12096, 12128, 12160, 12192, 12224,
1824, 1824, 1344, 1344, 12256, 1824, 12288, 12320, 12352, 12384, 1344,
12416, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 12448,
1344, 12480, 1824, 1824, 12000, 12512, 12544, 1824, 1824, 10176, 12576,
7808, 12608, 12640, 12672, 12704, 5280, 12736, 12768, 12800, 12832,
12864, 12896, 12928, 5280, 12960, 12992, 13024, 13056, 13088, 1824,
1824, 13120, 13152, 13184, 13216, 13248, 13280, 13312, 13344, 1824,
1824, 1824, 1824, 1344, 13376, 13408, 13440, 1344, 13472, 13504, 1824,
1824, 1824, 1824, 1824, 1344, 13536, 13568, 1824, 1344, 13600, 13632,
13664, 1344, 13696, 13728, 1824, 4032, 13760, 1824, 1824, 1824, 1824,
1824, 1824, 1344, 13792, 1824, 1824, 1824, 13824, 13856, 13888, 13920,
13952, 13984, 1824, 1824, 14016, 14048, 14080, 14112, 14144, 14176,
1344, 14208, 14240, 1344, 4608, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 14272, 14304, 14336, 14368, 14400, 14432, 1824, 1824, 14464,
14496, 14528, 14560, 14592, 13728, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 14624, 1824, 1824, 1824, 1824, 1824, 14656, 14688,
14720, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 9952, 1824, 1824, 1824, 10848,
10848, 10848, 14752, 1344, 1344, 1344, 1344, 1344, 1344, 14784, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 14816, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 14848,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 4608, 4736,
14880, 1824, 1824, 10176, 14912, 1344, 14944, 14976, 15008, 15040,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 13824, 13856,
15072, 1824, 1824, 1824, 1344, 1344, 15104, 15136, 15168, 1824, 1824,
15200, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 15232, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 4704, 1824, 12256, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 4736, 1824, 15264,
15296, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 9824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1344, 1344, 1344, 15328, 15360, 15392, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 4928, 4928, 4928, 4928, 4928,
4928, 4928, 8032, 4928, 15424, 4928, 15456, 15488, 15520, 4928, 15552,
4928, 4928, 15584, 1824, 1824, 1824, 1824, 15616, 4928, 4928, 15648,
15680, 1824, 1824, 1824, 1824, 15712, 15744, 15776, 15808, 15840, 15872,
15904, 15936, 15968, 16000, 16032, 16064, 16096, 15712, 15744, 16128,
15808, 16160, 16192, 16224, 15936, 16256, 16288, 16320, 16352, 16384,
16416, 16448, 16480, 16512, 16544, 16576, 4928, 4928, 4928, 4928, 4928,
4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 704,
16608, 704, 16640, 16672, 16704, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
16736, 16768, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 16800, 16832,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344,
16864, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344,
16896, 1824, 16928, 16960, 16992, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 17024, 6912, 17056, 1824, 1824,
17088, 17120, 1824, 1824, 1824, 1824, 1824, 1824, 17152, 17184, 17216,
17248, 17280, 17312, 1824, 17344, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 4928, 17376, 4928, 4928, 8000, 17408, 17440, 8032, 17472,
4928, 4928, 4928, 4928, 17504, 1824, 17536, 17568, 17600, 17632, 17664,
1824, 1824, 1824, 1824, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 17696,
4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928,
4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 4928, 17728,
17760, 4928, 4928, 4928, 8000, 4928, 4928, 17792, 17824, 17376, 4928,
17856, 4928, 17888, 17920, 1824, 1824, 4928, 4928, 4928, 17952, 4928,
4928, 17984, 4928, 4928, 4928, 8000, 18016, 18048, 18080, 18112, 1824,
4928, 4928, 4928, 4928, 18144, 4928, 6880, 18176, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 11360, 1824, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 18208, 1344, 1344, 1344,
1344, 1344, 1344, 11360, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 18240, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
18272, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 11360, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824, 1824,
1824, 1824, 1824, 1824, 1824, 1824, 1824, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344,
1344, 1344, 1344, 1344, 1344, 1792
#endif /* TCL_UTF_MAX > 3 */
};
/*
* The groupMap is indexed by combining the alternate page number with
* the page offset and returns a group number that identifies a unique
* set of character attributes.
|
| ︙ | ︙ | |||
654 655 656 657 658 659 660 |
3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 93, 93, 93, 0, 0, 3, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15,
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 |
3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 93, 93, 93, 0, 0, 3, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 17, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 125, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 93, 125, 93, 15, 125, 125, 125, 93, 93, 93, 93,
93, 93, 93, 93, 125, 125, 125, 125, 93, 125, 125, 15, 93, 93, 93, 93,
93, 93, 93, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 3, 3, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 93, 125, 125, 0, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15,
15, 15, 0, 15, 0, 0, 0, 15, 15, 15, 15, 0, 0, 93, 15, 125, 125, 125,
93, 93, 93, 93, 0, 0, 125, 125, 0, 0, 125, 125, 93, 15, 0, 0, 0, 0,
0, 0, 0, 0, 125, 0, 0, 0, 0, 15, 15, 0, 15, 15, 15, 93, 93, 0, 0, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 4, 4, 18, 18, 18, 18, 18, 18, 14,
4, 15, 3, 93, 0, 0, 93, 93, 125, 0, 15, 15, 15, 15, 15, 15, 0, 0, 0,
0, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15,
0, 15, 15, 0, 15, 15, 0, 15, 15, 0, 0, 93, 0, 125, 125, 125, 93, 93,
0, 0, 0, 0, 93, 93, 0, 0, 93, 93, 93, 0, 0, 0, 93, 0, 0, 0, 0, 0, 0,
0, 15, 15, 15, 15, 0, 15, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 93, 93, 15, 15, 15, 93, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93,
93, 125, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15,
15, 15, 15, 0, 0, 93, 15, 125, 125, 125, 93, 93, 93, 93, 93, 0, 93,
93, 125, 0, 125, 125, 93, 0, 0, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 15, 15, 93, 93, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3,
4, 0, 0, 0, 0, 0, 0, 0, 15, 93, 93, 93, 93, 93, 93, 0, 93, 125, 125,
0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 0, 0, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15,
15, 0, 0, 93, 15, 125, 93, 125, 93, 93, 93, 93, 0, 0, 125, 125, 0,
0, 125, 125, 93, 0, 0, 0, 0, 0, 0, 0, 93, 93, 125, 0, 0, 0, 0, 15,
15, 0, 15, 15, 15, 93, 93, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 14,
15, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 15, 0,
15, 15, 15, 15, 15, 15, 0, 0, 0, 15, 15, 15, 0, 15, 15, 15, 15, 0,
0, 0, 15, 15, 0, 15, 0, 15, 15, 0, 0, 0, 15, 15, 0, 0, 0, 15, 15, 15,
0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0,
125, 125, 93, 125, 125, 0, 0, 0, 125, 125, 125, 0, 125, 125, 125, 93,
0, 0, 15, 0, 0, 0, 0, 0, 0, 125, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 14, 14, 14, 14, 14,
14, 4, 14, 0, 0, 0, 0, 0, 93, 125, 125, 125, 93, 15, 15, 15, 15, 15,
15, 15, 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 15, 93,
93, 93, 125, 125, 125, 125, 0, 93, 93, 93, 0, 93, 93, 93, 93, 0, 0,
0, 0, 0, 0, 0, 93, 93, 0, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, 93, 93,
0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 3, 18, 18,
18, 18, 18, 18, 18, 14, 15, 93, 125, 125, 3, 15, 15, 15, 15, 15, 15,
15, 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 0, 93, 15, 125, 93,
125, 125, 125, 125, 125, 0, 93, 125, 125, 0, 125, 125, 93, 93, 0, 0,
0, 0, 0, 0, 0, 125, 125, 0, 0, 0, 0, 0, 0, 0, 15, 0, 15, 15, 93, 93,
0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 15, 15, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 93, 93, 125, 125, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 15, 125, 125,
125, 93, 93, 93, 93, 0, 125, 125, 125, 0, 125, 125, 125, 93, 15, 14,
0, 0, 0, 0, 15, 15, 15, 125, 18, 18, 18, 18, 18, 18, 18, 15, 15, 15,
93, 93, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18, 18, 18, 18,
18, 18, 18, 14, 15, 15, 15, 15, 15, 15, 0, 93, 125, 125, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 93, 0, 0, 0,
0, 125, 125, 125, 93, 93, 93, 0, 93, 0, 125, 125, 125, 125, 125, 125,
125, 125, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 125,
125, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 93, 15, 15, 93, 93, 93, 93, 93, 93,
93, 0, 0, 0, 0, 4, 15, 15, 15, 15, 15, 15, 92, 93, 93, 93, 93, 93,
93, 93, 93, 3, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 0, 0, 0, 0, 0, 15,
15, 0, 15, 0, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0,
15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 15, 15, 93, 93,
93, 93, 93, 93, 93, 93, 93, 15, 0, 0, 15, 15, 15, 15, 15, 0, 92, 0,
93, 93, 93, 93, 93, 93, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 15,
15, 15, 15, 15, 14, 14, 14, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
3, 3, 14, 3, 14, 14, 14, 93, 93, 14, 14, 14, 14, 14, 14, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 93, 14,
93, 14, 93, 5, 6, 5, 6, 125, 125, 15, 15, 15, 15, 15, 15, 15, 15, 0,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 0, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 125, 93, 93, 93, 93, 93, 3, 93, 93, 15, 15, 15, 15, 15, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 14, 14, 14,
14, 14, 14, 14, 14, 93, 14, 14, 14, 14, 14, 14, 0, 14, 14, 3, 3, 3,
3, 3, 14, 14, 14, 14, 3, 3, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 125, 125, 93, 93, 93, 93, 125, 93, 93, 93, 93,
93, 93, 125, 93, 93, 125, 125, 93, 93, 15, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 3, 3, 3, 3, 3, 3, 15, 15, 15, 15, 15, 15, 125, 125, 93, 93, 15,
15, 15, 15, 93, 93, 93, 15, 125, 125, 125, 15, 15, 125, 125, 125, 125,
125, 125, 125, 15, 15, 15, 93, 93, 93, 93, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 93, 125, 125, 93, 93, 125, 125, 125, 125,
125, 125, 93, 15, 125, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 125, 125, 125,
93, 14, 14, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126,
126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126,
126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 126, 0,
126, 0, 0, 0, 0, 0, 126, 0, 0, 127, 127, 127, 127, 127, 127, 127, 127,
|
| ︙ | ︙ | |||
834 835 836 837 838 839 840 |
15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 125, 125, 93, 0, 0, 3,
3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 125, 93, 125, 93, 93, 93, 93, 93, 93, 93, 0, 93,
125, 93, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93, 125, 125, 125, 125,
125, 125, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 0, 93, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 92, 3, 3, 3, 3, 3, 3, 0, 0,
| | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | < | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < > | | | < | | | > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < < | > | | | | | | | | | < | > | | | | | | | > > | < < | | | | | | | | | | | | | | | | | | | | | | | | > | < | | | | | | | | | | | | | | | | | > | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < > | | | | | | > | | | | > > | | | | | | | | | | < > | | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | > > > > > > | | | | | | | | | | | | | | | | | | | | | | < > | | | | | | > | | | | | | | | | | | | | | | | | | > | > | | | | | < | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < < > | | < < | | | | | | | | | | > > > > | | | | | | | | | | | | > > > < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | < | | | | | | | | | | | | | | > | | | | | < | > > | | > > | > | 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 |
15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 125, 125, 93, 0, 0, 3,
3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 125, 93, 125, 93, 93, 93, 93, 93, 93, 93, 0, 93,
125, 93, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93, 125, 125, 125, 125,
125, 125, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 0, 93, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 92, 3, 3, 3, 3, 3, 3, 0, 0,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 120, 93, 93,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 93, 93, 93, 93, 125, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 93, 125, 93, 93, 93, 93, 93, 125, 93, 125,
125, 125, 125, 125, 93, 125, 125, 15, 15, 15, 15, 15, 15, 15, 0, 0,
0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 3, 3, 3, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 93, 93, 93, 93, 93, 93, 93, 93, 93, 14,
14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 93, 93, 125, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 93, 93, 93, 93, 125, 125,
93, 93, 125, 93, 93, 93, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 125, 93, 93, 125, 125,
125, 93, 125, 93, 93, 93, 125, 125, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3,
3, 15, 15, 15, 15, 125, 125, 125, 125, 125, 125, 125, 125, 93, 93,
93, 93, 93, 93, 93, 93, 125, 125, 93, 93, 0, 0, 0, 3, 3, 3, 3, 3, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 92,
92, 92, 92, 92, 3, 3, 130, 131, 132, 133, 133, 134, 135, 136, 137,
0, 0, 0, 0, 0, 0, 0, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138,
138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138,
138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138, 138,
138, 138, 138, 138, 138, 0, 0, 138, 138, 138, 3, 3, 3, 3, 3, 3, 3,
3, 0, 0, 0, 0, 0, 0, 0, 0, 93, 93, 93, 3, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 125, 93, 93, 93, 93, 93, 93, 93, 15, 15, 15,
15, 93, 15, 15, 15, 15, 15, 15, 93, 15, 15, 125, 93, 93, 15, 0, 0,
0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 92, 92, 92, 92, 92,
92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92,
92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92,
92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92,
92, 92, 92, 92, 92, 92, 92, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 92, 139, 21, 21, 21, 140, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 141, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 92, 92, 92, 92, 92, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 0, 93, 93, 93, 93, 93, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 21, 21, 21, 21, 21,
142, 21, 21, 143, 21, 144, 144, 144, 144, 144, 144, 144, 144, 145,
145, 145, 145, 145, 145, 145, 145, 144, 144, 144, 144, 144, 144, 0,
0, 145, 145, 145, 145, 145, 145, 0, 0, 144, 144, 144, 144, 144, 144,
144, 144, 145, 145, 145, 145, 145, 145, 145, 145, 144, 144, 144, 144,
144, 144, 144, 144, 145, 145, 145, 145, 145, 145, 145, 145, 144, 144,
144, 144, 144, 144, 0, 0, 145, 145, 145, 145, 145, 145, 0, 0, 21, 144,
21, 144, 21, 144, 21, 144, 0, 145, 0, 145, 0, 145, 0, 145, 144, 144,
144, 144, 144, 144, 144, 144, 145, 145, 145, 145, 145, 145, 145, 145,
146, 146, 147, 147, 147, 147, 148, 148, 149, 149, 150, 150, 151, 151,
0, 0, 144, 144, 144, 144, 144, 144, 144, 144, 152, 152, 152, 152, 152,
152, 152, 152, 144, 144, 144, 144, 144, 144, 144, 144, 152, 152, 152,
152, 152, 152, 152, 152, 144, 144, 144, 144, 144, 144, 144, 144, 152,
152, 152, 152, 152, 152, 152, 152, 144, 144, 21, 153, 21, 0, 21, 21,
145, 145, 154, 154, 155, 11, 156, 11, 11, 11, 21, 153, 21, 0, 21, 21,
157, 157, 157, 157, 155, 11, 11, 11, 144, 144, 21, 21, 0, 0, 21, 21,
145, 145, 158, 158, 0, 11, 11, 11, 144, 144, 21, 21, 21, 114, 21, 21,
145, 145, 159, 159, 118, 11, 11, 11, 0, 0, 21, 153, 21, 0, 21, 21,
160, 160, 161, 161, 155, 11, 11, 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2,
17, 17, 17, 17, 17, 8, 8, 8, 8, 8, 8, 3, 3, 16, 20, 5, 16, 16, 20,
5, 16, 3, 3, 3, 3, 3, 3, 3, 3, 162, 163, 17, 17, 17, 17, 17, 2, 3,
3, 3, 3, 3, 3, 3, 3, 3, 16, 20, 3, 3, 3, 3, 12, 12, 3, 3, 3, 7, 5,
6, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 7, 3, 12, 3, 3, 3, 3, 3, 3, 3,
3, 3, 3, 2, 17, 17, 17, 17, 17, 0, 17, 17, 17, 17, 17, 17, 17, 17,
17, 17, 18, 92, 0, 0, 18, 18, 18, 18, 18, 18, 7, 7, 7, 5, 6, 92, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 7, 7, 7, 5, 6, 0, 92, 92, 92, 92,
92, 92, 92, 92, 92, 92, 92, 92, 92, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4,
4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4,
4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 120, 120, 120, 120, 93, 120, 120,
120, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 108, 14, 14, 14, 14, 108, 14,
14, 21, 108, 108, 108, 21, 21, 108, 108, 108, 21, 14, 108, 14, 14,
7, 108, 108, 108, 108, 108, 14, 14, 14, 14, 14, 14, 108, 14, 164, 14,
108, 14, 165, 166, 108, 108, 14, 21, 108, 108, 167, 108, 21, 15, 15,
15, 15, 21, 14, 14, 21, 21, 108, 108, 7, 7, 7, 7, 7, 108, 21, 21, 21,
21, 14, 7, 14, 14, 168, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 169, 169, 169, 169, 169, 169, 169, 169, 169,
169, 169, 169, 169, 169, 169, 169, 170, 170, 170, 170, 170, 170, 170,
170, 170, 170, 170, 170, 170, 170, 170, 170, 129, 129, 129, 23, 24,
129, 129, 129, 129, 18, 14, 14, 0, 0, 0, 0, 7, 7, 7, 7, 7, 14, 14,
14, 14, 14, 7, 7, 14, 14, 14, 14, 7, 14, 14, 7, 14, 14, 7, 14, 14,
14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 7, 7, 14, 14, 7, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 5, 6, 5, 6, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 7, 7, 14, 14, 14, 14, 14, 14, 14, 5, 6, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7,
7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171,
171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 171, 172, 172,
172, 172, 172, 172, 172, 172, 172, 172, 172, 172, 172, 172, 172, 172,
172, 172, 172, 172, 172, 172, 172, 172, 172, 172, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 5, 6, 5, 6,
5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7,
7, 7, 5, 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 7,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 5, 6, 5, 6, 5,
6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 5, 6, 5, 6, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 5, 6, 7, 7, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 7, 7, 7, 7, 7,
7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 14, 14, 7, 7, 7, 7,
7, 7, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 123, 123,
123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123,
123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123,
123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123, 123,
123, 123, 123, 0, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124,
124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124,
124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124, 124,
124, 124, 124, 124, 124, 124, 124, 124, 124, 0, 23, 24, 173, 174, 175,
176, 177, 23, 24, 23, 24, 23, 24, 178, 179, 180, 181, 21, 23, 24, 21,
23, 24, 21, 21, 21, 21, 21, 92, 92, 182, 182, 23, 24, 23, 24, 21, 14,
14, 14, 14, 14, 14, 23, 24, 23, 24, 93, 93, 93, 23, 24, 0, 0, 0, 0,
0, 3, 3, 3, 3, 18, 3, 3, 183, 183, 183, 183, 183, 183, 183, 183, 183,
183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183,
183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183, 183,
183, 0, 183, 0, 0, 0, 0, 0, 183, 0, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
0, 0, 0, 0, 0, 0, 0, 92, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 93, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15,
15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15,
15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 3, 3, 16, 20, 16, 20,
3, 3, 3, 16, 20, 3, 16, 20, 3, 3, 3, 3, 3, 3, 3, 3, 3, 8, 3, 3, 8,
3, 16, 20, 3, 3, 16, 20, 5, 6, 5, 6, 5, 6, 5, 6, 3, 3, 3, 3, 3, 92,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 8, 8, 3, 3, 3, 3, 8, 3, 5, 3, 3, 3, 3,
3, 3, 3, 3, 3, 3, 3, 3, 3, 14, 14, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0,
2, 3, 3, 3, 14, 92, 15, 129, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6, 14, 14,
5, 6, 5, 6, 5, 6, 5, 6, 8, 5, 6, 6, 14, 129, 129, 129, 129, 129, 129,
129, 129, 129, 93, 93, 93, 93, 125, 125, 8, 92, 92, 92, 92, 92, 14,
14, 129, 129, 129, 92, 15, 3, 14, 14, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 93,
93, 11, 11, 92, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 3,
92, 92, 92, 15, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 14, 14,
18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 18, 18, 18, 18,
18, 18, 18, 18, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 92, 3, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 23, 24, 15, 93, 120, 120, 120, 3, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 3, 92, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
23, 24, 92, 92, 93, 93, 15, 15, 15, 15, 15, 15, 129, 129, 129, 129,
129, 129, 129, 129, 129, 129, 93, 93, 3, 3, 3, 3, 3, 3, 0, 0, 0, 0,
0, 0, 0, 0, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11,
11, 11, 11, 11, 11, 11, 11, 11, 11, 92, 92, 92, 92, 92, 92, 92, 92,
92, 11, 11, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24,
21, 21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 92, 21,
21, 21, 21, 21, 21, 21, 21, 23, 24, 23, 24, 184, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 92, 11, 11, 23, 24, 185, 21, 15, 23, 24, 23, 24,
186, 21, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23,
24, 23, 24, 23, 24, 187, 188, 189, 190, 187, 21, 191, 192, 193, 194,
23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 23, 24, 0, 0, 23, 24, 195,
196, 197, 23, 24, 23, 24, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 23, 24, 15, 92, 92, 21, 15, 15, 15, 15, 15, 15, 15,
93, 15, 15, 15, 93, 15, 15, 15, 15, 93, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125,
125, 93, 93, 125, 14, 14, 14, 14, 93, 0, 0, 0, 18, 18, 18, 18, 18,
18, 14, 14, 4, 14, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 3, 3, 3, 3, 0, 0, 0,
0, 0, 0, 0, 0, 125, 125, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125,
125, 125, 125, 125, 125, 125, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 3, 3,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 15, 15, 15, 15,
15, 15, 3, 3, 3, 15, 3, 15, 15, 93, 15, 15, 15, 15, 15, 15, 93, 93,
93, 93, 93, 93, 93, 93, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 125, 125, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 93, 125, 125, 93, 93, 93, 93, 125, 125, 93, 93, 125, 125,
125, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 0, 92, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 0, 0, 0, 0, 3, 3, 15, 15, 15, 15, 15, 93, 92, 15, 15, 15,
15, 15, 15, 15, 15, 15, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 15, 15, 15, 15,
15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 93,
125, 125, 93, 93, 125, 125, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15,
15, 15, 93, 15, 15, 15, 15, 15, 15, 15, 15, 93, 125, 0, 0, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 0, 0, 3, 3, 3, 3, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 15, 15, 15, 15, 15, 15, 14,
14, 14, 15, 125, 93, 125, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 93, 15, 93, 93, 93, 15, 15, 93, 93, 15,
15, 15, 15, 15, 93, 93, 15, 93, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 92, 3, 3, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 125, 93, 93, 125, 125, 3, 3, 15, 92,
92, 125, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15,
0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 0,
0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15,
15, 15, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 198, 21, 21, 21, 21, 21, 21, 21, 11, 92, 92, 92, 92,
21, 21, 21, 21, 21, 21, 21, 21, 21, 92, 11, 11, 0, 0, 0, 0, 199, 199,
199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199,
199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199,
199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199, 199,
199, 199, 199, 199, 15, 15, 15, 125, 125, 93, 125, 125, 93, 125, 125,
3, 125, 93, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15,
15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 0, 0, 0, 0, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200,
200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200, 200,
200, 200, 200, 200, 200, 200, 200, 200, 201, 201, 201, 201, 201, 201,
201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201,
201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 201, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 21, 21, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 21, 21, 21, 21, 21, 0, 0, 0, 0, 0, 15,
93, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 7, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 0, 15, 0, 15,
15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 11, 11, 11,
11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 11, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 6, 5, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 4, 14, 0, 0, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 3, 3, 3, 3, 3, 3, 3, 5,
6, 3, 0, 0, 0, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 3, 8, 8, 12, 12, 5, 6, 5, 6, 5, 6, 5, 6, 5, 6,
5, 6, 5, 6, 5, 6, 3, 3, 5, 6, 3, 3, 3, 3, 12, 12, 12, 3, 3, 3, 0, 3,
3, 3, 3, 8, 5, 6, 5, 6, 5, 6, 3, 3, 3, 7, 8, 7, 7, 7, 0, 3, 4, 3, 3,
0, 0, 0, 0, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 17, 0,
3, 3, 3, 4, 3, 3, 3, 5, 6, 3, 7, 3, 8, 3, 3, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 3, 3, 7, 7, 7, 3, 11, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 5,
7, 6, 7, 5, 6, 3, 5, 6, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
92, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 92, 92, 0, 0, 15, 15,
15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15,
15, 15, 0, 0, 15, 15, 15, 0, 0, 0, 4, 4, 7, 11, 14, 4, 4, 0, 14, 7,
7, 7, 7, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 17, 17, 17, 14, 14,
0, 0
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
,15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 0, 0, 0, 3, 3, 3, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 129, 129,
129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129,
129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129,
129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129,
129, 129, 129, 129, 129, 129, 129, 129, 129, 18, 18, 18, 18, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 18, 18,
14, 14, 14, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
0, 0, 0, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 93, 0,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 18, 18, 18, 18, 0, 0, 0, 0, 0,
0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 129, 15, 15, 15, 15, 15, 15, 15, 15, 129, 0,
0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 3, 15, 15, 15, 15,
0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 3, 129, 129, 129, 129,
129, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 202, 202, 202, 202, 202, 202, 202,
202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202,
202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202,
202, 202, 202, 202, 202, 203, 203, 203, 203, 203, 203, 203, 203, 203,
203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203,
203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203,
203, 203, 203, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0,
0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 202, 202, 202, 202,
202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202,
202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202, 202,
202, 202, 202, 202, 0, 0, 0, 0, 203, 203, 203, 203, 203, 203, 203,
203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203,
203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203, 203,
203, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 3, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 0, 0, 15,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 0, 0, 15,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 3, 18, 18, 18, 18, 18, 18, 18, 18, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 14, 14, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0,
0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 0, 0, 0, 0, 18, 18, 18,
18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 18, 18, 18, 18, 18, 18, 0, 0, 0, 3, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 3, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 0, 0, 0, 0, 18, 18, 15, 15, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 15, 93, 93, 93, 0, 93, 93, 0, 0, 0, 0, 0, 93,
93, 93, 93, 15, 15, 15, 15, 0, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 0, 0, 93, 93, 93, 0, 0, 0, 0, 93, 18, 18, 18,
18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 3,
3, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 18, 18, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 18,
18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 14, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 93, 93, 0, 0, 0, 0, 18, 18, 18, 18, 18, 3, 3, 3,
3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0,
3, 3, 3, 3, 3, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 18, 18, 18, 18, 18, 18,
18, 18, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
0, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 98, 98, 98, 98, 98, 98,
98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98,
98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98,
98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 98, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103,
103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103,
103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103,
103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 103, 0, 0, 0,
0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 15, 15, 15, 15, 93, 93, 93, 93,
0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0,
0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 93, 93, 8, 0, 0, 15, 15, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18,
15, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 18, 18, 18, 18, 3, 3, 3, 3, 3, 0, 0, 0, 0,
0, 0, 15, 15, 15, 15, 15, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 125, 93, 125, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 3, 3, 3,
3, 3, 3, 3, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 125, 93, 93, 93,
93, 125, 125, 93, 93, 3, 3, 17, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 17, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0,
0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 93, 93, 93, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 93, 93, 93, 93, 93, 125, 93, 93, 93, 93, 93, 93, 93, 93, 0, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 3, 3, 15, 125, 125, 15, 0, 0, 0, 0,
0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 93, 3, 3, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125,
125, 125, 93, 93, 93, 93, 93, 93, 93, 93, 93, 125, 125, 15, 15, 15,
15, 3, 3, 3, 3, 93, 93, 93, 93, 3, 125, 93, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 15, 3, 15, 3, 3, 3, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 125, 93, 93,
93, 125, 125, 93, 125, 93, 93, 3, 3, 3, 3, 3, 3, 93, 0, 15, 15, 15,
15, 15, 15, 15, 0, 15, 0, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 3, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 93, 125, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93,
0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 93,
93, 125, 125, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 0, 0,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 0, 15,
15, 15, 15, 15, 0, 93, 93, 15, 125, 125, 93, 125, 125, 125, 125, 0,
0, 125, 125, 0, 0, 125, 125, 125, 0, 0, 15, 0, 0, 0, 0, 0, 0, 125,
0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 125, 125, 0, 0, 93, 93, 93, 93,
93, 93, 93, 0, 0, 0, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 125, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93,
125, 125, 93, 93, 93, 125, 93, 15, 15, 15, 15, 3, 3, 3, 3, 3, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 3, 3, 0, 3, 93, 15, 15, 15, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
125, 125, 125, 93, 93, 93, 93, 93, 93, 125, 93, 125, 125, 125, 125,
93, 93, 125, 93, 93, 15, 15, 3, 15, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 125, 93, 93, 93, 93, 0, 0,
125, 125, 125, 125, 93, 93, 125, 93, 93, 3, 3, 3, 3, 3, 3, 3, 3, 3,
3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 15, 15, 15, 15, 93, 93, 0,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
125, 125, 125, 93, 93, 93, 93, 93, 93, 93, 93, 125, 125, 93, 125, 93,
93, 3, 3, 3, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 93, 125, 93, 125, 125, 93, 93, 93,
93, 93, 93, 125, 93, 15, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 125, 125, 93, 93, 93, 93, 125, 93, 93, 93, 93, 93, 0, 0, 0, 0,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 3, 3, 3, 14, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 125, 93, 93, 93, 93, 93,
93, 93, 93, 93, 125, 93, 93, 3, 0, 0, 0, 0, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10,
10, 10, 10, 10, 10, 10, 10, 10, 10, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13, 13,
13, 13, 13, 13, 13, 13, 13, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18, 18, 18,
18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15,
15, 15, 15, 15, 15, 15, 0, 0, 15, 0, 0, 15, 15, 15, 15, 15, 15, 15,
15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 125, 125, 125, 125,
125, 0, 125, 125, 0, 0, 93, 93, 125, 93, 15, 125, 15, 125, 93, 3, 3,
3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0,
0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
125, 125, 125, 93, 93, 93, 93, 0, 0, 93, 93, 125, 125, 125, 125, 93,
15, 3, 15, 125, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 93, 125, 15, 93, 93,
93, 93, 3, 3, 3, 3, 3, 3, 3, 3, 93, 0, 0, 0, 0, 0, 0, 0, 0, 15, 93,
93, 93, 93, 93, 93, 125, 125, 93, 93, 93, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 125, 93, 93, 3, 3, 3, 15, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 125, 93, 93, 93,
93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93, 125, 93, 15, 3, 3, 3, 3,
3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 0, 0, 0, 3, 3, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 0, 125, 93, 93, 93, 93, 93, 93, 93, 125,
93, 93, 125, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15,
15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93, 93, 0, 0, 0,
93, 0, 93, 93, 0, 93, 93, 93, 93, 93, 93, 93, 15, 93, 0, 0, 0, 0, 0,
0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0, 15, 15, 15,
15, 15, 15, 0, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 125, 125, 125, 125, 125, 0, 93, 93, 0, 125, 125, 93,
125, 93, 15, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 125, 125, 3, 3, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 14, 14,
14, 14, 14, 14, 14, 14, 4, 4, 4, 4, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 3, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129, 129,
129, 129, 129, 0, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15,
15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 17, 17, 17, 17, 17, 17, 17, 17, 17, 0, 0, 0,
0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 0, 0, 0, 0, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0,
93, 93, 93, 93, 93, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 93, 93, 93, 93, 93,
93, 93, 3, 3, 3, 3, 3, 14, 14, 14, 14, 92, 92, 92, 92, 3, 14, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 18, 18, 18,
18, 18, 18, 18, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 3,
3, 3, 3, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
0, 0, 0, 0, 93, 15, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125,
125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125,
125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125,
125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125, 125,
125, 125, 125, 0, 0, 0, 0, 0, 0, 0, 93, 93, 93, 93, 92, 92, 92, 92,
92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 92, 3, 92, 93, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 125, 125, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 15, 15, 15, 15,
15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 0, 0, 14, 93, 93, 3, 17, 17, 17, 17, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14,
14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 125, 125, 93, 93, 93, 14, 14, 14, 125, 125, 125, 125, 125, 125,
17, 17, 17, 17, 17, 17, 17, 17, 93, 93, 93, 93, 93, 93, 93, 93, 14,
14, 93, 93, 93, 93, 93, 93, 93, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 93, 93, 93, 93, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 14, 14, 93, 93, 93, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 0, 0, 0, 0, 0, 0, 0, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 21, 21, 21, 21, 21, 21, 21, 0, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108,
0, 108, 108, 0, 0, 108, 0, 0, 108, 108, 0, 0, 108, 108, 108, 108, 0,
108, 108, 108, 108, 108, 108, 108, 108, 21, 21, 21, 21, 0, 21, 0, 21,
21, 21, 21, 21, 21, 21, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 108, 108, 0, 108, 108, 108, 108, 0,
0, 108, 108, 108, 108, 108, 108, 108, 108, 0, 108, 108, 108, 108, 108,
108, 108, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, 108, 0, 108, 108,
108, 108, 0, 108, 108, 108, 108, 108, 0, 108, 0, 0, 0, 108, 108, 108,
108, 108, 108, 108, 0, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 108, 108, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 21, 21, 21, 21, 21, 21, 0, 0, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 7, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7,
21, 21, 21, 21, 21, 21, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 7, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21,
21, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 7, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 7, 21, 21, 21, 21, 21, 21, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108, 108,
108, 108, 108, 108, 108, 108, 108, 108, 7, 21, 21, 21, 21, 21, 21,
21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21, 21,
21, 21, 7, 21, 21, 21, 21, 21, 21, 108, 21, 0, 0, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9,
9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 14, 14, 14, 14, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 14, 14, 14, 14, 14, 14, 14,
14, 93, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 93,
14, 14, 3, 3, 3, 3, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 93,
93, 93, 93, 93, 93, 93, 0, 93, 93, 93, 93, 93, 93, 93, 93, 93, 93,
93, 93, 93, 93, 93, 93, 93, 0, 0, 93, 93, 93, 93, 93, 93, 93, 0, 93,
93, 0, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 0, 0, 0, 93, 93, 93, 93, 93, 93, 93, 92, 92, 92, 92, 92, 92, 92,
0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 15, 14, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 93, 93, 93, 93, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0,
0, 0, 0, 4, 15, 15, 15, 15, 15, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18,
18, 93, 93, 93, 93, 93, 93, 93, 0, 0, 0, 0, 0, 0, 0, 0, 0, 204, 204,
204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204,
204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204, 204,
204, 204, 204, 204, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205,
205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 205,
205, 205, 205, 205, 205, 205, 205, 205, 205, 205, 93, 93, 93, 93, 93,
93, 93, 92, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 3,
3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 14, 18, 18, 18, 4, 18, 18, 18, 18, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
18, 14, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18, 18,
0, 0, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0,
15, 15, 0, 15, 0, 0, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
0, 15, 15, 15, 15, 0, 15, 0, 15, 0, 0, 0, 0, 0, 0, 15, 0, 0, 0, 0,
15, 0, 15, 0, 15, 0, 15, 15, 15, 0, 15, 15, 0, 15, 0, 0, 15, 0, 15,
0, 15, 0, 15, 0, 15, 0, 15, 15, 0, 15, 0, 0, 15, 15, 15, 15, 0, 15,
15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 15, 15, 15, 15, 0, 15,
0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 15, 15,
15, 0, 15, 15, 15, 15, 15, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 7, 7, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 18, 18, 18, 18, 18, 18, 18, 18,
18, 18, 18, 18, 18, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0,
0, 0, 0, 0, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14,
14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
11, 11, 11, 11, 11, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0,
0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 14, 14, 14,
14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 14, 14,
14, 14, 14, 0, 0, 0, 14, 14, 14, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14,
14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14,
0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0,
0, 0, 0, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14,
14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0, 14, 14, 14, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 14, 14,
14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 9, 9, 9, 9, 9, 9, 9, 9, 9, 9, 0, 0, 0, 0, 0, 0,
15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15,
15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
#endif /* TCL_UTF_MAX > 3 */
};
|
| ︙ | ︙ | |||
1610 1611 1612 1613 1614 1615 1616 |
-2760383, -2760127, -2768575, 1859714, -9044927, -10823615, -12158,
-10830783, -10833599, -10832575, -10830015, -10817983, -10824127,
-10818751, 237633, -12223, -10830527, -9058239, 237698, 9949314,
18, 17, 10305, 10370, 8769, 8834
};
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
| | | | 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 |
-2760383, -2760127, -2768575, 1859714, -9044927, -10823615, -12158,
-10830783, -10833599, -10832575, -10830015, -10817983, -10824127,
-10818751, 237633, -12223, -10830527, -9058239, 237698, 9949314,
18, 17, 10305, 10370, 8769, 8834
};
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1FFFFF) >= 0x31360)
#else
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1F0000) != 0)
#endif
/*
* The following constants are used to determine the category of a
* Unicode character.
*/
|
| ︙ | ︙ | |||
1659 1660 1661 1662 1663 1664 1665 | /* * The following macros extract the fields of the character info. The * GetDelta() macro is complicated because we can't rely on the C compiler * to do sign extension on right shifts. */ | | | | | | 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 | /* * The following macros extract the fields of the character info. The * GetDelta() macro is complicated because we can't rely on the C compiler * to do sign extension on right shifts. */ #define GetCaseType(info) (((info) & 0xE0) >> 5) #define GetCategory(ch) (GetUniCharInfo(ch) & 0x1F) #define GetDelta(info) ((info) >> 8) /* * This macro extracts the information about a character from the * Unicode character tables. */ #if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6 # define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0x1FFFFF) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]]) #else # define GetUniCharInfo(ch) (groups[groupMap[pageMap[((ch) & 0xFFFF) >> OFFSET_BITS] | ((ch) & ((1 << OFFSET_BITS)-1))]]) #endif |
Changes to generic/tclUtf.c.
| ︙ | ︙ | |||
51 52 53 54 55 56 57 | * Unicode characters less than this value are represented by themselves in * UTF-8 strings. */ #define UNICODE_SELF 0x80 /* | | > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 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 |
* Unicode characters less than this value are represented by themselves in
* UTF-8 strings.
*/
#define UNICODE_SELF 0x80
/*
* The following structures are used when mapping between Unicode and
* UTF-8.
*/
static const unsigned char totalBytes[256] = {
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
/* Tcl_UtfCharComplete() might point to 2nd byte of valid 4-byte sequence */
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
/* End of "continuation byte section" */
2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
#if TCL_UTF_MAX > 3
4,4,4,4,4,
#else
1,1,1,1,1,
#endif
1,1,1,1,1,1,1,1,1,1,1
};
static const unsigned char complete[256] = {
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
/* Tcl_UtfCharComplete() might point to 2nd byte of valid 4-byte sequence */
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
/* End of "continuation byte section" */
2,1,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
#if TCL_UTF_MAX > 3
4,4,4,4,4,
#else
3,3,3,3,3,
#endif
1,1,1,1,1,1,1,1,1,1,1
};
/*
* Functions used only in this module.
*/
static int Invalid(const char *src);
/*
*---------------------------------------------------------------------------
*
* TclUtfCount --
*
* Find the number of bytes in the Utf character "ch".
*
* Results:
* The return values is the number of bytes in the Utf character "ch".
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
TclUtfCount(
int ch) /* The Unicode character whose size is returned. */
{
if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) {
return 1;
}
if (ch <= 0x7FF) {
return 2;
}
if (((unsigned)(ch - 0x10000) <= 0xFFFFF)) {
return 4;
}
return 3;
}
/*
*---------------------------------------------------------------------------
*
* Invalid --
*
* Given a pointer to a two-byte prefix of a well-formed UTF-8 byte
* sequence (a lead byte followed by a trail byte) this routine
* examines those two bytes to determine whether the sequence is
* invalid in UTF-8. This might be because it is an overlong
* encoding, or because it encodes something out of the proper range.
*
* Given a pointer to the bytes \xF8 or \xFC , this routine will
* try to read beyond the end of the "bounds" table. Callers must
* prevent this.
*
* Given a pointer to something else (an ASCII byte, a trail byte,
* or another byte that can never begin a valid byte sequence such
* as \xF5) this routine returns false. That makes the routine poorly
* named, as it does not detect and report all invalid sequences.
*
* Callers have to take care that this routine does something useful
* for their needs.
*
* Results:
* A boolean.
*---------------------------------------------------------------------------
*/
static const unsigned char bounds[28] = {
0x80, 0x80, /* \xC0 accepts \x80 only */
0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF,
0x80, 0xBF, /* (\xC4 - \xDC) -- all sequences valid */
0xA0, 0xBF, /* \xE0\x80 through \xE0\x9F are invalid prefixes */
0x80, 0xBF, 0x80, 0xBF, 0x80, 0xBF, /* (\xE4 - \xEC) -- all valid */
0x90, 0xBF, /* \xF0\x80 through \xF0\x8F are invalid prefixes */
0x80, 0x8F /* \xF4\x90 and higher are invalid prefixes */
};
static int
Invalid(
const char *src) /* Points to lead byte of a UTF-8 byte sequence */
{
unsigned char byte = UCHAR(*src);
int index;
if ((byte & 0xC3) == 0xC0) {
/* Only lead bytes 0xC0, 0xE0, 0xF0, 0xF4 need examination */
index = (byte - 0xC0) >> 1;
if (UCHAR(src[1]) < bounds[index] || UCHAR(src[1]) > bounds[index+1]) {
/* Out of bounds - report invalid. */
return 1;
}
}
return 0;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UniCharToUtf --
*
* Store the given Tcl_UniChar as a sequence of UTF-8 bytes in the
* provided buffer. Equivalent to Plan 9 runetochar().
|
| ︙ | ︙ | |||
217 218 219 220 221 222 223 224 225 | * * Side effects: * None. * *--------------------------------------------------------------------------- */ char * Tcl_UniCharToUtfDString( | > | | < | | < > > > > > > > > > > > < < | < < < < < < < < < < < | | | < | | > > > > > > > > > > > > | | 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 |
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
#undef Tcl_UniCharToUtfDString
char *
Tcl_UniCharToUtfDString(
const int *uniStr, /* Unicode string to convert to UTF-8. */
int uniLength, /* Length of Unicode string. */
Tcl_DString *dsPtr) /* UTF-8 representation of string is appended
* to this previously initialized DString. */
{
const int *w, *wEnd;
char *p, *string;
int oldLength;
/*
* UTF-8 string length in bytes will be <= Unicode string length * 4.
*/
if (uniStr == NULL) {
return NULL;
}
if (uniLength < 0) {
uniLength = 0;
w = uniStr;
while (*w != '\0') {
uniLength++;
w++;
}
}
oldLength = Tcl_DStringLength(dsPtr);
Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 4);
string = Tcl_DStringValue(dsPtr) + oldLength;
p = string;
wEnd = uniStr + uniLength;
for (w = uniStr; w < wEnd; ) {
p += Tcl_UniCharToUtf(*w, p);
w++;
}
Tcl_DStringSetLength(dsPtr, oldLength + (p - string));
return string;
}
char *
Tcl_Char16ToUtfDString(
const unsigned short *uniStr,/* Utf-16 string to convert to UTF-8. */
int uniLength, /* Length of Utf-16 string. */
Tcl_DString *dsPtr) /* UTF-8 representation of string is appended
* to this previously initialized DString. */
{
const unsigned short *w, *wEnd;
char *p, *string;
int oldLength, len = 1;
/*
* UTF-8 string length in bytes will be <= Utf16 string length * 3.
*/
if (uniStr == NULL) {
return NULL;
}
if (uniLength < 0) {
uniLength = 0;
w = uniStr;
while (*w != '\0') {
uniLength++;
w++;
}
}
oldLength = Tcl_DStringLength(dsPtr);
Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 3);
string = Tcl_DStringValue(dsPtr) + oldLength;
p = string;
wEnd = uniStr + uniLength;
for (w = uniStr; w < wEnd; ) {
if (!len && ((*w & 0xFC00) != 0xDC00)) {
/* Special case for handling high surrogates. */
|
| ︙ | ︙ | |||
304 305 306 307 308 309 310 |
/* Special case for handling high surrogates. */
p += Tcl_UniCharToUtf(-1, p);
}
Tcl_DStringSetLength(dsPtr, oldLength + (p - string));
return string;
}
| < | | > | | | < < < < < < < < < < < < < < | 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 |
/* Special case for handling high surrogates. */
p += Tcl_UniCharToUtf(-1, p);
}
Tcl_DStringSetLength(dsPtr, oldLength + (p - string));
return string;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfToUniChar --
*
* Extract the Tcl_UniChar represented by the UTF-8 string. Bad UTF-8
* sequences are converted to valid Tcl_UniChars and processing
* continues. Equivalent to Plan 9 chartorune().
*
* The caller must ensure that the source buffer is long enough that this
* routine does not run off the end and dereference non-existent memory
* looking for trail bytes. If the source buffer is known to be '\0'
* terminated, this cannot happen. Otherwise, the caller should call
* Tcl_UtfCharComplete() before calling this routine to ensure that
* enough bytes remain in the string.
*
* If TCL_UTF_MAX <= 4, special handling of Surrogate pairs is done:
* For any UTF-8 string containing a character outside of the BMP, the
* first call to this function will fill *chPtr with the high surrogate
* and generate a return value of 1. Calling Tcl_UtfToUniChar again
* will produce the low surrogate and a return value of 3. Because *chPtr
* is used to remember whether the high surrogate is already produced, it
* is recommended to initialize the variable it points to as 0 before
* the first call to Tcl_UtfToUniChar is done.
*
* Results:
* *chPtr is filled with the Tcl_UniChar, and the return value is the
* number of bytes from the UTF-8 string that were consumed.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
static const unsigned short cp1252[32] = {
0x20AC, 0x81, 0x201A, 0x0192, 0x201E, 0x2026, 0x2020, 0x2021,
0x02C6, 0x2030, 0x0160, 0x2039, 0x0152, 0x8D, 0x017D, 0x8F,
0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014,
0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178
};
#undef Tcl_UtfToUniChar
int
Tcl_UtfToUniChar(
const char *src, /* The UTF-8 string. */
int *chPtr)/* Filled with the Unicode character represented by
* the UTF-8 string. */
{
int byte;
/*
* Unroll 1 to 4 byte UTF-8 sequences.
*/
byte = *((unsigned char *) src);
if (byte < 0xC0) {
/*
* Handles properly formed UTF-8 characters between 0x01 and 0x7F.
* Treats naked trail bytes 0x80 to 0x9F as valid characters from
* the cp1252 table. See: <https://en.wikipedia.org/wiki/UTF-8>
* Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid
* characters representing themselves.
*/
if ((unsigned)(byte-0x80) < (unsigned)0x20) {
*chPtr = cp1252[byte-0x80];
} else {
*chPtr = byte;
}
return 1;
} else if (byte < 0xE0) {
|
| ︙ | ︙ | |||
423 424 425 426 427 428 429 |
}
/*
* A three-byte-character lead-byte not followed by two trail-bytes
* represents itself.
*/
}
| | < < < < < < < < < < < < < | | | | | | > | < | 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 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 |
}
/*
* A three-byte-character lead-byte not followed by two trail-bytes
* represents itself.
*/
}
else if (byte < 0xF5) {
if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) {
/*
* Four-byte-character lead byte followed by three trail bytes.
*/
*chPtr = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12)
| ((src[2] & 0x3F) << 6) | (src[3] & 0x3F));
if ((unsigned)(*chPtr - 0x10000) <= 0xFFFFF) {
return 4;
}
}
/*
* A four-byte-character lead-byte not followed by three trail-bytes
* represents itself.
*/
}
*chPtr = byte;
return 1;
}
int
Tcl_UtfToChar16(
const char *src, /* The UTF-8 string. */
unsigned short *chPtr)/* Filled with the Tcl_UniChar represented by
* the UTF-8 string. This could be a surrogate too. */
{
unsigned short byte;
/*
* Unroll 1 to 4 byte UTF-8 sequences.
*/
byte = UCHAR(*src);
if (byte < 0xC0) {
/*
* Handles properly formed UTF-8 characters between 0x01 and 0x7F.
* Treats naked trail bytes 0x80 to 0x9F as valid characters from
* the cp1252 table. See: <https://en.wikipedia.org/wiki/UTF-8>
* Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid
* characters representing themselves.
*/
/* If *chPtr contains a high surrogate (produced by a previous
* Tcl_UtfToUniChar() call) and the next 3 bytes are UTF-8 continuation
* bytes, then we must produce a follow-up low surrogate. We only
* do that if the high surrogate matches the bits we encounter.
*/
if (((byte & 0xC0) == 0x80)
&& ((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)
&& (((((byte - 0x10) << 2) & 0xFC) | 0xD800) == (*chPtr & 0xFCFC))
&& ((src[1] & 0xF0) == (((*chPtr << 4) & 0x30) | 0x80))) {
*chPtr = ((src[1] & 0x0F) << 6) + (src[2] & 0x3F) + 0xDC00;
return 3;
}
if ((unsigned)(byte-0x80) < (unsigned)0x20) {
*chPtr = cp1252[byte-0x80];
} else {
*chPtr = byte;
|
| ︙ | ︙ | |||
532 533 534 535 536 537 538 |
}
/*
* A three-byte-character lead-byte not followed by two trail-bytes
* represents itself.
*/
}
| | | | > | | < < > < | | > | | | | > > > > > > > | | | | > | | < < | | < | | > | | < | | | > > > > > > > | | | > | | < | | | > | < | | 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 |
}
/*
* A three-byte-character lead-byte not followed by two trail-bytes
* represents itself.
*/
}
else if (byte < 0xF5) {
if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)) {
/*
* Four-byte-character lead byte followed by at least two trail bytes.
* We don't test the validity of 3th trail byte, see [ed29806ba]
*/
Tcl_UniChar high = (((byte & 0x07) << 8) | ((src[1] & 0x3F) << 2)
| ((src[2] & 0x3F) >> 4)) - 0x40;
if (high < 0x400) {
/* produce high surrogate, advance source pointer */
*chPtr = 0xD800 + high;
return 1;
}
/* out of range, < 0x10000 or > 0x10FFFF */
}
/*
* A four-byte-character lead-byte not followed by three trail-bytes
* represents itself.
*/
}
*chPtr = byte;
return 1;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfToUniCharDString --
*
* Convert the UTF-8 string to Unicode.
*
* Results:
* The return value is a pointer to the Unicode representation of the
* UTF-8 string. Storage for the return value is appended to the end of
* dsPtr. The Unicode string is terminated with a Unicode NULL character.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
#undef Tcl_UtfToUniCharDString
int *
Tcl_UtfToUniCharDString(
const char *src, /* UTF-8 string to convert to Unicode. */
int length, /* Length of UTF-8 string in bytes, or -1 for
* strlen(). */
Tcl_DString *dsPtr) /* Unicode representation of string is
* appended to this previously initialized
* DString. */
{
int ch = 0, *w, *wString;
const char *p;
int oldLength;
/* Pointer to the end of string. Never read endPtr[0] */
const char *endPtr = src + length;
/* Pointer to last byte where optimization still can be used */
const char *optPtr = endPtr - TCL_UTF_MAX;
if (src == NULL) {
return NULL;
}
if (length < 0) {
length = strlen(src);
}
/*
* Unicode string length in Tcl_UniChars will be <= UTF-8 string length in
* bytes.
*/
oldLength = Tcl_DStringLength(dsPtr);
Tcl_DStringSetLength(dsPtr,
oldLength + ((length + 1) * sizeof(int)));
wString = (int *) (Tcl_DStringValue(dsPtr) + oldLength);
w = wString;
p = src;
endPtr = src + length;
optPtr = endPtr - 4;
while (p <= optPtr) {
p += TclUtfToUCS4(p, &ch);
*w++ = ch;
}
while ((p < endPtr) && TclUCS4Complete(p, endPtr-p)) {
p += TclUtfToUCS4(p, &ch);
*w++ = ch;
}
while (p < endPtr) {
*w++ = UCHAR(*p++);
}
*w = '\0';
Tcl_DStringSetLength(dsPtr,
oldLength + ((char *) w - (char *) wString));
return wString;
}
unsigned short *
Tcl_UtfToChar16DString(
const char *src, /* UTF-8 string to convert to Unicode. */
int length, /* Length of UTF-8 string in bytes, or -1 for
* strlen(). */
Tcl_DString *dsPtr) /* Unicode representation of string is
* appended to this previously initialized
* DString. */
{
unsigned short ch = 0, *w, *wString;
const char *p;
int oldLength;
/* Pointer to the end of string. Never read endPtr[0] */
const char *endPtr = src + length;
/* Pointer to last byte where optimization still can be used */
const char *optPtr = endPtr - TCL_UTF_MAX;
if (src == NULL) {
return NULL;
}
if (length < 0) {
length = strlen(src);
}
/*
* Unicode string length in Tcl_UniChars will be <= UTF-8 string length in
* bytes.
*/
oldLength = Tcl_DStringLength(dsPtr);
Tcl_DStringSetLength(dsPtr,
oldLength + ((length + 1) * sizeof(unsigned short)));
wString = (unsigned short *) (Tcl_DStringValue(dsPtr) + oldLength);
w = wString;
p = src;
endPtr = src + length;
optPtr = endPtr - 3;
while (p <= optPtr) {
p += Tcl_UtfToChar16(p, &ch);
*w++ = ch;
}
while (p < endPtr) {
if (TclChar16Complete(p, endPtr-p)) {
p += Tcl_UtfToChar16(p, &ch);
*w++ = ch;
} else {
*w++ = UCHAR(*p++);
}
}
*w = '\0';
Tcl_DStringSetLength(dsPtr,
oldLength + ((char *) w - (char *) wString));
return wString;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfCharComplete --
*
* Determine if the UTF-8 string of the given length is long enough to be
* decoded by Tcl_UtfToUniChar(). This does not ensure that the UTF-8
|
| ︙ | ︙ | |||
703 704 705 706 707 708 709 |
*---------------------------------------------------------------------------
*/
int
Tcl_UtfCharComplete(
const char *src, /* String to check if first few bytes contain
* a complete UTF-8 character. */
| | | | | | | | < < < < < < < | > | > > > | > > > > > > > > > | < < < < | > | | > > > > > > > > > | < < < < | < < < < < | < | | < < < | < | < < < < < | < | | | | > > > | | > > > | > > | > > > | > > > > > | | | > > > > > > > > > | > > | 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 |
*---------------------------------------------------------------------------
*/
int
Tcl_UtfCharComplete(
const char *src, /* String to check if first few bytes contain
* a complete UTF-8 character. */
int length) /* Length of above string in bytes. */
{
return length >= complete[UCHAR(*src)];
}
/*
*---------------------------------------------------------------------------
*
* Tcl_NumUtfChars --
*
* Returns the number of characters (not bytes) in the UTF-8 string, not
* including the terminating NULL byte. This is equivalent to Plan 9
* utflen() and utfnlen().
*
* Results:
* As above.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
Tcl_NumUtfChars(
const char *src, /* The UTF-8 string to measure. */
int length) /* The length of the string in bytes, or -1
* for strlen(string). */
{
Tcl_UniChar ch = 0;
int i = 0;
if (length < 0) {
/* string is NUL-terminated, so TclUtfToUniChar calls are safe. */
while ((*src != '\0') && (i < INT_MAX)) {
src += TclUtfToUniChar(src, &ch);
i++;
}
} else {
/* Will return value between 0 and length. No overflow checks. */
/* Pointer to the end of string. Never read endPtr[0] */
const char *endPtr = src + length;
/* Pointer to last byte where optimization still can be used */
const char *optPtr = endPtr - TCL_UTF_MAX;
/*
* Optimize away the call in this loop. Justified because...
* when (src <= optPtr), (endPtr - src) >= (endPtr - optPtr)
* By initialization above (endPtr - optPtr) = TCL_UTF_MAX
* So (endPtr - src) >= TCL_UTF_MAX, and passing that to
* Tcl_UtfCharComplete we know will cause return of 1.
*/
while (src <= optPtr
/* && Tcl_UtfCharComplete(src, endPtr - src) */ ) {
src += TclUtfToUniChar(src, &ch);
i++;
}
/* Loop over the remaining string where call must happen */
while (src < endPtr) {
if (Tcl_UtfCharComplete(src, endPtr - src)) {
src += TclUtfToUniChar(src, &ch);
} else {
/*
* src points to incomplete UTF-8 sequence
* Treat first byte as character and count it
*/
src++;
}
i++;
}
}
return i;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfFindFirst --
*
* Returns a pointer to the first occurrence of the given Unicode character
* in the NULL-terminated UTF-8 string. The NULL terminator is considered
* part of the UTF-8 string. Equivalent to Plan 9 utfrune().
*
* Results:
* As above. If the Unicode character does not exist in the given string,
* the return value is NULL.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
const char *
Tcl_UtfFindFirst(
const char *src, /* The UTF-8 string to be searched. */
int ch) /* The Unicode character to search for. */
{
while (1) {
int find, len = TclUtfToUCS4(src, &find);
if (find == ch) {
return src;
}
if (*src == '\0') {
return NULL;
}
src += len;
}
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfFindLast --
*
* Returns a pointer to the last occurrence of the given Unicode character
* in the NULL-terminated UTF-8 string. The NULL terminator is considered
* part of the UTF-8 string. Equivalent to Plan 9 utfrrune().
*
* Results:
* As above. If the Unicode character does not exist in the given string, the
* return value is NULL.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
const char *
Tcl_UtfFindLast(
const char *src, /* The UTF-8 string to be searched. */
int ch) /* The Unicode character to search for. */
{
const char *last = NULL;
while (1) {
int find, len = TclUtfToUCS4(src, &find);
if (find == ch) {
last = src;
}
if (*src == '\0') {
break;
}
src += len;
}
return last;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfNext --
*
* Given a pointer to some location in a UTF-8 string, Tcl_UtfNext
* returns a pointer to the next UTF-8 character in the string.
* The caller must not ask for the next character after the last
* character in the string if the string is not terminated by a null
* character.
*
* Results:
* The return value is the pointer to the next character in the UTF-8
* string.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
const char *
Tcl_UtfNext(
const char *src) /* The current location in the string. */
{
int left;
const char *next;
if (((*src) & 0xC0) == 0x80) {
if ((((*++src) & 0xC0) == 0x80) && (((*++src) & 0xC0) == 0x80)) {
++src;
}
return src;
}
left = totalBytes[UCHAR(*src)];
next = src + 1;
while (--left) {
if ((*next & 0xC0) != 0x80) {
/*
* src points to non-trail byte; We ran out of trail bytes
* before the needs of the lead byte were satisfied.
* Let the (malformed) lead byte alone be a character
*/
return src + 1;
}
next++;
}
/*
* Call Invalid() here only if required conditions are met:
* src[0] is known a lead byte.
* src[1] is known a trail byte.
* Especially important to prevent calls when src[0] == '\xF8' or '\xFC'
* See tests utf-6.37 through utf-6.43 through valgrind or similar tool.
*/
if ((next == src + 1) || Invalid(src)) {
return src + 1;
}
return next;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfPrev --
*
|
| ︙ | ︙ | |||
920 921 922 923 924 925 926 | * None. * *--------------------------------------------------------------------------- */ const char * Tcl_UtfPrev( | | | < > | | > > > > < < > | < | | < | > | > > > > > > > | > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > | > | | | | | | | | < | < | < | < < | | | < < > > | | | | < | < < | < | < | < | | < | | | > | 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 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 |
* None.
*
*---------------------------------------------------------------------------
*/
const char *
Tcl_UtfPrev(
const char *src, /* A location in a UTF-8 string. */
const char *start) /* Pointer to the beginning of the string */
{
int trailBytesSeen = 0; /* How many trail bytes have been verified? */
const char *fallback = src - 1;
/* If we cannot find a lead byte that might
* start a prefix of a valid UTF byte sequence,
* we will fallback to a one-byte back step */
const char *look = fallback;
/* Start search at the fallback position */
/* Quick boundary case exit. */
if (fallback <= start) {
return start;
}
do {
unsigned char byte = UCHAR(look[0]);
if (byte < 0x80) {
/*
* Single byte character. Either this is a correct previous
* character, or it is followed by at least one trail byte
* which indicates a malformed sequence. In either case the
* correct result is to return the fallback.
*/
return fallback;
}
if (byte >= 0xC0) {
/* Non-trail byte; May be multibyte lead. */
if ((trailBytesSeen == 0)
/*
* We've seen no trailing context to use to check
* anything. From what we know, this non-trail byte
* is a prefix of a previous character, and accepting
* it (the fallback) is correct.
*/
|| (trailBytesSeen >= complete[byte])) {
/*
* That is, (1 + trailBytesSeen > needed).
* We've examined more bytes than needed to complete
* this lead byte. No matter about well-formedness or
* validity, the sequence starting with this lead byte
* will never include the fallback location, so we must
* return the fallback location. See test utf-7.17
*/
return fallback;
}
/*
* trailBytesSeen > 0, so we can examine look[1] safely.
* Use that capability to screen out invalid sequences.
*/
if (Invalid(look)) {
/* Reject */
return fallback;
}
return (const char *)look;
}
/* We saw a trail byte. */
trailBytesSeen++;
if ((const char *)look == start) {
/*
* Do not read before the start of the string
*
* If we get here, we've examined bytes at every location
* >= start and < src and all of them are trail bytes,
* including (*start). We need to return our fallback
* and exit this loop before we run past the start of the string.
*/
return fallback;
}
/* Continue the search backwards... */
look--;
} while (trailBytesSeen < TCL_UTF_MAX);
/*
* We've seen TCL_UTF_MAX trail bytes, so we know there will not be a
* properly formed byte sequence to find, and we can stop looking,
* accepting the fallback (for TCL_UTF_MAX > 3) or just go back as
* far as we can.
*/
#if TCL_UTF_MAX > 3
return fallback;
#else
return src - TCL_UTF_MAX;
#endif
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UniCharAtIndex --
*
* Returns the Unicode character represented at the specified character
* (not byte) position in the UTF-8 string.
*
* Results:
* As above.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
int
Tcl_UniCharAtIndex(
const char *src, /* The UTF-8 string to dereference. */
int index) /* The position of the desired character. */
{
Tcl_UniChar ch = 0;
int i = 0;
if (index < 0) {
return -1;
}
while (index-- > 0) {
i = TclUtfToUniChar(src, &ch);
src += i;
}
#if TCL_UTF_MAX <= 3
if ((ch >= 0xD800) && (i < 3)) {
/* Index points at character following high Surrogate */
return -1;
}
#endif
TclUtfToUCS4(src, &i);
return i;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfAtIndex --
*
* Returns a pointer to the specified character (not byte) position in
* the UTF-8 string. If TCL_UTF_MAX <= 3, characters > U+FFFF count as
* 2 positions, but then the pointer should never be placed between
* the two positions.
*
* Results:
* As above.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
const char *
Tcl_UtfAtIndex(
const char *src, /* The UTF-8 string. */
int index) /* The position of the desired character. */
{
Tcl_UniChar ch = 0;
int len = 0;
while (index-- > 0) {
len = TclUtfToUniChar(src, &ch);
src += len;
}
#if TCL_UTF_MAX <= 3
if ((ch >= 0xD800) && (len < 3)) {
/* Index points at character following high Surrogate */
src += TclUtfToUniChar(src, &ch);
}
#endif
return src;
}
/*
*---------------------------------------------------------------------------
*
* Tcl_UtfBackslash --
*
* Figure out how to handle a backslash sequence.
*
* Results:
* Stores the bytes represented by the backslash sequence in dst and
* returns the number of bytes written to dst. At most 4 bytes
* are written to dst; dst must have been large enough to accept those
* bytes. If readPtr isn't NULL then it is filled in with a count of the
* number of bytes in the backslash sequence.
*
* Side effects:
* The maximum number of bytes it takes to represent a Unicode character
* in UTF-8 is guaranteed to be less than the number of bytes used to
* express the backslash sequence that represents that Unicode character.
* If the target buffer into which the caller is going to store the bytes
* that represent the Unicode character is at least as large as the
* source buffer from which the backslashed sequence was extracted, no
* buffer overruns should occur.
*
*---------------------------------------------------------------------------
*/
int
Tcl_UtfBackslash(
const char *src, /* Points to the backslash character of a
* backslash sequence. */
int *readPtr, /* Fill in with number of characters read from
* src, unless NULL. */
char *dst) /* Filled with the bytes represented by the
* backslash sequence. */
{
#define LINE_LENGTH 128
int numRead;
int result;
result = TclParseBackslash(src, LINE_LENGTH, &numRead, dst);
if (numRead == LINE_LENGTH) {
/*
* We ate a whole line. Pay the price of a strlen()
*/
|
| ︙ | ︙ | |||
1115 1116 1117 1118 1119 1120 1121 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToUpper(
char *str) /* String to convert in place. */
{
| < | | | < < < < < < < < | | | 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToUpper(
char *str) /* String to convert in place. */
{
int ch, upChar;
char *src, *dst;
int len;
/*
* Iterate over the string until we hit the terminating null.
*/
src = dst = str;
while (*src) {
len = TclUtfToUCS4(src, &ch);
upChar = Tcl_UniCharToUpper(ch);
/*
* To keep badly formed Utf strings from getting inflated by the
* conversion (thereby causing a segfault), only copy the upper case
* char to dst if its size is <= the original char.
*/
if ((len < TclUtfCount(upChar)) || ((upChar & ~0x7FF) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(upChar, dst);
}
src += len;
}
|
| ︙ | ︙ | |||
1177 1178 1179 1180 1181 1182 1183 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToLower(
char *str) /* String to convert in place. */
{
| < | | | < < < < < < < < | | | 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToLower(
char *str) /* String to convert in place. */
{
int ch, lowChar;
char *src, *dst;
int len;
/*
* Iterate over the string until we hit the terminating null.
*/
src = dst = str;
while (*src) {
len = TclUtfToUCS4(src, &ch);
lowChar = Tcl_UniCharToLower(ch);
/*
* To keep badly formed Utf strings from getting inflated by the
* conversion (thereby causing a segfault), only copy the lower case
* char to dst if its size is <= the original char.
*/
if ((len < TclUtfCount(lowChar)) || ((lowChar & ~0x7FF) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(lowChar, dst);
}
src += len;
}
|
| ︙ | ︙ | |||
1240 1241 1242 1243 1244 1245 1246 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToTitle(
char *str) /* String to convert in place. */
{
| < | | | < < < < < < < < | | | < < < < < < < | | 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfToTitle(
char *str) /* String to convert in place. */
{
int ch, titleChar, lowChar;
char *src, *dst;
int len;
/*
* Capitalize the first character and then lowercase the rest of the
* characters until we get to a null.
*/
src = dst = str;
if (*src) {
len = TclUtfToUCS4(src, &ch);
titleChar = Tcl_UniCharToTitle(ch);
if ((len < TclUtfCount(titleChar)) || ((titleChar & ~0x7FF) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(titleChar, dst);
}
src += len;
}
while (*src) {
len = TclUtfToUCS4(src, &ch);
lowChar = ch;
/* Special exception for Georgian Asomtavruli chars, no titlecase. */
if ((unsigned)(lowChar - 0x1C90) >= 0x30) {
lowChar = Tcl_UniCharToLower(lowChar);
}
if ((len < TclUtfCount(lowChar)) || ((lowChar & ~0x7FF) == 0xD800)) {
memmove(dst, src, len);
dst += len;
} else {
dst += Tcl_UniCharToUtf(lowChar, dst);
}
src += len;
}
|
| ︙ | ︙ | |||
1320 1321 1322 1323 1324 1325 1326 |
*----------------------------------------------------------------------
*/
int
TclpUtfNcmp2(
const char *cs, /* UTF string to compare to ct. */
const char *ct, /* UTF string cs is compared to. */
| | | | 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 |
*----------------------------------------------------------------------
*/
int
TclpUtfNcmp2(
const char *cs, /* UTF string to compare to ct. */
const char *ct, /* UTF string cs is compared to. */
unsigned long numBytes) /* Number of *bytes* to compare. */
{
/*
* We can't simply call 'memcmp(cs, ct, numBytes);' because we need to
* check for Tcl's \xC0\x80 non-utf-8 null encoding. Otherwise utf-8 lexes
* fine in the strcmp manner.
*/
int result = 0;
for ( ; numBytes != 0; numBytes--, cs++, ct++) {
if (*cs != *ct) {
result = UCHAR(*cs) - UCHAR(*ct);
break;
}
}
|
| ︙ | ︙ | |||
1367 1368 1369 1370 1371 1372 1373 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfNcmp(
const char *cs, /* UTF string to compare to ct. */
const char *ct, /* UTF string cs is compared to. */
| | | | 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfNcmp(
const char *cs, /* UTF string to compare to ct. */
const char *ct, /* UTF string cs is compared to. */
unsigned long numChars) /* Number of UTF chars to compare. */
{
Tcl_UniChar ch1 = 0, ch2 = 0;
/*
* Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the
* pair of bytes 0xC0,0x80) is larger than byte representation of \u0001
* (the byte 0x01.)
*/
while (numChars-- > 0) {
/*
* n must be interpreted as chars, not bytes. This should be called
* only when both strings are of at least n chars long (no need for \0
* check)
*/
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
#if TCL_UTF_MAX <= 3
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
return ch1;
}
} else if ((ch2 & 0xFC00) == 0xD800) {
return -ch2;
|
| ︙ | ︙ | |||
1425 1426 1427 1428 1429 1430 1431 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfNcasecmp(
const char *cs, /* UTF string to compare to ct. */
const char *ct, /* UTF string cs is compared to. */
| | | | 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 |
*----------------------------------------------------------------------
*/
int
Tcl_UtfNcasecmp(
const char *cs, /* UTF string to compare to ct. */
const char *ct, /* UTF string cs is compared to. */
unsigned long numChars) /* Number of UTF chars to compare. */
{
Tcl_UniChar ch1 = 0, ch2 = 0;
while (numChars-- > 0) {
/*
* n must be interpreted as chars, not bytes.
* This should be called only when both strings are of
* at least n chars long (no need for \0 check)
*/
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
#if TCL_UTF_MAX <= 3
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
return ch1;
}
} else if ((ch2 & 0xFC00) == 0xD800) {
return -ch2;
|
| ︙ | ︙ | |||
1487 1488 1489 1490 1491 1492 1493 |
{
Tcl_UniChar ch1 = 0, ch2 = 0;
while (*cs && *ct) {
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
| | | 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 |
{
Tcl_UniChar ch1 = 0, ch2 = 0;
while (*cs && *ct) {
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
#if TCL_UTF_MAX <= 3
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
return ch1;
}
} else if ((ch2 & 0xFC00) == 0xD800) {
return -ch2;
|
| ︙ | ︙ | |||
1533 1534 1535 1536 1537 1538 1539 |
{
Tcl_UniChar ch1 = 0, ch2 = 0;
while (*cs && *ct) {
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
| | | 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 |
{
Tcl_UniChar ch1 = 0, ch2 = 0;
while (*cs && *ct) {
cs += TclUtfToUniChar(cs, &ch1);
ct += TclUtfToUniChar(ct, &ch2);
if (ch1 != ch2) {
#if TCL_UTF_MAX <= 3
/* Surrogates always report higher than non-surrogates */
if (((ch1 & 0xFC00) == 0xD800)) {
if ((ch2 & 0xFC00) != 0xD800) {
return ch1;
}
} else if ((ch2 & 0xFC00) == 0xD800) {
return -ch2;
|
| ︙ | ︙ | |||
1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 |
if (!UNICODE_OUT_OF_RANGE(ch)) {
int info = GetUniCharInfo(ch);
if (GetCaseType(info) & 0x04) {
ch -= GetDelta(info);
}
}
return ch & 0x1FFFFF;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharToLower --
| > | 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 |
if (!UNICODE_OUT_OF_RANGE(ch)) {
int info = GetUniCharInfo(ch);
if (GetCaseType(info) & 0x04) {
ch -= GetDelta(info);
}
}
/* Clear away extension bits, if any */
return ch & 0x1FFFFF;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharToLower --
|
| ︙ | ︙ | |||
1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 |
int info = GetUniCharInfo(ch);
int mode = GetCaseType(info);
if ((mode & 0x02) && (mode != 0x7)) {
ch += GetDelta(info);
}
}
return ch & 0x1FFFFF;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharToTitle --
| > | 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 |
int info = GetUniCharInfo(ch);
int mode = GetCaseType(info);
if ((mode & 0x02) && (mode != 0x7)) {
ch += GetDelta(info);
}
}
/* Clear away extension bits, if any */
return ch & 0x1FFFFF;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharToTitle --
|
| ︙ | ︙ | |||
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 |
if (mode != 0x7) {
ch += ((mode & 0x4) ? -1 : 1);
}
} else if (mode == 0x4) {
ch -= GetDelta(info);
}
}
return ch & 0x1FFFFF;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharLen --
*
* Find the length of a UniChar string. The str input must be null
* terminated.
*
* Results:
* Returns the length of str in UniChars (not bytes).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
| > | | | 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 |
if (mode != 0x7) {
ch += ((mode & 0x4) ? -1 : 1);
}
} else if (mode == 0x4) {
ch -= GetDelta(info);
}
}
/* Clear away extension bits, if any */
return ch & 0x1FFFFF;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UniCharLen --
*
* Find the length of a UniChar string. The str input must be null
* terminated.
*
* Results:
* Returns the length of str in UniChars (not bytes).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_UniCharLen(
const Tcl_UniChar *uniStr) /* Unicode string to find length of. */
{
int len = 0;
while (*uniStr != '\0') {
len++;
uniStr++;
}
return len;
}
|
| ︙ | ︙ | |||
1705 1706 1707 1708 1709 1710 1711 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharNcmp(
const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */
const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */
| | | 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharNcmp(
const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */
const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */
unsigned long numChars) /* Number of unichars to compare. */
{
#ifdef WORDS_BIGENDIAN
/*
* We are definitely on a big-endian machine; memcmp() is safe
*/
return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar));
|
| ︙ | ︙ | |||
1750 1751 1752 1753 1754 1755 1756 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharNcasecmp(
const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */
const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */
| | | 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 |
*----------------------------------------------------------------------
*/
int
Tcl_UniCharNcasecmp(
const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */
const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */
unsigned long numChars) /* Number of unichars to compare. */
{
for ( ; numChars != 0; numChars--, ucs++, uct++) {
if (*ucs != *uct) {
Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs);
Tcl_UniChar lct = Tcl_UniCharToLower(*uct);
if (lcs != lct) {
|
| ︙ | ︙ | |||
1838 1839 1840 1841 1842 1843 1844 1845 |
*/
int
Tcl_UniCharIsControl(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
ch &= 0x1FFFFF;
| > | | 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 |
*/
int
Tcl_UniCharIsControl(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
/* Clear away extension bits, if any */
ch &= 0x1FFFFF;
if ((ch == 0xE0001) || ((ch >= 0xE0020) && (ch <= 0xE007F))) {
return 1;
}
if ((ch >= 0xF0000) && ((ch & 0xFFFF) <= 0xFFFD)) {
return 1;
}
return 0;
}
|
| ︙ | ︙ | |||
1897 1898 1899 1900 1901 1902 1903 |
*/
int
Tcl_UniCharIsGraph(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
| | < | 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 |
*/
int
Tcl_UniCharIsGraph(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
return ((unsigned)((ch & 0x1FFFFF) - 0xE0100) <= 0xEF);
}
return ((GRAPH_BITS >> GetCategory(ch)) & 1);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1950 1951 1952 1953 1954 1955 1956 |
*/
int
Tcl_UniCharIsPrint(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
| | < | 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 |
*/
int
Tcl_UniCharIsPrint(
int ch) /* Unicode character to test. */
{
if (UNICODE_OUT_OF_RANGE(ch)) {
return ((unsigned)((ch & 0x1FFFFF) - 0xE0100) <= 0xEF);
}
return (((GRAPH_BITS|SPACE_BITS) >> GetCategory(ch)) & 1);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2011 2012 2013 2014 2015 2016 2017 |
/*
* If the character is within the first 127 characters, just use the
* standard C function, otherwise consult the Unicode table.
*/
if (ch < 0x80) {
| | | 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 |
/*
* If the character is within the first 127 characters, just use the
* standard C function, otherwise consult the Unicode table.
*/
if (ch < 0x80) {
return TclIsSpaceProcM((char) ch);
} else if (UNICODE_OUT_OF_RANGE(ch)) {
return 0;
} else if (ch == 0x0085 || ch == 0x180E || ch == 0x200B
|| ch == 0x202F || ch == 0x2060 || ch == 0xFEFF) {
return 1;
} else {
return ((SPACE_BITS >> GetCategory(ch)) & 1);
|
| ︙ | ︙ | |||
2156 2157 2158 2159 2160 2161 2162 |
* quickly if the next char in the pattern isn't a special
* character
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while (*uniStr && (p != *uniStr)
| | | 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 |
* quickly if the next char in the pattern isn't a special
* character
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while (*uniStr && (p != *uniStr)
&& (p != Tcl_UniCharToLower(*uniStr))) {
uniStr++;
}
} else {
while (*uniStr && (p != *uniStr)) {
uniStr++;
}
}
|
| ︙ | ︙ | |||
2196 2197 2198 2199 2200 2201 2202 |
* characters separated by "-").
*/
if (p == '[') {
Tcl_UniChar startChar, endChar;
uniPattern++;
| | | | | 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 |
* characters separated by "-").
*/
if (p == '[') {
Tcl_UniChar startChar, endChar;
uniPattern++;
ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr);
uniStr++;
while (1) {
if ((*uniPattern == ']') || (*uniPattern == 0)) {
return 0;
}
startChar = (nocase ? Tcl_UniCharToLower(*uniPattern)
: *uniPattern);
uniPattern++;
if (*uniPattern == '-') {
uniPattern++;
if (*uniPattern == 0) {
return 0;
}
endChar = (nocase ? Tcl_UniCharToLower(*uniPattern)
: *uniPattern);
uniPattern++;
if (((startChar <= ch1) && (ch1 <= endChar))
|| ((endChar <= ch1) && (ch1 <= startChar))) {
/*
* Matches ranges of form [a-z] or [z-a].
*/
|
| ︙ | ︙ | |||
2288 2289 2290 2291 2292 2293 2294 |
*
*----------------------------------------------------------------------
*/
int
TclUniCharMatch(
const Tcl_UniChar *string, /* Unicode String. */
| | | | 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 |
*
*----------------------------------------------------------------------
*/
int
TclUniCharMatch(
const Tcl_UniChar *string, /* Unicode String. */
int strLen, /* Length of String */
const Tcl_UniChar *pattern, /* Pattern, which may contain special
* characters. */
int ptnLen, /* Length of Pattern */
int nocase) /* 0 for case sensitive, 1 for insensitive */
{
const Tcl_UniChar *stringEnd, *patternEnd;
Tcl_UniChar p;
stringEnd = string + strLen;
patternEnd = pattern + ptnLen;
|
| ︙ | ︙ | |||
2348 2349 2350 2351 2352 2353 2354 |
* quickly if the next char in the pattern isn't a special
* character.
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while ((string < stringEnd) && (p != *string)
| | | 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 |
* quickly if the next char in the pattern isn't a special
* character.
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while ((string < stringEnd) && (p != *string)
&& (p != Tcl_UniCharToLower(*string))) {
string++;
}
} else {
while ((string < stringEnd) && (p != *string)) {
string++;
}
}
|
| ︙ | ︙ | |||
2389 2390 2391 2392 2393 2394 2395 |
* characters separated by "-").
*/
if (p == '[') {
Tcl_UniChar ch1, startChar, endChar;
pattern++;
| | | | | 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 |
* characters separated by "-").
*/
if (p == '[') {
Tcl_UniChar ch1, startChar, endChar;
pattern++;
ch1 = (nocase ? Tcl_UniCharToLower(*string) : *string);
string++;
while (1) {
if ((*pattern == ']') || (pattern == patternEnd)) {
return 0;
}
startChar = (nocase ? Tcl_UniCharToLower(*pattern) : *pattern);
pattern++;
if (*pattern == '-') {
pattern++;
if (pattern == patternEnd) {
return 0;
}
endChar = (nocase ? Tcl_UniCharToLower(*pattern)
: *pattern);
pattern++;
if (((startChar <= ch1) && (ch1 <= endChar))
|| ((endChar <= ch1) && (ch1 <= startChar))) {
/*
* Matches ranges of form [a-z] or [z-a].
*/
|
| ︙ | ︙ | |||
2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 |
return 0;
}
string++;
pattern++;
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 |
return 0;
}
string++;
pattern++;
}
}
/*
*---------------------------------------------------------------------------
*
* TclUtfToUCS4 --
*
* Extract the 4-byte codepoint from the leading bytes of the
* Modified UTF-8 string "src". This is a utility routine to
* contain the surrogate gymnastics in one place.
*
* The caller must ensure that the source buffer is long enough that this
* routine does not run off the end and dereference non-existent memory
* looking for trail bytes. If the source buffer is known to be '\0'
* terminated, this cannot happen. Otherwise, the caller should call
* Tcl_UtfCharComplete() before calling this routine to ensure that
* enough bytes remain in the string.
*
* Results:
* *usc4Ptr is filled with the UCS4 code point, and the return value is
* the number of bytes from the UTF-8 string that were consumed.
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
#if TCL_UTF_MAX <= 3
int
TclUtfToUCS4(
const char *src, /* The UTF-8 string. */
int *ucs4Ptr) /* Filled with the UCS4 codepoint represented
* by the UTF-8 string. */
{
/* Make use of the #undef Tcl_UtfToUniChar above, which already handles UCS4. */
return Tcl_UtfToUniChar(src, ucs4Ptr);
}
int
TclUniCharToUCS4(
const Tcl_UniChar *src, /* The Tcl_UniChar string. */
int *ucs4Ptr) /* Filled with the UCS4 codepoint represented
* by the Tcl_UniChar string. */
{
if (((src[0] & 0xFC00) == 0xD800) && ((src[1] & 0xFC00) == 0xDC00)) {
*ucs4Ptr = (((src[0] & 0x3FF) << 10) | (src[01] & 0x3FF)) + 0x10000;
return 2;
}
*ucs4Ptr = src[0];
return 1;
}
#endif
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to generic/tclUtil.c.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclParse.h" #include "tclStringTrim.h" | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tclParse.h" #include "tclStringTrim.h" #include "tclTomMath.h" #include <math.h> /* * The absolute pathname of the executable in which this Tcl library is * running. */ |
| ︙ | ︙ | |||
90 91 92 93 94 95 96 97 98 99 100 101 102 103 | #define COMPAT 1 #define CONVERT_NONE 0 #define CONVERT_BRACE 2 #define CONVERT_ESCAPE 4 #define CONVERT_MASK (CONVERT_BRACE | CONVERT_ESCAPE) #define CONVERT_ANY 16 /* * Prototypes for functions defined later in this file. */ static void ClearHash(Tcl_HashTable *tablePtr); static void FreeProcessGlobalValue(ClientData clientData); static void FreeThreadHash(ClientData clientData); | > > > > > > > | | | 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 | #define COMPAT 1 #define CONVERT_NONE 0 #define CONVERT_BRACE 2 #define CONVERT_ESCAPE 4 #define CONVERT_MASK (CONVERT_BRACE | CONVERT_ESCAPE) #define CONVERT_ANY 16 /* * The following key is used by Tcl_PrintDouble and TclPrecTraceProc to * access the precision to be used for double formatting. */ static Tcl_ThreadDataKey precisionKey; /* * Prototypes for functions defined later in this file. */ static void ClearHash(Tcl_HashTable *tablePtr); static void FreeProcessGlobalValue(ClientData clientData); static void FreeThreadHash(ClientData clientData); static int GetEndOffsetFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, size_t endValue, Tcl_WideInt *indexPtr); static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr); static int GetWideForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, size_t endValue, Tcl_WideInt *widePtr); static int FindElement(Tcl_Interp *interp, const char *string, int stringLength, const char *typeStr, const char *typeCode, const char **elementPtr, const char **nextPtr, int *sizePtr, int *literalPtr); /* * The following is the Tcl object type definition for an object that * represents a list index in the form, "end-offset". It is used as a * performance optimization in Tcl_GetIntForIndex. The internal rep is * stored directly in the wideValue, so no memory management is required * for it. This is a caching intrep, keeping the result of a parse |
| ︙ | ︙ | |||
383 384 385 386 387 388 389 |
*
*----------------------------------------------------------------------
*/
int
TclMaxListLength(
const char *bytes,
| | | | | | | | | | | | | 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 |
*
*----------------------------------------------------------------------
*/
int
TclMaxListLength(
const char *bytes,
int numBytes,
const char **endPtr)
{
int count = 0;
if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) {
/* Empty string case - quick exit */
goto done;
}
/*
* No list element before leading white space.
*/
count += 1 - TclIsSpaceProcM(*bytes);
/*
* Count white space runs as potential element separators.
*/
while (numBytes) {
if ((numBytes == -1) && (*bytes == '\0')) {
break;
}
if (TclIsSpaceProcM(*bytes)) {
/*
* Space run started; bump count.
*/
count++;
do {
bytes++;
numBytes -= (numBytes != -1);
} while (numBytes && TclIsSpaceProcM(*bytes));
if ((numBytes == 0) || ((numBytes == -1) && (*bytes == '\0'))) {
break;
}
/*
* (*bytes) is non-space; return to counting state.
*/
}
bytes++;
numBytes -= (numBytes != -1);
}
/*
* No list element following trailing white space.
*/
count -= TclIsSpaceProcM(bytes[-1]);
done:
if (endPtr) {
*endPtr = bytes;
}
return count;
}
|
| ︙ | ︙ | |||
495 496 497 498 499 500 501 |
* elements (possibly in braces). */
int listLength, /* Number of bytes in the list's string. */
const char **elementPtr, /* Where to put address of first significant
* character in first element of list. */
const char **nextPtr, /* Fill in with location of character just
* after all white space following end of
* argument (next arg or end of list). */
| | | 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 |
* elements (possibly in braces). */
int listLength, /* Number of bytes in the list's string. */
const char **elementPtr, /* Where to put address of first significant
* character in first element of list. */
const char **nextPtr, /* Fill in with location of character just
* after all white space following end of
* argument (next arg or end of list). */
int *sizePtr, /* If non-zero, fill in with size of
* element. */
int *literalPtr) /* If non-zero, fill in with non-zero/zero to
* indicate that the substring of *sizePtr
* bytes starting at **elementPtr is/is not
* the literal list element and therefore
* does not/does require a call to
* TclCopyAndCollapse() by the caller. */
|
| ︙ | ︙ | |||
524 525 526 527 528 529 530 |
int dictLength, /* Number of bytes in the dict's string. */
const char **elementPtr, /* Where to put address of first significant
* character in the first element (i.e., key
* or value) of dict. */
const char **nextPtr, /* Fill in with location of character just
* after all white space following end of
* element (next arg or end of list). */
| | | 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 |
int dictLength, /* Number of bytes in the dict's string. */
const char **elementPtr, /* Where to put address of first significant
* character in the first element (i.e., key
* or value) of dict. */
const char **nextPtr, /* Fill in with location of character just
* after all white space following end of
* element (next arg or end of list). */
int *sizePtr, /* If non-zero, fill in with size of
* element. */
int *literalPtr) /* If non-zero, fill in with non-zero/zero to
* indicate that the substring of *sizePtr
* bytes starting at **elementPtr is/is not
* the literal key or value and therefore
* does not/does require a call to
* TclCopyAndCollapse() by the caller. */
|
| ︙ | ︙ | |||
556 557 558 559 560 561 562 |
const char *typeCode, /* The type code for thing we are parsing, for
* error messages. */
const char **elementPtr, /* Where to put address of first significant
* character in first element. */
const char **nextPtr, /* Fill in with location of character just
* after all white space following end of
* argument (next arg or end of list/dict). */
| | | | | | 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 |
const char *typeCode, /* The type code for thing we are parsing, for
* error messages. */
const char **elementPtr, /* Where to put address of first significant
* character in first element. */
const char **nextPtr, /* Fill in with location of character just
* after all white space following end of
* argument (next arg or end of list/dict). */
int *sizePtr, /* If non-zero, fill in with size of
* element. */
int *literalPtr) /* If non-zero, fill in with non-zero/zero to
* indicate that the substring of *sizePtr
* bytes starting at **elementPtr is/is not
* the literal list/dict element and therefore
* does not/does require a call to
* TclCopyAndCollapse() by the caller. */
{
const char *p = string;
const char *elemStart; /* Points to first byte of first element. */
const char *limit; /* Points just after list/dict's last byte. */
int openBraces = 0; /* Brace nesting level during parse. */
int inQuotes = 0;
int size = 0;
int numChars;
int literal = 1;
const char *p2;
/*
* Skim off leading white space and check for an opening brace or quote.
* We treat embedded NULLs in the list/dict as bytes belonging to a list
* element (or dictionary key or value).
*/
limit = (string + stringLength);
while ((p < limit) && (TclIsSpaceProcM(*p))) {
p++;
}
if (p == limit) { /* no element found */
elemStart = limit;
goto done;
}
|
| ︙ | ︙ | |||
627 628 629 630 631 632 633 |
case '}':
if (openBraces > 1) {
openBraces--;
} else if (openBraces == 1) {
size = (p - elemStart);
p++;
| | | | 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 |
case '}':
if (openBraces > 1) {
openBraces--;
} else if (openBraces == 1) {
size = (p - elemStart);
p++;
if ((p >= limit) || TclIsSpaceProcM(*p)) {
goto done;
}
/*
* Garbage after the closing brace; return an error.
*/
if (interp != NULL) {
p2 = p;
while ((p2 < limit) && (!TclIsSpaceProcM(*p2))
&& (p2 < p+20)) {
p2++;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s element in braces followed by \"%.*s\" "
"instead of space", typeStr, (int) (p2-p), p));
Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK",
|
| ︙ | ︙ | |||
671 672 673 674 675 676 677 | literal = 0; } TclParseBackslash(p, limit - p, &numChars, NULL); p += (numChars - 1); break; | < < < < < < < < < < < < < < < < < | | > > > > > > > > > > > > > > | 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 |
literal = 0;
}
TclParseBackslash(p, limit - p, &numChars, NULL);
p += (numChars - 1);
break;
/*
* Double-quote: if element is in quotes then terminate it.
*/
case '"':
if (inQuotes) {
size = (p - elemStart);
p++;
if ((p >= limit) || TclIsSpaceProcM(*p)) {
goto done;
}
/*
* Garbage after the closing quote; return an error.
*/
if (interp != NULL) {
p2 = p;
while ((p2 < limit) && (!TclIsSpaceProcM(*p2))
&& (p2 < p+20)) {
p2++;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s element in quotes followed by \"%.*s\" "
"instead of space", typeStr, (int) (p2-p), p));
Tcl_SetErrorCode(interp, "TCL", "VALUE", typeCode, "JUNK",
NULL);
}
return TCL_ERROR;
}
break;
default:
if (TclIsSpaceProcM(*p)) {
/*
* Space: ignore if element is in braces or quotes;
* otherwise terminate element.
*/
if ((openBraces == 0) && !inQuotes) {
size = (p - elemStart);
goto done;
}
}
break;
}
p++;
}
/*
* End of list/dict: terminate element.
*/
|
| ︙ | ︙ | |||
749 750 751 752 753 754 755 |
}
return TCL_ERROR;
}
size = (p - elemStart);
}
done:
| | | 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 |
}
return TCL_ERROR;
}
size = (p - elemStart);
}
done:
while ((p < limit) && (TclIsSpaceProcM(*p))) {
p++;
}
*elementPtr = elemStart;
*nextPtr = p;
if (sizePtr != 0) {
*sizePtr = size;
}
|
| ︙ | ︙ | |||
782 783 784 785 786 787 788 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | | | 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 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclCopyAndCollapse(
int count, /* Number of byte to copy from src. */
const char *src, /* Copy from here... */
char *dst) /* ... to here. */
{
int newCount = 0;
while (count > 0) {
char c = *src;
if (c == '\\') {
int numRead;
int backslashCount = TclParseBackslash(src, count, &numRead, dst);
dst += backslashCount;
newCount += backslashCount;
src += numRead;
count -= numRead;
} else {
*dst = c;
|
| ︙ | ︙ | |||
853 854 855 856 857 858 859 |
int *argcPtr, /* Pointer to location to fill in with the
* number of elements in the list. */
const char ***argvPtr) /* Pointer to place to store pointer to array
* of pointers to list elements. */
{
const char **argv, *end, *element;
char *p;
| | < | | | | 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 |
int *argcPtr, /* Pointer to location to fill in with the
* number of elements in the list. */
const char ***argvPtr) /* Pointer to place to store pointer to array
* of pointers to list elements. */
{
const char **argv, *end, *element;
char *p;
int length, size, i, result, elSize;
/*
* Allocate enough space to work in. A (const char *) for each (possible)
* list element plus one more for terminating NULL, plus as many bytes as
* in the original string value, plus one more for a terminating '\0'.
* Space used to hold element separating white space in the original
* string gets re-purposed to hold '\0' characters in the argv array.
*/
size = TclMaxListLength(list, -1, &end) + 1;
length = end - list;
argv = (const char **)ckalloc((size * sizeof(char *)) + length + 1);
for (i = 0, p = ((char *) argv) + size*sizeof(char *);
*list != 0; i++) {
const char *prevList = list;
int literal;
result = TclFindElement(interp, list, length, &element, &list,
&elSize, &literal);
length -= (list - prevList);
if (result != TCL_OK) {
ckfree(argv);
return result;
}
if (*element == 0) {
break;
}
if (i >= size) {
ckfree(argv);
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"internal error in Tcl_SplitList", -1));
Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList",
NULL);
}
return TCL_ERROR;
|
| ︙ | ︙ | |||
931 932 933 934 935 936 937 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_ScanElement(
const char *src, /* String to convert to list element. */
int *flagPtr) /* Where to store information to guide
* Tcl_ConvertCountedElement. */
{
return Tcl_ScanCountedElement(src, -1, flagPtr);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
963 964 965 966 967 968 969 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_ScanCountedElement(
const char *src, /* String to convert to Tcl list element. */
int length, /* Number of bytes in src, or -1. */
int *flagPtr) /* Where to store information to guide
* Tcl_ConvertElement. */
{
char flags = CONVERT_ANY;
int numBytes = TclScanElement(src, length, &flags);
*flagPtr = flags;
|
| ︙ | ︙ | |||
1007 1008 1009 1010 1011 1012 1013 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | | 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 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclScanElement(
const char *src, /* String to convert to Tcl list element. */
int length, /* Number of bytes in src, or -1. */
char *flagPtr) /* Where to store information to guide
* Tcl_ConvertElement. */
{
const char *p = src;
int nestingLevel = 0; /* Brace nesting count */
int forbidNone = 0; /* Do not permit CONVERT_NONE mode. Something
* needs protection or escape. */
int requireEscape = 0; /* Force use of CONVERT_ESCAPE mode. For some
* reason bare or brace-quoted form fails. */
int extra = 0; /* Count of number of extra bytes needed for
* formatted element, assuming we use escape
* sequences in formatting. */
int bytesNeeded; /* Buffer length computed to complete the
* element formatting in the selected mode. */
#if COMPAT
int preferEscape = 0; /* Use preferences to track whether to use */
int preferBrace = 0; /* CONVERT_MASK mode. */
int braceCount = 0; /* Count of all braces '{' '}' seen. */
#endif /* COMPAT */
if ((p == NULL) || (length == 0) || ((*p == '\0') && (length == -1))) {
/*
* Empty string element must be brace quoted.
*/
*flagPtr = CONVERT_BRACE;
return 2;
}
|
| ︙ | ︙ | |||
1106 1107 1108 1109 1110 1111 1112 | break; #else /* FLOW THROUGH */ #endif /* COMPAT */ case '[': /* TYPE_SUBS */ case '$': /* TYPE_SUBS */ case ';': /* TYPE_COMMAND_END */ | < < < < < < | | 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 |
break;
#else
/* FLOW THROUGH */
#endif /* COMPAT */
case '[': /* TYPE_SUBS */
case '$': /* TYPE_SUBS */
case ';': /* TYPE_COMMAND_END */
forbidNone = 1;
extra++; /* Escape sequences all one byte longer. */
#if COMPAT
preferBrace = 1;
#endif /* COMPAT */
break;
case '\\': /* TYPE_SUBS */
extra++; /* Escape '\' => '\\' */
if ((length == 1) || ((length == -1) && (p[1] == '\0'))) {
/*
* Final backslash. Cannot format with brace quoting.
*/
requireEscape = 1;
break;
}
|
| ︙ | ︙ | |||
1151 1152 1153 1154 1155 1156 1157 | } forbidNone = 1; #if COMPAT preferBrace = 1; #endif /* COMPAT */ break; case '\0': /* TYPE_SUBS */ | | > > > > > > > | > | > | | 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 |
}
forbidNone = 1;
#if COMPAT
preferBrace = 1;
#endif /* COMPAT */
break;
case '\0': /* TYPE_SUBS */
if (length == -1) {
goto endOfString;
}
/* TODO: Panic on improper encoding? */
break;
default:
if (TclIsSpaceProcM(*p)) {
forbidNone = 1;
extra++; /* Escape sequences all one byte longer. */
#if COMPAT
preferBrace = 1;
#endif
}
break;
}
}
length -= (length > 0);
p++;
}
endOfString:
if (nestingLevel != 0) {
/*
* Unbalanced braces! Cannot format with brace quoting.
|
| ︙ | ︙ | |||
1193 1194 1195 1196 1197 1198 1199 |
* Make room to escape leading #, if needed.
*/
if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
bytesNeeded++;
}
*flagPtr = CONVERT_ESCAPE;
| | | 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 |
* Make room to escape leading #, if needed.
*/
if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
bytesNeeded++;
}
*flagPtr = CONVERT_ESCAPE;
goto overflowCheck;
}
if (*flagPtr & CONVERT_ANY) {
/*
* The caller has not let us know what flags it will pass to
* TclConvertElement() so compute the max size we might need for any
* possible choice. Normally the formatting using escape sequences is
* the longer one, and a minimum "extra" value of 2 makes sure we
|
| ︙ | ︙ | |||
1241 1242 1243 1244 1245 1246 1247 |
* escape the braces.
*/
if (*flagPtr & TCL_DONT_USE_BRACES) {
bytesNeeded += braceCount;
}
*flagPtr = CONVERT_MASK;
| | | 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 |
* escape the braces.
*/
if (*flagPtr & TCL_DONT_USE_BRACES) {
bytesNeeded += braceCount;
}
*flagPtr = CONVERT_MASK;
goto overflowCheck;
}
#endif /* COMPAT */
if (*flagPtr & TCL_DONT_USE_BRACES) {
/*
* If the caller reports it will direct TclConvertElement() to
* use escapes, add the extra bytes needed to have room for them.
*/
|
| ︙ | ︙ | |||
1267 1268 1269 1270 1271 1272 1273 | /* * Add 2 bytes for room for the enclosing braces. */ bytesNeeded += 2; } *flagPtr = CONVERT_BRACE; | | > > > > > | 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 |
/*
* Add 2 bytes for room for the enclosing braces.
*/
bytesNeeded += 2;
}
*flagPtr = CONVERT_BRACE;
goto overflowCheck;
}
/*
* So far, no need to quote or escape anything.
*/
if ((*src == '#') && !(*flagPtr & TCL_DONT_QUOTE_HASH)) {
/*
* If we need to quote a leading #, make room to enclose in braces.
*/
bytesNeeded += 2;
}
*flagPtr = CONVERT_NONE;
overflowCheck:
if (bytesNeeded < 0) {
Tcl_Panic("TclScanElement: string length overflow");
}
return bytesNeeded;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ConvertElement --
|
| ︙ | ︙ | |||
1306 1307 1308 1309 1310 1311 1312 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_ConvertElement(
const char *src, /* Source information for list element. */
char *dst, /* Place to put list-ified element. */
int flags) /* Flags produced by Tcl_ScanElement. */
{
return Tcl_ConvertCountedElement(src, -1, dst, flags);
}
|
| ︙ | ︙ | |||
1336 1337 1338 1339 1340 1341 1342 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | | 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
Tcl_ConvertCountedElement(
const char *src, /* Source information for list element. */
int length, /* Number of bytes in src, or -1. */
char *dst, /* Place to put list-ified element. */
int flags) /* Flags produced by Tcl_ScanElement. */
{
int numBytes = TclConvertElement(src, length, dst, flags);
dst[numBytes] = '\0';
return numBytes;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1369 1370 1371 1372 1373 1374 1375 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | | | | | | | 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclConvertElement(
const char *src, /* Source information for list element. */
int length, /* Number of bytes in src, or -1. */
char *dst, /* Place to put list-ified element. */
int flags) /* Flags produced by Tcl_ScanElement. */
{
int conversion = flags & CONVERT_MASK;
char *p = dst;
/*
* Let the caller demand we use escape sequences rather than braces.
*/
if ((flags & TCL_DONT_USE_BRACES) && (conversion & CONVERT_BRACE)) {
conversion = CONVERT_ESCAPE;
}
/*
* No matter what the caller demands, empty string must be braced!
*/
if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) {
p[0] = '{';
p[1] = '}';
return 2;
}
/*
* Escape leading hash as needed and requested.
*/
if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) {
if (conversion == CONVERT_ESCAPE) {
p[0] = '\\';
p[1] = '#';
p += 2;
src++;
length -= (length > 0);
} else {
conversion = CONVERT_BRACE;
}
}
/*
* No escape or quoting needed. Copy the literal string value.
*/
if (conversion == CONVERT_NONE) {
if (length == -1) {
/* TODO: INT_MAX overflow? */
while (*src) {
*p++ = *src++;
}
return p - dst;
} else {
memcpy(dst, src, length);
return length;
}
}
/*
* Formatted string is original string enclosed in braces.
*/
if (conversion == CONVERT_BRACE) {
*p = '{';
p++;
if (length == -1) {
/* TODO: INT_MAX overflow? */
while (*src) {
*p++ = *src++;
}
} else {
memcpy(p, src, length);
p += length;
}
*p = '}';
p++;
return p - dst;
}
/* conversion == CONVERT_ESCAPE or CONVERT_MASK */
/*
* Formatted string is original string converted to escape sequences.
*/
for ( ; length; src++, length -= (length > 0)) {
switch (*src) {
case ']':
case '[':
case '$':
case ';':
case ' ':
case '\\':
|
| ︙ | ︙ | |||
1510 1511 1512 1513 1514 1515 1516 | case '\v': *p = '\\'; p++; *p = 'v'; p++; continue; case '\0': | | | | | 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 |
case '\v':
*p = '\\';
p++;
*p = 'v';
p++;
continue;
case '\0':
if (length == -1) {
return p - dst;
}
/*
* If we reach this point, there's an embedded NULL in the string
* range being processed, which should not happen when the
* encoding rules for Tcl strings are properly followed. If the
* day ever comes when we stop tolerating such things, this is
* where to put the Tcl_Panic().
*/
break;
}
*p = *src;
p++;
}
return p - dst;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Merge --
*
|
| ︙ | ︙ | |||
1557 1558 1559 1560 1561 1562 1563 |
char *
Tcl_Merge(
int argc, /* How many strings to merge. */
const char *const *argv) /* Array of string values. */
{
#define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
| < | | | > > > > > > | | > | < < > | > | > > < > | < | | > > | | | | > | | | < < < < < | | | | | > > | | > > | | | > > > > | | > > | > | < > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | > > | | > > > | > > > > | | | | 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 |
char *
Tcl_Merge(
int argc, /* How many strings to merge. */
const char *const *argv) /* Array of string values. */
{
#define LOCAL_SIZE 64
char localFlags[LOCAL_SIZE], *flagPtr = NULL;
int i, bytesNeeded = 0;
char *result, *dst;
/*
* Handle empty list case first, so logic of the general case can be
* simpler.
*/
if (argc == 0) {
result = (char *)ckalloc(1);
result[0] = '\0';
return result;
}
/*
* Pass 1: estimate space, gather flags.
*/
if (argc <= LOCAL_SIZE) {
flagPtr = localFlags;
} else {
flagPtr = (char *)ckalloc(argc);
}
for (i = 0; i < argc; i++) {
flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
bytesNeeded += TclScanElement(argv[i], -1, &flagPtr[i]);
if (bytesNeeded < 0) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
}
if (bytesNeeded > INT_MAX - argc + 1) {
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
}
bytesNeeded += argc;
/*
* Pass two: copy into the result area.
*/
result = (char *)ckalloc(bytesNeeded);
dst = result;
for (i = 0; i < argc; i++) {
flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 );
dst += TclConvertElement(argv[i], -1, dst, flagPtr[i]);
*dst = ' ';
dst++;
}
dst[-1] = 0;
if (flagPtr != localFlags) {
ckfree(flagPtr);
}
return result;
}
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
*----------------------------------------------------------------------
*
* Tcl_Backslash --
*
* Figure out how to handle a backslash sequence.
*
* Results:
* The return value is the character that should be substituted in place
* of the backslash sequence that starts at src. If readPtr isn't NULL
* then it is filled in with a count of the number of characters in the
* backslash sequence.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
char
Tcl_Backslash(
const char *src, /* Points to the backslash character of a
* backslash sequence. */
int *readPtr) /* Fill in with number of characters read from
* src, unless NULL. */
{
char buf[4] = "";
Tcl_UniChar ch = 0;
Tcl_UtfBackslash(src, readPtr, buf);
TclUtfToUniChar(buf, &ch);
return (char) ch;
}
#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* TclTrimRight --
* Takes two counted strings in the Tcl encoding. Conceptually
* finds the sub string (offset) to trim from the right side of the
* first string all characters found in the second string.
*
* Results:
* The number of bytes to be removed from the end of the string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclTrimRight(
const char *bytes, /* String to be trimmed... */
int numBytes, /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (bytes[numBytes] == '\0'). */
const char *trim, /* String of trim characters... */
int numTrim) /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (trim[numTrim] == '\0'). */
{
const char *pp, *p = bytes + numBytes;
int ch1, ch2;
/* Empty strings -> nothing to do */
if ((numBytes == 0) || (numTrim == 0)) {
return 0;
}
/*
* Outer loop: iterate over string to be trimmed.
*/
do {
const char *q = trim;
int pInc = 0, bytesLeft = numTrim;
pp = TclUtfPrev(p, bytes);
do {
pp += pInc;
pInc = TclUtfToUCS4(pp, &ch1);
} while (pp + pInc < p);
/*
* Inner loop: scan trim string for match to current character.
*/
do {
int qInc = TclUtfToUCS4(q, &ch2);
if (ch1 == ch2) {
break;
}
q += qInc;
bytesLeft -= qInc;
} while (bytesLeft);
if (bytesLeft == 0) {
/*
* No match; trim task done; *p is last non-trimmed char.
*/
break;
}
p = pp;
} while (p > bytes);
return numBytes - (p - bytes);
}
/*
*----------------------------------------------------------------------
*
* TclTrimLeft --
*
* Takes two counted strings in the Tcl encoding. Conceptually
* finds the sub string (offset) to trim from the left side of the
* first string all characters found in the second string.
*
* Results:
* The number of bytes to be removed from the start of the string.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclTrimLeft(
const char *bytes, /* String to be trimmed... */
int numBytes, /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (bytes[numBytes] == '\0'). */
const char *trim, /* String of trim characters... */
int numTrim) /* ...and its length in bytes */
/* Calls to TclUtfToUniChar() in this routine
* rely on (trim[numTrim] == '\0'). */
{
const char *p = bytes;
int ch1, ch2;
/* Empty strings -> nothing to do */
if ((numBytes == 0) || (numTrim == 0)) {
return 0;
}
/*
* Outer loop: iterate over string to be trimmed.
*/
do {
int pInc = TclUtfToUCS4(p, &ch1);
const char *q = trim;
int bytesLeft = numTrim;
/*
* Inner loop: scan trim string for match to current character.
*/
do {
int qInc = TclUtfToUCS4(q, &ch2);
if (ch1 == ch2) {
break;
}
q += qInc;
bytesLeft -= qInc;
|
| ︙ | ︙ | |||
1807 1808 1809 1810 1811 1812 1813 |
p += pInc;
numBytes -= pInc;
} while (numBytes > 0);
return p - bytes;
}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | > > | > > | | < < | < | | < < | | > > | > | > | | < < | | < | | | | | < < | | 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 |
p += pInc;
numBytes -= pInc;
} while (numBytes > 0);
return p - bytes;
}
/*
*----------------------------------------------------------------------
*
* TclTrim --
* Finds the sub string (offset) to trim from both sides of the
* first string all characters found in the second string.
*
* Results:
* The number of bytes to be removed from the start of the string
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclTrim(
const char *bytes, /* String to be trimmed... */
int numBytes, /* ...and its length in bytes */
/* Calls in this routine
* rely on (bytes[numBytes] == '\0'). */
const char *trim, /* String of trim characters... */
int numTrim, /* ...and its length in bytes */
/* Calls in this routine
* rely on (trim[numTrim] == '\0'). */
int *trimRightPtr) /* Offset from the end of the string. */
{
int trimLeft = 0, trimRight = 0;
/* Empty strings -> nothing to do */
if ((numBytes > 0) && (numTrim > 0)) {
/* When bytes is NUL-terminated, returns 0 <= trimLeft <= numBytes */
trimLeft = TclTrimLeft(bytes, numBytes, trim, numTrim);
numBytes -= trimLeft;
/* If we did not trim the whole string, it starts with a character
* that we will not trim. Skip over it. */
if (numBytes > 0) {
int ch;
const char *first = bytes + trimLeft;
bytes += TclUtfToUCS4(first, &ch);
numBytes -= (bytes - first);
if (numBytes > 0) {
/* When bytes is NUL-terminated, returns
* 0 <= trimRight <= numBytes */
trimRight = TclTrimRight(bytes, numBytes, trim, numTrim);
}
}
}
*trimRightPtr = trimRight;
return trimLeft;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Concat --
|
| ︙ | ︙ | |||
1917 1918 1919 1920 1921 1922 1923 | * Memory is allocated for the result; the caller is responsible for * freeing the memory. * *---------------------------------------------------------------------- */ /* The whitespace characters trimmed during [concat] operations */ | | < | | > > > > > > > > > > > | | | 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 |
* Memory is allocated for the result; the caller is responsible for
* freeing the memory.
*
*----------------------------------------------------------------------
*/
/* The whitespace characters trimmed during [concat] operations */
#define CONCAT_WS_SIZE (int) (sizeof(CONCAT_TRIM_SET "") - 1)
char *
Tcl_Concat(
int argc, /* Number of strings to concatenate. */
const char *const *argv) /* Array of strings to concatenate. */
{
int i, needSpace = 0, bytesNeeded = 0;
char *result, *p;
/*
* Dispose of the empty result corner case first to simplify later code.
*/
if (argc == 0) {
result = (char *) ckalloc(1);
result[0] = '\0';
return result;
}
/*
* First allocate the result buffer at the size required.
*/
for (i = 0; i < argc; i++) {
bytesNeeded += strlen(argv[i]);
if (bytesNeeded < 0) {
Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded");
}
}
if (bytesNeeded + argc - 1 < 0) {
/*
* Panic test could be tighter, but not going to bother for this
* legacy routine.
*/
Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded");
}
/*
* All element bytes + (argc - 1) spaces + 1 terminating NULL.
*/
result = (char *)ckalloc(bytesNeeded + argc);
for (p = result, i = 0; i < argc; i++) {
int triml, trimr, elemLength;
const char *element;
element = argv[i];
elemLength = strlen(argv[i]);
/* Trim away the leading/trailing whitespace. */
triml = TclTrim(element, elemLength, CONCAT_TRIM_SET,
|
| ︙ | ︙ | |||
2014 2015 2016 2017 2018 2019 2020 |
*/
Tcl_Obj *
Tcl_ConcatObj(
int objc, /* Number of objects to concatenate. */
Tcl_Obj *const objv[]) /* Array of objects to concatenate. */
{
| < | | | | 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 |
*/
Tcl_Obj *
Tcl_ConcatObj(
int objc, /* Number of objects to concatenate. */
Tcl_Obj *const objv[]) /* Array of objects to concatenate. */
{
int i, elemLength, needSpace = 0, bytesNeeded = 0;
const char *element;
Tcl_Obj *objPtr, *resPtr;
/*
* Check first to see if all the items are of list type or empty. If so,
* we will concat them together as lists, and return a list object. This
* is only valid when the lists are in canonical form.
*/
for (i = 0; i < objc; i++) {
int length;
objPtr = objv[i];
if (TclListObjIsCanonical(objPtr)) {
continue;
}
TclGetStringFromObj(objPtr, &length);
if (length > 0) {
break;
}
}
if (i == objc) {
resPtr = NULL;
for (i = 0; i < objc; i++) {
|
| ︙ | ︙ | |||
2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 |
*
* First try to pre-allocate the size required.
*/
for (i = 0; i < objc; i++) {
element = TclGetStringFromObj(objv[i], &elemLength);
bytesNeeded += elemLength;
}
/*
* Does not matter if this fails, will simply try later to build up the
* string with each Append reallocating as needed with the usual string
* append algorithm. When that fails it will report the error.
*/
TclNewObj(resPtr);
(void) Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1);
Tcl_SetObjLength(resPtr, 0);
for (i = 0; i < objc; i++) {
| > > > | | 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 |
*
* First try to pre-allocate the size required.
*/
for (i = 0; i < objc; i++) {
element = TclGetStringFromObj(objv[i], &elemLength);
bytesNeeded += elemLength;
if (bytesNeeded < 0) {
break;
}
}
/*
* Does not matter if this fails, will simply try later to build up the
* string with each Append reallocating as needed with the usual string
* append algorithm. When that fails it will report the error.
*/
TclNewObj(resPtr);
(void) Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1);
Tcl_SetObjLength(resPtr, 0);
for (i = 0; i < objc; i++) {
int triml, trimr;
element = TclGetStringFromObj(objv[i], &elemLength);
/* Trim away the leading/trailing whitespace. */
triml = TclTrim(element, elemLength, CONCAT_TRIM_SET,
CONCAT_WS_SIZE, &trimr);
element += triml;
|
| ︙ | ︙ | |||
2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 |
}
Tcl_AppendToObj(resPtr, element, elemLength);
needSpace = 1;
}
return resPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_StringCaseMatch --
*
* See if a particular string matches a particular pattern. Allows case
* insensitivity.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
}
Tcl_AppendToObj(resPtr, element, elemLength);
needSpace = 1;
}
return resPtr;
}
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
*----------------------------------------------------------------------
*
* Tcl_StringMatch --
*
* See if a particular string matches a particular pattern.
*
* Results:
* The return value is 1 if string matches pattern, and 0 otherwise. The
* matching operation permits the following special characters in the
* pattern: *?\[] (see the manual entry for details on what these mean).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#undef Tcl_StringMatch
int
Tcl_StringMatch(
const char *str, /* String. */
const char *pattern) /* Pattern, which may contain special
* characters. */
{
return Tcl_StringCaseMatch(str, pattern, 0);
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_StringCaseMatch --
*
* See if a particular string matches a particular pattern. Allows case
* insensitivity.
|
| ︙ | ︙ | |||
2145 2146 2147 2148 2149 2150 2151 |
Tcl_StringCaseMatch(
const char *str, /* String. */
const char *pattern, /* Pattern, which may contain special
* characters. */
int nocase) /* 0 for case sensitive, 1 for insensitive */
{
int p, charLen;
| < | | 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 |
Tcl_StringCaseMatch(
const char *str, /* String. */
const char *pattern, /* Pattern, which may contain special
* characters. */
int nocase) /* 0 for case sensitive, 1 for insensitive */
{
int p, charLen;
int ch1 = 0, ch2 = 0;
while (1) {
p = *pattern;
/*
* See if we're at the end of both the pattern and the string. If so,
* we succeeded. If we're at the end of the pattern but not at the end
|
| ︙ | ︙ | |||
2187 2188 2189 2190 2191 2192 2193 |
}
/*
* This is a special case optimization for single-byte utf.
*/
if (UCHAR(*pattern) < 0x80) {
| | | | | | | | | | | | | | | > | > > | | 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 |
}
/*
* This is a special case optimization for single-byte utf.
*/
if (UCHAR(*pattern) < 0x80) {
ch2 = (int)
(nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
} else {
TclUtfToUCS4(pattern, &ch2);
if (nocase) {
ch2 = Tcl_UniCharToLower(ch2);
}
}
while (1) {
/*
* Optimization for matching - cruise through the string
* quickly if the next char in the pattern isn't a special
* character
*/
if ((p != '[') && (p != '?') && (p != '\\')) {
if (nocase) {
while (*str) {
charLen = TclUtfToUCS4(str, &ch1);
if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) {
break;
}
str += charLen;
}
} else {
/*
* There's no point in trying to make this code
* shorter, as the number of bytes you want to compare
* each time is non-constant.
*/
while (*str) {
charLen = TclUtfToUCS4(str, &ch1);
if (ch2 == ch1) {
break;
}
str += charLen;
}
}
}
if (Tcl_StringCaseMatch(str, pattern, nocase)) {
return 1;
}
if (*str == '\0') {
return 0;
}
str += TclUtfToUCS4(str, &ch1);
}
}
/*
* Check for a "?" as the next pattern character. It matches any
* single character.
*/
if (p == '?') {
pattern++;
str += TclUtfToUCS4(str, &ch1);
continue;
}
/*
* Check for a "[" as the next pattern character. It is followed by a
* list of characters that are acceptable, or by a range (two
* characters separated by "-").
*/
if (p == '[') {
int startChar = 0, endChar = 0;
pattern++;
if (UCHAR(*str) < 0x80) {
ch1 = (int)
(nocase ? tolower(UCHAR(*str)) : UCHAR(*str));
str++;
} else {
str += TclUtfToUCS4(str, &ch1);
if (nocase) {
ch1 = Tcl_UniCharToLower(ch1);
}
}
while (1) {
if ((*pattern == ']') || (*pattern == '\0')) {
return 0;
}
if (UCHAR(*pattern) < 0x80) {
startChar = (int) (nocase
? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
pattern++;
} else {
pattern += TclUtfToUCS4(pattern, &startChar);
if (nocase) {
startChar = Tcl_UniCharToLower(startChar);
}
}
if (*pattern == '-') {
pattern++;
if (*pattern == '\0') {
return 0;
}
if (UCHAR(*pattern) < 0x80) {
endChar = (int) (nocase
? tolower(UCHAR(*pattern)) : UCHAR(*pattern));
pattern++;
} else {
pattern += TclUtfToUCS4(pattern, &endChar);
if (nocase) {
endChar = Tcl_UniCharToLower(endChar);
}
}
if (((startChar <= ch1) && (ch1 <= endChar))
|| ((endChar <= ch1) && (ch1 <= startChar))) {
/*
* Matches ranges of form [a-z] or [z-a].
*/
break;
}
} else if (startChar == ch1) {
break;
}
}
/* If we reach here, we matched. Need to move past closing ] */
while (*pattern != ']') {
if (*pattern == '\0') {
/* We ran out of pattern after matching something in
* (unclosed!) brackets. So long as we ran out of string
* at the same time, we have a match. Otherwise, not. */
return (*str == '\0');
}
pattern++;
}
pattern++;
continue;
}
|
| ︙ | ︙ | |||
2338 2339 2340 2341 2342 2343 2344 | } /* * There's no special character. Just make sure that the next bytes of * each string match. */ | | | | 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 |
}
/*
* There's no special character. Just make sure that the next bytes of
* each string match.
*/
str += TclUtfToUCS4(str, &ch1);
pattern += TclUtfToUCS4(pattern, &ch2);
if (nocase) {
if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) {
return 0;
}
} else if (ch1 != ch2) {
return 0;
}
|
| ︙ | ︙ | |||
2373 2374 2375 2376 2377 2378 2379 |
*
*----------------------------------------------------------------------
*/
int
TclByteArrayMatch(
const unsigned char *string,/* String. */
| | | | | 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 |
*
*----------------------------------------------------------------------
*/
int
TclByteArrayMatch(
const unsigned char *string,/* String. */
int strLen, /* Length of String */
const unsigned char *pattern,
/* Pattern, which may contain special
* characters. */
int ptnLen, /* Length of Pattern */
TCL_UNUSED(int) /*flags*/)
{
const unsigned char *stringEnd, *patternEnd;
unsigned char p;
stringEnd = string + strLen;
patternEnd = pattern + ptnLen;
|
| ︙ | ︙ | |||
2554 2555 2556 2557 2558 2559 2560 |
int
TclStringMatchObj(
Tcl_Obj *strObj, /* string object. */
Tcl_Obj *ptnObj, /* pattern object. */
int flags) /* Only TCL_MATCH_NOCASE should be passed, or
* 0. */
{
| | < | | | | | 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 |
int
TclStringMatchObj(
Tcl_Obj *strObj, /* string object. */
Tcl_Obj *ptnObj, /* pattern object. */
int flags) /* Only TCL_MATCH_NOCASE should be passed, or
* 0. */
{
int match, length, plen;
/*
* Promote based on the type of incoming object.
* XXX: Currently doesn't take advantage of exact-ness that
* XXX: TclReToGlob tells us about
trivial = nocase ? 0 : TclMatchIsTrivial(TclGetString(ptnObj));
*/
if (TclHasIntRep(strObj, &tclStringType) || (strObj->typePtr == NULL)) {
Tcl_UniChar *udata, *uptn;
udata = Tcl_GetUnicodeFromObj(strObj, &length);
uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen);
match = TclUniCharMatch(udata, length, uptn, plen, flags);
} else if (TclIsPureByteArray(strObj) && TclIsPureByteArray(ptnObj)
&& !flags) {
unsigned char *data, *ptn;
data = Tcl_GetByteArrayFromObj(strObj, &length);
ptn = Tcl_GetByteArrayFromObj(ptnObj, &plen);
match = TclByteArrayMatch(data, length, ptn, plen, 0);
} else {
match = Tcl_StringCaseMatch(TclGetString(strObj),
TclGetString(ptnObj), flags);
}
return match;
}
|
| ︙ | ︙ | |||
2633 2634 2635 2636 2637 2638 2639 |
*
*----------------------------------------------------------------------
*/
char *
Tcl_DStringAppend(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
| | | | | | | | | | | | | | 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 |
*
*----------------------------------------------------------------------
*/
char *
Tcl_DStringAppend(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
const char *bytes, /* String to append. If length is -1 then this
* must be null-terminated. */
int length) /* Number of bytes from "bytes" to append. If
* < 0, then append all of bytes, up to null
* at end. */
{
int newSize;
if (length < 0) {
length = strlen(bytes);
}
newSize = length + dsPtr->length;
/*
* Allocate a larger buffer for the string if the current one isn't large
* enough. Allocate extra space in the new buffer so that there will be
* room to grow before we have to allocate again.
*/
if (newSize >= dsPtr->spaceAvl) {
dsPtr->spaceAvl = newSize * 2;
if (dsPtr->string == dsPtr->staticSpace) {
char *newString = (char *)ckalloc(dsPtr->spaceAvl);
memcpy(newString, dsPtr->string, dsPtr->length);
dsPtr->string = newString;
} else {
int offset = -1;
/* See [16896d49fd] */
if (bytes >= dsPtr->string
&& bytes <= dsPtr->string + dsPtr->length) {
offset = bytes - dsPtr->string;
}
dsPtr->string = (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl);
if (offset >= 0) {
bytes = dsPtr->string + offset;
}
}
}
/*
* Copy the new string into the buffer at the end of the old one.
*/
|
| ︙ | ︙ | |||
2702 2703 2704 2705 2706 2707 2708 |
*/
char *
TclDStringAppendObj(
Tcl_DString *dsPtr,
Tcl_Obj *objPtr)
{
| | | | 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 |
*/
char *
TclDStringAppendObj(
Tcl_DString *dsPtr,
Tcl_Obj *objPtr)
{
int length;
char *bytes = TclGetStringFromObj(objPtr, &length);
return Tcl_DStringAppend(dsPtr, bytes, length);
}
char *
TclDStringAppendDString(
Tcl_DString *dsPtr,
|
| ︙ | ︙ | |||
2743 2744 2745 2746 2747 2748 2749 |
Tcl_DStringAppendElement(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
const char *element) /* String to append. Must be
* null-terminated. */
{
char *dst = dsPtr->string + dsPtr->length;
int needSpace = TclNeedSpace(dsPtr->string, dst);
| | > | > > > > > > > > > > > > > > > > > > > > > > > > | > > > | | < > | < < < < < < < | > | | > > > | | | 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 |
Tcl_DStringAppendElement(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
const char *element) /* String to append. Must be
* null-terminated. */
{
char *dst = dsPtr->string + dsPtr->length;
int needSpace = TclNeedSpace(dsPtr->string, dst);
char flags = 0;
int quoteHash = 1, newSize;
if (needSpace) {
/*
* If we need a space to separate the new element from something
* already ending the string, we're not appending the first element
* of any list, so we need not quote any leading hash character.
*/
quoteHash = 0;
} else {
/*
* We don't need a space, maybe because there's some already there.
* Checking whether we might be appending a first element is a bit
* more involved.
*
* Backtrack over all whitespace.
*/
while ((--dst >= dsPtr->string) && TclIsSpaceProcM(*dst)) {
}
/* Call again without whitespace to confound things. */
quoteHash = !TclNeedSpace(dsPtr->string, dst+1);
}
if (!quoteHash) {
flags |= TCL_DONT_QUOTE_HASH;
}
newSize = dsPtr->length + needSpace + TclScanElement(element, -1, &flags);
if (!quoteHash) {
flags |= TCL_DONT_QUOTE_HASH;
}
/*
* Allocate a larger buffer for the string if the current one isn't large
* enough. Allocate extra space in the new buffer so that there will be
* room to grow before we have to allocate again. SPECIAL NOTE: must use
* memcpy, not strcpy, to copy the string to a larger buffer, since there
* may be embedded NULLs in the string in some cases.
*/
if (newSize >= dsPtr->spaceAvl) {
dsPtr->spaceAvl = newSize * 2;
if (dsPtr->string == dsPtr->staticSpace) {
char *newString = (char *)ckalloc(dsPtr->spaceAvl);
memcpy(newString, dsPtr->string, dsPtr->length);
dsPtr->string = newString;
} else {
int offset = -1;
/* See [16896d49fd] */
if (element >= dsPtr->string
&& element <= dsPtr->string + dsPtr->length) {
offset = element - dsPtr->string;
}
dsPtr->string = (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl);
if (offset >= 0) {
element = dsPtr->string + offset;
}
}
}
dst = dsPtr->string + dsPtr->length;
/*
* Convert the new string to a list element and copy it into the buffer at
* the end, with a space, if needed.
*/
if (needSpace) {
*dst = ' ';
dst++;
dsPtr->length++;
}
dsPtr->length += TclConvertElement(element, -1, dst, flags);
dsPtr->string[dsPtr->length] = '\0';
return dsPtr->string;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DStringSetLength --
*
* Change the length of a dynamic string. This can cause the string to
* either grow or shrink, depending on the value of length.
*
* Results:
* None.
*
* Side effects:
* The length of dsPtr is changed to length and a null byte is stored at
* that position in the string. If length is larger than the space
* allocated for dsPtr, then a panic occurs.
*
*----------------------------------------------------------------------
*/
void
Tcl_DStringSetLength(
Tcl_DString *dsPtr, /* Structure describing dynamic string. */
int length) /* New length for dynamic string. */
{
int newsize;
if (length < 0) {
length = 0;
}
if (length >= dsPtr->spaceAvl) {
/*
* There are two interesting cases here. In the first case, the user
* may be trying to allocate a large buffer of a specific size. It
* would be wasteful to overallocate that buffer, so we just allocate
* enough for the requested size plus the trailing null byte. In the
* second case, we are growing the buffer incrementally, so we need
* behavior similar to Tcl_DStringAppend. The requested length will
* usually be a small delta above the current spaceAvl, so we'll end
* up doubling the old size. This won't grow the buffer quite as
* quickly, but it should be close enough.
*/
newsize = dsPtr->spaceAvl * 2;
if (length < newsize) {
dsPtr->spaceAvl = newsize;
} else {
dsPtr->spaceAvl = length + 1;
}
if (dsPtr->string == dsPtr->staticSpace) {
char *newString = (char *)ckalloc(dsPtr->spaceAvl);
memcpy(newString, dsPtr->string, dsPtr->length);
dsPtr->string = newString;
} else {
dsPtr->string = (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl);
}
}
dsPtr->length = length;
dsPtr->string[length] = 0;
}
/*
|
| ︙ | ︙ | |||
2883 2884 2885 2886 2887 2888 2889 |
*/
void
Tcl_DStringFree(
Tcl_DString *dsPtr) /* Structure describing dynamic string. */
{
if (dsPtr->string != dsPtr->staticSpace) {
| | | 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 |
*/
void
Tcl_DStringFree(
Tcl_DString *dsPtr) /* Structure describing dynamic string. */
{
if (dsPtr->string != dsPtr->staticSpace) {
ckfree(dsPtr->string);
}
dsPtr->string = dsPtr->staticSpace;
dsPtr->length = 0;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
dsPtr->staticSpace[0] = '\0';
}
|
| ︙ | ︙ | |||
2945 2946 2947 2948 2949 2950 2951 2952 |
void
Tcl_DStringGetResult(
Tcl_Interp *interp, /* Interpreter whose result is to be reset. */
Tcl_DString *dsPtr) /* Dynamic string that is to become the result
* of interp. */
{
Tcl_Obj *obj = Tcl_GetObjResult(interp);
| > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 |
void
Tcl_DStringGetResult(
Tcl_Interp *interp, /* Interpreter whose result is to be reset. */
Tcl_DString *dsPtr) /* Dynamic string that is to become the result
* of interp. */
{
#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
Tcl_Obj *obj = Tcl_GetObjResult(interp);
const char *bytes = TclGetString(obj);
Tcl_DStringFree(dsPtr);
Tcl_DStringAppend(dsPtr, bytes, obj->length);
Tcl_ResetResult(interp);
#else
Interp *iPtr = (Interp *) interp;
if (dsPtr->string != dsPtr->staticSpace) {
ckfree(dsPtr->string);
}
/*
* Do more efficient transfer when we know the result is a Tcl_Obj. When
* there's no string result, we only have to deal with two cases:
*
* 1. When the string rep is the empty string, when we don't copy but
* instead use the staticSpace in the DString to hold an empty string.
* 2. When the string rep is not there or there's a real string rep, when
* we use Tcl_GetString to fetch (or generate) the string rep - which
* we know to have been allocated with ckalloc() - and use it to
* populate the DString space. Then, we free the internal rep. and set
* the object's string representation back to the canonical empty
* string.
*/
if (!iPtr->result[0] && iPtr->objResultPtr
&& !Tcl_IsShared(iPtr->objResultPtr)) {
if (iPtr->objResultPtr->bytes == &tclEmptyString) {
dsPtr->string = dsPtr->staticSpace;
dsPtr->string[0] = 0;
dsPtr->length = 0;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
} else {
dsPtr->string = TclGetString(iPtr->objResultPtr);
dsPtr->length = iPtr->objResultPtr->length;
dsPtr->spaceAvl = dsPtr->length + 1;
TclFreeIntRep(iPtr->objResultPtr);
iPtr->objResultPtr->bytes = &tclEmptyString;
iPtr->objResultPtr->length = 0;
}
return;
}
/*
* If the string result is empty, move the object result to the string
* result, then reset the object result.
*/
(void) Tcl_GetStringResult(interp);
dsPtr->length = strlen(iPtr->result);
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
dsPtr->string = iPtr->result;
dsPtr->spaceAvl = dsPtr->length+1;
} else {
dsPtr->string = (char *)ckalloc(dsPtr->length+1);
memcpy(dsPtr->string, iPtr->result, dsPtr->length+1);
iPtr->freeProc(iPtr->result);
}
dsPtr->spaceAvl = dsPtr->length+1;
iPtr->freeProc = NULL;
} else {
if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) {
dsPtr->string = dsPtr->staticSpace;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
} else {
dsPtr->string = (char *)ckalloc(dsPtr->length+1);
dsPtr->spaceAvl = dsPtr->length + 1;
}
memcpy(dsPtr->string, iPtr->result, dsPtr->length+1);
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
#endif /* !TCL_NO_DEPRECATED */
}
/*
*----------------------------------------------------------------------
*
* TclDStringToObj --
*
|
| ︙ | ︙ | |||
3076 3077 3078 3079 3080 3081 3082 | * * Tcl_PrintDouble -- * * Given a floating-point value, this function converts it to an ASCII * string using. * * Results: | | > | | | > | 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 |
*
* Tcl_PrintDouble --
*
* Given a floating-point value, this function converts it to an ASCII
* string using.
*
* Results:
* The ASCII equivalent of "value" is written at "dst". It is written
* using the current precision, and it is guaranteed to contain a decimal
* point or exponent, so that it looks like a floating-point value and
* not an integer.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
Tcl_PrintDouble(
TCL_UNUSED(Tcl_Interp *),
double value, /* Value to print as string. */
char *dst) /* Where to store converted value; must have
* at least TCL_DOUBLE_SPACE characters. */
{
char *p, c;
int exponent;
int signum;
char *digits;
char *end;
int *precisionPtr = (int *)Tcl_GetThreadData(&precisionKey, sizeof(int));
/*
* Handle NaN.
*/
if (TclIsNaN(value)) {
TclFormatNaN(value, dst);
|
| ︙ | ︙ | |||
3129 3130 3131 3132 3133 3134 3135 |
return;
}
/*
* Ordinary (normal and denormal) values.
*/
| > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 |
return;
}
/*
* Ordinary (normal and denormal) values.
*/
if (*precisionPtr == 0) {
digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST,
&exponent, &signum, &end);
} else {
/*
* There are at least two possible interpretations for tcl_precision.
*
* The first is, "choose the decimal representation having
* $tcl_precision digits of significance that is nearest to the given
* number, breaking ties by rounding to even, and then trimming
* trailing zeros." This gives the greatest possible precision in the
* decimal string, but offers the anomaly that [expr 0.1] will be
* "0.10000000000000001".
*
* The second is "choose the decimal representation having at most
* $tcl_precision digits of significance that is nearest to the given
* number. If no such representation converts exactly to the given
* number, choose the one that is closest, breaking ties by rounding
* to even. If more than one such representation converts exactly to
* the given number, choose the shortest, breaking ties in favour of
* the nearest, breaking remaining ties in favour of the one ending in
* an even digit."
*
* Tcl 8.4 implements the first of these, which gives rise to
* anomalies in formatting:
*
* % expr 0.1
* 0.10000000000000001
* % expr 0.01
* 0.01
* % expr 1e-7
* 9.9999999999999995e-08
*
* For human readability, it appears better to choose the second rule,
* and let [expr 0.1] return 0.1. But for 8.4 compatibility, we prefer
* the first (the recommended zero value for tcl_precision avoids the
* problem entirely).
*
* Uncomment TCL_DD_SHORTEST in the next call to prefer the method
* that allows floating point values to be shortened if it can be done
* without loss of precision.
*/
digits = TclDoubleDigits(value, *precisionPtr,
TCL_DD_E_FORMAT /* | TCL_DD_SHORTEST */,
&exponent, &signum, &end);
}
if (signum) {
*dst++ = '-';
}
p = digits;
if (exponent < -4 || exponent > 16) {
/*
* E format for numbers < 1e-3 or >= 1e17.
*/
*dst++ = *p++;
c = *p;
if (c != '\0') {
*dst++ = '.';
while (c != '\0') {
*dst++ = c;
c = *++p;
}
}
/*
* Tcl 8.4 appears to format with at least a two-digit exponent;
* preserve that behaviour when tcl_precision != 0
*/
if (*precisionPtr == 0) {
sprintf(dst, "e%+d", exponent);
} else {
sprintf(dst, "e%+03d", exponent);
}
} else {
/*
* F format for others.
*/
if (exponent < 0) {
*dst++ = '0';
|
| ︙ | ︙ | |||
3182 3183 3184 3185 3186 3187 3188 |
while (c != '\0') {
*dst++ = c;
c = *++p;
}
}
*dst++ = '\0';
}
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 |
while (c != '\0') {
*dst++ = c;
c = *++p;
}
}
*dst++ = '\0';
}
ckfree(digits);
}
/*
*----------------------------------------------------------------------
*
* TclPrecTraceProc --
*
* This function is invoked whenever the variable "tcl_precision" is
* written.
*
* Results:
* Returns NULL if all went well, or an error message if the new value
* for the variable doesn't make sense.
*
* Side effects:
* If the new value doesn't make sense then this function undoes the
* effect of the variable modification. Otherwise it modifies the format
* string that's used by Tcl_PrintDouble.
*
*----------------------------------------------------------------------
*/
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
char *
TclPrecTraceProc(
ClientData clientData,
Tcl_Interp *interp, /* Interpreter containing variable. */
const char *name1, /* Name of variable. */
const char *name2, /* Second part of variable name. */
int flags) /* Information about what happened. */
{
Tcl_Obj *value;
Tcl_WideInt prec;
int *precisionPtr = (int *)Tcl_GetThreadData(&precisionKey, sizeof(int));
/*
* If the variable is unset, then recreate the trace.
*/
if (flags & TCL_TRACE_UNSETS) {
if ((flags & TCL_TRACE_DESTROYED) && !Tcl_InterpDeleted(interp)) {
Tcl_TraceVar2(interp, name1, name2,
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
|TCL_TRACE_UNSETS, TclPrecTraceProc, clientData);
}
return NULL;
}
/*
* When the variable is read, reset its value from our shared value. This
* is needed in case the variable was modified in some other interpreter
* so that this interpreter's value is out of date.
*/
if (flags & TCL_TRACE_READS) {
Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewWideIntObj(*precisionPtr),
flags & TCL_GLOBAL_ONLY);
return NULL;
}
/*
* The variable is being written. Check the new value and disallow it if
* it isn't reasonable or if this is a safe interpreter (we don't want
* safe interpreters messing up the precision of other interpreters).
*/
if (Tcl_IsSafe(interp)) {
return (char *) "can't modify precision from a safe interpreter";
}
value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
if (value == NULL
|| Tcl_GetWideIntFromObj(NULL, value, &prec) != TCL_OK
|| prec < 0 || prec > TCL_MAX_PREC) {
return (char *) "improper value for precision";
}
*precisionPtr = (int)prec;
return NULL;
}
#endif /* !TCL_NO_DEPRECATED)*/
/*
*----------------------------------------------------------------------
*
* TclNeedSpace --
*
* This function checks to see whether it is appropriate to add a space
|
| ︙ | ︙ | |||
3211 3212 3213 3214 3215 3216 3217 |
const char *start, /* First character in string. */
const char *end) /* End of string (place where space will be
* added, if appropriate). */
{
/*
* A space is needed unless either:
* (a) we're at the start of the string, or
| < > > > > > > < | > > > > > > > > > > > | | | | > > > > > > > > > | | < < < < < < < < > > | < < < < < > | > | | < < < < < < < < | < | 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 |
const char *start, /* First character in string. */
const char *end) /* End of string (place where space will be
* added, if appropriate). */
{
/*
* A space is needed unless either:
* (a) we're at the start of the string, or
*
* (NOTE: This check is now absorbed into the loop below.)
*
if (end == start) {
return 0;
}
*
*/
/*
* (b) we're at the start of a nested list-element, quoted with an open
* curly brace; we can be nested arbitrarily deep, so long as the
* first curly brace starts an element, so backtrack over open curly
* braces that are trailing characters of the string; and
*
* (NOTE: Every character our parser is looking for is a proper
* single-byte encoding of an ASCII value. It does not accept
* overlong encodings. Given that, there's no benefit using
* Tcl_UtfPrev. If it would find what we seek, so would byte-by-byte
* backward scan. Save routine call overhead and risk of wrong
* results should the behavior of Tcl_UtfPrev change in unexpected ways.
* Reconsider this if we ever start treating non-ASCII Unicode
* characters as meaningful list syntax, expanded Unicode spaces as
* element separators, for example.)
*
end = Tcl_UtfPrev(end, start);
while (*end == '{') {
if (end == start) {
return 0;
}
end = Tcl_UtfPrev(end, start);
}
*
*/
while ((--end >= start) && (*end == '{')) {
}
if (end < start) {
return 0;
}
/*
* (c) the trailing character of the string is already a list-element
* separator, Use the same testing routine as TclFindElement to
* enforce consistency.
*/
if (TclIsSpaceProcM(*end)) {
int result = 0;
/*
* Trailing whitespace might be part of a backslash escape
* sequence. Handle that possibility.
*/
while ((--end >= start) && (*end == '\\')) {
result = !result;
}
return result;
}
return 1;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3297 3298 3299 3300 3301 3302 3303 | * Side effects: * The formatted characters are written into the storage pointer to by * the "buffer" argument. * *---------------------------------------------------------------------- */ | | | > | | < < < < < < < < < < < < < < < < < < < < < | < < < | | < | > | | 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 |
* Side effects:
* The formatted characters are written into the storage pointer to by
* the "buffer" argument.
*
*----------------------------------------------------------------------
*/
int
TclFormatInt(
char *buffer, /* Points to the storage into which the
* formatted characters are written. */
Tcl_WideInt n) /* The integer to format. */
{
Tcl_WideUInt intVal;
int i = 0;
int numFormatted, j;
static const char digits[] = "0123456789";
/*
* Generate the characters of the result backwards in the buffer.
*/
intVal = (n < 0 ? -(Tcl_WideUInt)n : (Tcl_WideUInt)n);
do {
buffer[i++] = digits[intVal % 10];
intVal = intVal / 10;
} while (intVal > 0);
if (n < 0) {
buffer[i++] = '-';
}
buffer[i] = '\0';
numFormatted = i--;
/*
* Now reverse the characters.
*/
for (j = 0; j < i; j++, i--) {
char tmp = buffer[i];
|
| ︙ | ︙ | |||
3388 3389 3390 3391 3392 3393 3394 |
*
*----------------------------------------------------------------------
*/
static int
GetWideForIndex(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
| | | | > < < | < < < < | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | < | | < < < > | | < | < | | | | | < < | > > > | | | | | | > | | > > > > > > > > > > > > | > | > > > > | > | > | > > > > > > | > > > > > | > > > > > | > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | | | | > > > > > > > > > > > > | | | | | | | > > > > > > > > > > > > > > > > | 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 |
*
*----------------------------------------------------------------------
*/
static int
GetWideForIndex(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
Tcl_Obj *objPtr, /* Points to the value to be parsed */
size_t endValue, /* The value to be stored at *widePtr if
* objPtr holds "end".
* NOTE: this value may be TCL_INDEX_NONE. */
Tcl_WideInt *widePtr) /* Location filled in with a wide integer
* representing an index. */
{
int numType;
ClientData cd;
int code = TclGetNumberFromObj(NULL, objPtr, &cd, &numType);
if (code == TCL_OK) {
if (numType == TCL_NUMBER_INT) {
/* objPtr holds an integer in the signed wide range */
*widePtr = *(Tcl_WideInt *)cd;
return TCL_OK;
}
if (numType == TCL_NUMBER_BIG) {
/* objPtr holds an integer outside the signed wide range */
/* Truncate to the signed wide range. */
*widePtr = ((mp_isneg((mp_int *)cd)) ? WIDE_MIN : WIDE_MAX);
return TCL_OK;
}
}
/* objPtr does not hold a number, check the end+/- format... */
return GetEndOffsetFromObj(interp, objPtr, endValue, widePtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetIntForIndex --
*
* This function returns an integer corresponding to the list index held
* in a Tcl object. The Tcl object's value is expected to be in the
* format integer([+-]integer)? or the format end([+-]integer)?.
*
* Results:
* The return value is normally TCL_OK, which means that the index was
* successfully stored into the location referenced by "indexPtr". If the
* Tcl object referenced by "objPtr" has the value "end", the value
* stored is "endValue". If "objPtr"s values is not of one of the
* expected formats, TCL_ERROR is returned and, if "interp" is non-NULL,
* an error message is left in the interpreter's result object.
*
* Side effects:
* The object referenced by "objPtr" might be converted to an integer,
* wide integer, or end-based-index object.
*
*----------------------------------------------------------------------
*/
int
Tcl_GetIntForIndex(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
Tcl_Obj *objPtr, /* Points to an object containing either "end"
* or an integer. */
int endValue, /* The value to be stored at "indexPtr" if
* "objPtr" holds "end". */
int *indexPtr) /* Location filled in with an integer
* representing an index. May be NULL.*/
{
Tcl_WideInt wide;
if (GetWideForIndex(interp, objPtr, (size_t)(endValue + 1) - 1, &wide) == TCL_ERROR) {
return TCL_ERROR;
}
if (indexPtr != NULL) {
if ((wide < 0) && (endValue > TCL_INDEX_END)) {
*indexPtr = -1;
} else if (wide > INT_MAX) {
*indexPtr = INT_MAX;
} else if (wide < INT_MIN) {
*indexPtr = INT_MIN;
} else {
*indexPtr = (int) wide;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* GetEndOffsetFromObj --
*
* Look for a string of the form "end[+-]offset" or "offset[+-]offset" and
* convert it to an internal representation.
*
* The internal representation (wideValue) uses the following encoding:
*
* WIDE_MIN: Index value TCL_INDEX_NONE (or -1)
* WIDE_MIN+1: Index value n, for any n < -1 (usually same effect as -1)
* -$n: Index "end-[expr {$n-1}]"
* -2: Index "end-1"
* -1: Index "end"
* 0: Index "0"
* WIDE_MAX-1: Index "end+n", for any n > 1
* WIDE_MAX: Index "end+1"
*
* Results:
* Tcl return code.
*
* Side effects:
* May store a Tcl_ObjType.
*
*----------------------------------------------------------------------
*/
static int
GetEndOffsetFromObj(
Tcl_Interp *interp,
Tcl_Obj *objPtr, /* Pointer to the object to parse */
size_t endValue, /* The value to be stored at "indexPtr" if
* "objPtr" holds "end". */
Tcl_WideInt *widePtr) /* Location filled in with an integer
* representing an index. */
{
Tcl_ObjIntRep *irPtr;
Tcl_WideInt offset = -1; /* Offset in the "end-offset" expression - 1 */
ClientData cd;
while ((irPtr = TclFetchIntRep(objPtr, &endOffsetType)) == NULL) {
Tcl_ObjIntRep ir;
int length;
const char *bytes = TclGetStringFromObj(objPtr, &length);
if (*bytes != 'e') {
int numType;
const char *opPtr;
int length, 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(TclGetString(objPtr), -1, NULL) > 1)
/* If it's possible, do the full list parse. */
&& (TCL_OK == Tcl_ListObjLength(NULL, objPtr, &length))
&& (length > 1)) {
goto parseError;
}
/* Passed the list screen, so parse for index arithmetic expression */
if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, -1, &opPtr,
TCL_PARSE_INTEGER_ONLY)) {
Tcl_WideInt w1=0, w2=0;
/* value starts with valid integer... */
if ((*opPtr == '-') || (*opPtr == '+')) {
/* ... value continues with [-+] ... */
/* Save first integer as wide if possible */
TclGetNumberFromObj(NULL, objPtr, &cd, &t1);
if (t1 == TCL_NUMBER_INT) {
w1 = (*(Tcl_WideInt *)cd);
}
if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, opPtr + 1,
-1, NULL, TCL_PARSE_INTEGER_ONLY)) {
/* ... value concludes with second valid integer */
/* Save second integer as wide if possible */
TclGetNumberFromObj(NULL, objPtr, &cd, &t2);
if (t2 == TCL_NUMBER_INT) {
w2 = (*(Tcl_WideInt *)cd);
}
}
}
/* Clear invalid intreps left by TclParseNumber */
TclFreeIntRep(objPtr);
if (t1 && t2) {
/* We have both integer values */
if ((t1 == TCL_NUMBER_INT) && (t2 == TCL_NUMBER_INT)) {
/* Both are wide, do wide-integer math */
if (*opPtr == '-') {
if ((w2 == WIDE_MIN) && (interp != NULL)) {
goto extreme;
}
w2 = -w2;
}
if ((w1 ^ w2) < 0) {
/* Different signs, sum cannot overflow */
offset = w1 + w2;
} else if (w1 >= 0) {
if (w1 < WIDE_MAX - w2) {
offset = w1 + w2;
} else {
offset = WIDE_MAX;
}
} else {
if (w1 > WIDE_MIN - w2) {
offset = w1 + w2;
} else {
offset = WIDE_MIN;
}
}
} else if (interp == NULL) {
/*
* We use an interp to do bignum index calculations.
* If we don't get one, call all indices with bignums errors,
* and rely on callers to handle it.
*/
goto parseError;
} 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:
Tcl_ExprObj(interp, objPtr, &sum);
TclGetNumberFromObj(NULL, sum, &cd, &numType);
if (numType == TCL_NUMBER_INT) {
/* sum holds an integer in the signed wide range */
offset = *(Tcl_WideInt *)cd;
} else {
/* sum holds an integer outside the signed wide range */
/* Truncate to the signed wide range. */
if (mp_isneg((mp_int *)cd)) {
offset = WIDE_MIN;
} else {
offset = WIDE_MAX;
}
}
Tcl_DecrRefCount(sum);
}
if (offset < 0) {
offset = (offset == -1) ? WIDE_MIN : WIDE_MIN+1;
}
goto parseOK;
}
}
goto parseError;
}
if ((length < 3) || (length == 4) || (strncmp(bytes, "end", 3) != 0)) {
/* Doesn't start with "end" */
goto parseError;
}
if (length > 4) {
int t;
/* Parse for the "end-..." or "end+..." formats */
if ((bytes[3] != '-') && (bytes[3] != '+')) {
/* No operator where we need one */
goto parseError;
}
if (TclIsSpaceProc(bytes[4])) {
/* Space after + or - not permitted. */
goto parseError;
}
/* Parse the integer offset */
if (TCL_OK != TclParseNumber(NULL, objPtr, NULL,
bytes+4, length-4, NULL, TCL_PARSE_INTEGER_ONLY)) {
/* Not a recognized integer format */
goto parseError;
}
/* Got an integer offset; pull it from where parser left it. */
TclGetNumberFromObj(NULL, objPtr, &cd, &t);
if (t == TCL_NUMBER_BIG) {
/* Truncate to the signed wide range. */
if (mp_isneg((mp_int *)cd)) {
offset = (bytes[3] == '-') ? WIDE_MAX : WIDE_MIN;
} else {
offset = (bytes[3] == '-') ? WIDE_MIN : WIDE_MAX;
}
} else {
/* assert (t == TCL_NUMBER_INT); */
offset = (*(Tcl_WideInt *)cd);
if (bytes[3] == '-') {
offset = (offset == WIDE_MIN) ? WIDE_MAX : -offset;
}
if (offset == 1) {
offset = WIDE_MAX; /* "end+1" */
} else if (offset > 1) {
offset = WIDE_MAX - 1; /* "end+n", out of range */
} else if (offset != WIDE_MIN) {
offset--;
}
}
}
parseOK:
/* Success. Store the new internal rep. */
ir.wideValue = offset;
Tcl_StoreIntRep(objPtr, &endOffsetType, &ir);
}
offset = irPtr->wideValue;
if (offset == WIDE_MAX) {
*widePtr = endValue + 1;
} else if (offset == WIDE_MIN) {
*widePtr = -1;
} else if (endValue == (size_t)-1) {
*widePtr = offset;
} else if (offset < 0) {
/* Different signs, sum cannot overflow */
*widePtr = endValue + offset + 1;
} else if (offset < WIDE_MAX) {
*widePtr = offset;
} else {
*widePtr = WIDE_MAX;
}
return TCL_OK;
/* Report a parse error. */
parseError:
if (interp != NULL) {
char * bytes = TclGetString(objPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad index \"%s\": must be integer?[+-]integer? or"
" end?[+-]integer?", bytes));
if (!strncmp(bytes, "end-", 4)) {
bytes += 4;
}
TclCheckBadOctal(interp, bytes);
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TclIndexEncode --
*
|
| ︙ | ︙ | |||
3749 3750 3751 3752 3753 3754 3755 | * * A token can also be parsed as an end-relative index expression. * All end-relative expressions that indicate an index larger * than end (end+2, end--5) point beyond the end of the indexed * collection, and can be encoded as after. The end-relative * expressions that indicate an index less than or equal to end * are encoded relative to the value TCL_INDEX_END (-2). The | | | | | | | < | | | | | < < < < < | < < < < | | | | | | | | | | | | | | | | | < < < < < < < < < < | 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 |
*
* A token can also be parsed as an end-relative index expression.
* All end-relative expressions that indicate an index larger
* than end (end+2, end--5) point beyond the end of the indexed
* collection, and can be encoded as after. The end-relative
* expressions that indicate an index less than or equal to end
* are encoded relative to the value TCL_INDEX_END (-2). The
* index "end" is encoded as -2, down to the index "end-0x7FFFFFFE"
* which is encoded as INT_MIN. Since the largest index into a
* string possible in Tcl 8 is 0x7FFFFFFE, the interpretation of
* "end-0x7FFFFFFE" for that largest string would be 0. Thus,
* if the tokens "end-0x7FFFFFFF" or "end+-0x80000000" are parsed,
* they can be encoded with the before value.
*
* These details will require re-examination whenever string and
* list length limits are increased, but that will likely also
* mean a revised routine capable of returning Tcl_WideInt values.
*
* Returns:
* TCL_OK if parsing succeeded, and TCL_ERROR if it failed.
*
* Side effects:
* When TCL_OK is returned, the encoded index value is written
* to *indexPtr.
*
*----------------------------------------------------------------------
*/
int
TclIndexEncode(
Tcl_Interp *interp, /* For error reporting, may be NULL */
Tcl_Obj *objPtr, /* Index value to parse */
int before, /* Value to return for index before beginning */
int after, /* Value to return for index after end */
int *indexPtr) /* Where to write the encoded answer, not NULL */
{
Tcl_WideInt wide;
int idx;
if (TCL_OK == GetWideForIndex(interp, objPtr, (unsigned)TCL_INDEX_END , &wide)) {
const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &endOffsetType);
if (irPtr && irPtr->wideValue >= 0) {
/* "int[+-]int" syntax, works the same here as "int" */
irPtr = NULL;
}
/*
* We parsed an end+offset index value.
* wide holds the offset value in the range WIDE_MIN...WIDE_MAX.
*/
if (wide > (unsigned)(irPtr ? TCL_INDEX_END : INT_MAX)) {
/*
* All end+postive or end-negative expressions
* always indicate "after the end".
*/
idx = after;
} else if (wide <= (irPtr ? INT_MAX : TCL_INDEX_NONE)) {
/* These indices always indicate "before the beginning */
idx = before;
} else {
/* Encoded end-positive (or end+negative) are offset */
idx = (int)wide;
}
} else {
return TCL_ERROR;
}
*indexPtr = idx;
return TCL_OK;
}
|
| ︙ | ︙ | |||
3846 3847 3848 3849 3850 3851 3852 | * * Results: * The decoded index value. * *---------------------------------------------------------------------- */ | | | | > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 4123 4124 4125 4126 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 4186 4187 4188 4189 4190 4191 4192 4193 4194 4195 4196 |
*
* Results:
* The decoded index value.
*
*----------------------------------------------------------------------
*/
int
TclIndexDecode(
int encoded, /* Value to decode */
int endValue) /* Meaning of "end" to use, > TCL_INDEX_END */
{
if (encoded > TCL_INDEX_END) {
return encoded;
}
endValue += encoded - TCL_INDEX_END;
if (endValue >= 0) {
return endValue;
}
return TCL_INDEX_NONE;
}
/*
*----------------------------------------------------------------------
*
* TclCheckBadOctal --
*
* This function checks for a bad octal value and appends a meaningful
* error to the interp's result.
*
* Results:
* 1 if the argument was a bad octal, else 0.
*
* Side effects:
* The interpreter's result is modified.
*
*----------------------------------------------------------------------
*/
int
TclCheckBadOctal(
Tcl_Interp *interp, /* Interpreter to use for error reporting. If
* NULL, then no error message is left after
* errors. */
const char *value) /* String to check. */
{
const char *p = value;
/*
* A frequent mistake is invalid octal values due to an unwanted leading
* zero. Try to generate a meaningful error message.
*/
while (TclIsSpaceProcM(*p)) {
p++;
}
if (*p == '+' || *p == '-') {
p++;
}
if (*p == '0') {
if ((p[1] == 'o') || p[1] == 'O') {
p += 2;
}
while (isdigit(UCHAR(*p))) { /* INTL: digit. */
p++;
}
while (TclIsSpaceProcM(*p)) {
p++;
}
if (*p == '\0') {
/*
* Reached end of string.
*/
if (interp != NULL) {
/*
* Don't reset the result here because we want this result to
* be added to an existing error message as extra info.
*/
Tcl_AppendToObj(Tcl_GetObjResult(interp),
" (looks like invalid octal number)", -1);
}
return 1;
}
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* ClearHash --
*
* Remove all the entries in the hash table *tablePtr.
*
*----------------------------------------------------------------------
*/
static void
ClearHash(
Tcl_HashTable *tablePtr)
{
Tcl_HashSearch search;
Tcl_HashEntry *hPtr;
for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
hPtr = Tcl_NextHashEntry(&search)) {
Tcl_Obj *objPtr = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
Tcl_DecrRefCount(objPtr);
Tcl_DeleteHashEntry(hPtr);
}
}
/*
|
| ︙ | ︙ | |||
3909 3910 3911 3912 3913 3914 3915 |
*/
static Tcl_HashTable *
GetThreadHash(
Tcl_ThreadDataKey *keyPtr)
{
Tcl_HashTable **tablePtrPtr =
| | | | 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 |
*/
static Tcl_HashTable *
GetThreadHash(
Tcl_ThreadDataKey *keyPtr)
{
Tcl_HashTable **tablePtrPtr =
(Tcl_HashTable **)Tcl_GetThreadData(keyPtr, sizeof(Tcl_HashTable *));
if (NULL == *tablePtrPtr) {
*tablePtrPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
Tcl_CreateThreadExitHandler(FreeThreadHash, *tablePtrPtr);
Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS);
}
return *tablePtrPtr;
}
/*
|
| ︙ | ︙ | |||
3937 3938 3939 3940 3941 3942 3943 |
*----------------------------------------------------------------------
*/
static void
FreeThreadHash(
ClientData clientData)
{
| | | | | | 4240 4241 4242 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 |
*----------------------------------------------------------------------
*/
static void
FreeThreadHash(
ClientData clientData)
{
Tcl_HashTable *tablePtr = (Tcl_HashTable *)clientData;
ClearHash(tablePtr);
Tcl_DeleteHashTable(tablePtr);
ckfree(tablePtr);
}
/*
*----------------------------------------------------------------------
*
* FreeProcessGlobalValue --
*
* Exit handler used by Tcl(Set|Get)ProcessGlobalValue to cleanup a
* ProcessGlobalValue at exit.
*
*----------------------------------------------------------------------
*/
static void
FreeProcessGlobalValue(
ClientData clientData)
{
ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *)clientData;
pgvPtr->epoch++;
pgvPtr->numBytes = 0;
ckfree(pgvPtr->value);
pgvPtr->value = NULL;
if (pgvPtr->encoding) {
Tcl_FreeEncoding(pgvPtr->encoding);
pgvPtr->encoding = NULL;
}
Tcl_MutexFinalize(&pgvPtr->mutex);
}
|
| ︙ | ︙ | |||
4002 4003 4004 4005 4006 4007 4008 |
/*
* Fill the global string value.
*/
pgvPtr->epoch++;
if (NULL != pgvPtr->value) {
| | | | | 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 |
/*
* Fill the global string value.
*/
pgvPtr->epoch++;
if (NULL != pgvPtr->value) {
ckfree(pgvPtr->value);
} else {
Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr);
}
bytes = TclGetString(newValue);
pgvPtr->numBytes = newValue->length;
pgvPtr->value = (char *)ckalloc(pgvPtr->numBytes + 1);
memcpy(pgvPtr->value, bytes, pgvPtr->numBytes + 1);
if (pgvPtr->encoding) {
Tcl_FreeEncoding(pgvPtr->encoding);
}
pgvPtr->encoding = encoding;
/*
* Fill the local thread copy directly with the Tcl_Obj value to avoid
* loss of the intrep. Increment newValue refCount early to handle case
* where we set a PGV to itself.
*/
Tcl_IncrRefCount(newValue);
cacheMap = GetThreadHash(&pgvPtr->key);
ClearHash(cacheMap);
hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy);
Tcl_SetHashValue(hPtr, newValue);
Tcl_MutexUnlock(&pgvPtr->mutex);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4050 4051 4052 4053 4054 4055 4056 |
Tcl_Obj *
TclGetProcessGlobalValue(
ProcessGlobalValue *pgvPtr)
{
Tcl_Obj *value = NULL;
Tcl_HashTable *cacheMap;
Tcl_HashEntry *hPtr;
| | | | | | 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 4376 4377 4378 4379 4380 4381 4382 4383 4384 4385 4386 4387 4388 4389 4390 4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 |
Tcl_Obj *
TclGetProcessGlobalValue(
ProcessGlobalValue *pgvPtr)
{
Tcl_Obj *value = NULL;
Tcl_HashTable *cacheMap;
Tcl_HashEntry *hPtr;
unsigned int epoch = pgvPtr->epoch;
if (pgvPtr->encoding) {
Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL);
if (pgvPtr->encoding != current) {
/*
* The system encoding has changed since the master string value
* was saved. Convert the master value to be based on the new
* system encoding.
*/
Tcl_DString native, newValue;
Tcl_MutexLock(&pgvPtr->mutex);
epoch = ++pgvPtr->epoch;
Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value,
pgvPtr->numBytes, &native);
Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native),
Tcl_DStringLength(&native), &newValue);
Tcl_DStringFree(&native);
ckfree(pgvPtr->value);
pgvPtr->value = (char *)ckalloc(Tcl_DStringLength(&newValue) + 1);
memcpy(pgvPtr->value, Tcl_DStringValue(&newValue),
Tcl_DStringLength(&newValue) + 1);
Tcl_DStringFree(&newValue);
Tcl_FreeEncoding(pgvPtr->encoding);
pgvPtr->encoding = current;
Tcl_MutexUnlock(&pgvPtr->mutex);
} else {
Tcl_FreeEncoding(current);
}
}
cacheMap = GetThreadHash(&pgvPtr->key);
hPtr = Tcl_FindHashEntry(cacheMap, INT2PTR(epoch));
if (NULL == hPtr) {
int dummy;
/*
* No cache for the current epoch - must be a new one.
*
* First, clear the cacheMap, as anything in it must refer to some
|
| ︙ | ︙ | |||
4117 4118 4119 4120 4121 4122 4123 | /* * Store a copy of the shared value in our epoch-indexed cache. */ value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes); hPtr = Tcl_CreateHashEntry(cacheMap, | | | | 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 |
/*
* Store a copy of the shared value in our epoch-indexed cache.
*/
value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes);
hPtr = Tcl_CreateHashEntry(cacheMap,
INT2PTR(pgvPtr->epoch), &dummy);
Tcl_MutexUnlock(&pgvPtr->mutex);
Tcl_SetHashValue(hPtr, value);
Tcl_IncrRefCount(value);
}
return (Tcl_Obj *)Tcl_GetHashValue(hPtr);
}
/*
*----------------------------------------------------------------------
*
* TclSetObjNameOfExecutable --
*
|
| ︙ | ︙ | |||
4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 |
}
return bytes;
}
/*
*----------------------------------------------------------------------
*
* TclGetPlatform --
*
* This is a kludge that allows the test library to get access the
* internal tclPlatform variable.
*
* Results:
* Returns a pointer to the tclPlatform variable.
| > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
}
return bytes;
}
/*
*----------------------------------------------------------------------
*
* TclpGetTime --
*
* Deprecated synonym for Tcl_GetTime. This function is provided for the
* benefit of extensions written before Tcl_GetTime was exported from the
* library.
*
* Results:
* None.
*
* Side effects:
* Stores current time in the buffer designated by "timePtr"
*
*----------------------------------------------------------------------
*/
void
TclpGetTime(
Tcl_Time *timePtr)
{
Tcl_GetTime(timePtr);
}
/*
*----------------------------------------------------------------------
*
* TclGetPlatform --
*
* This is a kludge that allows the test library to get access the
* internal tclPlatform variable.
*
* Results:
* Returns a pointer to the tclPlatform variable.
|
| ︙ | ︙ | |||
4256 4257 4258 4259 4260 4261 4262 |
*----------------------------------------------------------------------
*/
int
TclReToGlob(
Tcl_Interp *interp,
const char *reStr,
| | | 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 |
*----------------------------------------------------------------------
*/
int
TclReToGlob(
Tcl_Interp *interp,
const char *reStr,
int reStrLen,
Tcl_DString *dsPtr,
int *exactPtr,
int *quantifiersFoundPtr)
{
int anchorLeft, anchorRight, lastIsStar, numStars;
char *dsStr, *dsStrStart;
const char *msg, *p, *strEnd, *code;
|
| ︙ | ︙ |
Changes to generic/tclVar.c.
| ︙ | ︙ | |||
184 185 186 187 188 189 190 | Tcl_Obj *patternPtr, int includeLinks); static void ArrayPopulateSearch(Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Var *varPtr, ArraySearch *searchPtr); static void ArrayDoneSearch(Interp *iPtr, Var *varPtr, ArraySearch *searchPtr); static Tcl_NRPostProc ArrayForLoopCallback; | | < | 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 | Tcl_Obj *patternPtr, int includeLinks); static void ArrayPopulateSearch(Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Var *varPtr, ArraySearch *searchPtr); static void ArrayDoneSearch(Interp *iPtr, Var *varPtr, ArraySearch *searchPtr); static Tcl_NRPostProc ArrayForLoopCallback; static Tcl_ObjCmdProc ArrayForNRCmd; static void DeleteSearches(Interp *iPtr, Var *arrayVarPtr); static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr, Var *varPtr, int flags, int index); static int LocateArray(Tcl_Interp *interp, Tcl_Obj *name, Var **varPtrPtr, int *isArrayPtr); static int NotArrayError(Tcl_Interp *interp, Tcl_Obj *name); static Tcl_Var ObjFindNamespaceVar(Tcl_Interp *interp, |
| ︙ | ︙ | |||
264 265 266 267 268 269 270 |
Tcl_StoreIntRep((objPtr), &localVarNameType, &ir); \
} while (0)
#define LocalGetIntRep(objPtr, index, name) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &localVarNameType); \
| | | 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 |
Tcl_StoreIntRep((objPtr), &localVarNameType, &ir); \
} while (0)
#define LocalGetIntRep(objPtr, index, name) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &localVarNameType); \
(name) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr1 : NULL; \
(index) = irPtr ? PTR2INT(irPtr->twoPtrValue.ptr2) : -1; \
} while (0)
static const Tcl_ObjType parsedVarNameType = {
"parsedVarName",
FreeParsedVarName, DupParsedVarName, NULL, NULL
};
|
| ︙ | ︙ | |||
290 291 292 293 294 295 296 |
} while (0)
#define ParsedGetIntRep(objPtr, parsed, array, elem) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &parsedVarNameType); \
(parsed) = (irPtr != NULL); \
| | | | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 |
} while (0)
#define ParsedGetIntRep(objPtr, parsed, array, elem) \
do { \
const Tcl_ObjIntRep *irPtr; \
irPtr = TclFetchIntRep((objPtr), &parsedVarNameType); \
(parsed) = (irPtr != NULL); \
(array) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr1 : NULL; \
(elem) = irPtr ? (Tcl_Obj *)irPtr->twoPtrValue.ptr2 : NULL; \
} while (0)
Var *
TclVarHashCreateVar(
TclVarHashTable *tablePtr,
const char *key,
int *newPtr)
|
| ︙ | ︙ | |||
339 340 341 342 343 344 345 |
}
static int
NotArrayError(
Tcl_Interp *interp,
Tcl_Obj *name)
{
| | | 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 |
}
static int
NotArrayError(
Tcl_Interp *interp,
Tcl_Obj *name)
{
const char *nameStr = Tcl_GetString(name);
Tcl_SetObjResult(interp,
Tcl_ObjPrintf("\"%s\" isn't an array", nameStr));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", nameStr, NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
381 382 383 384 385 386 387 |
* if this variable isn't an array element. */
{
if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr)
&& !TclIsVarTraced(varPtr)
&& (VarHashRefCount(varPtr) == (unsigned)
!TclIsVarDeadHash(varPtr))) {
if (VarHashRefCount(varPtr) == 0) {
| | | | 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 |
* if this variable isn't an array element. */
{
if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr)
&& !TclIsVarTraced(varPtr)
&& (VarHashRefCount(varPtr) == (unsigned)
!TclIsVarDeadHash(varPtr))) {
if (VarHashRefCount(varPtr) == 0) {
ckfree(varPtr);
} else {
VarHashDeleteEntry(varPtr);
}
}
if (arrayPtr != NULL && TclIsVarUndefined(arrayPtr) &&
TclIsVarInHash(arrayPtr) && !TclIsVarTraced(arrayPtr) &&
(VarHashRefCount(arrayPtr) == (unsigned)
!TclIsVarDeadHash(arrayPtr))) {
if (VarHashRefCount(arrayPtr) == 0) {
ckfree(arrayPtr);
} else {
VarHashDeleteEntry(arrayPtr);
}
}
}
void
|
| ︙ | ︙ | |||
528 529 530 531 532 533 534 |
*
*----------------------------------------------------------------------
*/
Var *
TclObjLookupVar(
Tcl_Interp *interp, /* Interpreter to use for lookup. */
| | | 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 |
*
*----------------------------------------------------------------------
*/
Var *
TclObjLookupVar(
Tcl_Interp *interp, /* Interpreter to use for lookup. */
Tcl_Obj *part1Ptr, /* If part2 isn't NULL, this is the name of an
* array. Otherwise, this is a full variable
* name that could include a parenthesized
* array element. */
const char *part2, /* Name of element within array, or NULL. */
int flags, /* Only TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* and TCL_LEAVE_ERR_MSG bits matter. */
const char *msg, /* Verb to use in error messages, e.g. "read"
|
| ︙ | ︙ | |||
601 602 603 604 605 606 607 |
Var **arrayPtrPtr) /* If the name refers to an element of an
* array, *arrayPtrPtr gets filled in with
* address of array variable. Otherwise this
* is set to NULL. */
{
Interp *iPtr = (Interp *) interp;
CallFrame *varFramePtr = iPtr->varFramePtr;
| | | 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 |
Var **arrayPtrPtr) /* If the name refers to an element of an
* array, *arrayPtrPtr gets filled in with
* address of array variable. Otherwise this
* is set to NULL. */
{
Interp *iPtr = (Interp *) interp;
CallFrame *varFramePtr = iPtr->varFramePtr;
Var *varPtr; /* Points to the variable's in-frame Var
* structure. */
const char *errMsg = NULL;
int index, parsed = 0;
int localIndex;
Tcl_Obj *namePtr, *arrayPtr, *elem;
|
| ︙ | ︙ | |||
661 662 663 664 665 666 667 |
}
if (!parsed) {
/*
* part1Ptr is possibly an unparsed array element.
*/
| | | 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 |
}
if (!parsed) {
/*
* part1Ptr is possibly an unparsed array element.
*/
int len;
const char *part1 = TclGetStringFromObj(part1Ptr, &len);
if ((len > 1) && (part1[len - 1] == ')')) {
const char *part2 = strchr(part1, '(');
if (part2) {
if (part2Ptr != NULL) {
|
| ︙ | ︙ | |||
843 844 845 846 847 848 849 |
TclVarHashTable *tablePtr; /* Points to the hashtable, if any, in which
* to look up the variable. */
Tcl_Var var; /* Used to search for global names. */
Var *varPtr; /* Points to the Var structure returned for
* the variable. */
Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr;
ResolverScheme *resPtr;
| | < | 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 |
TclVarHashTable *tablePtr; /* Points to the hashtable, if any, in which
* to look up the variable. */
Tcl_Var var; /* Used to search for global names. */
Var *varPtr; /* Points to the Var structure returned for
* the variable. */
Namespace *varNsPtr, *cxtNsPtr, *dummy1Ptr, *dummy2Ptr;
ResolverScheme *resPtr;
int isNew, i, result, varLen;
const char *varName = TclGetStringFromObj(varNamePtr, &varLen);
varPtr = NULL;
varNsPtr = NULL; /* Set non-NULL if a nonlocal variable. */
*indexPtr = -3;
if (flags & TCL_GLOBAL_ONLY) {
|
| ︙ | ︙ | |||
917 918 919 920 921 922 923 |
|| (cxtNsPtr == iPtr->globalNsPtr)
|| ((*varName == ':') && (*(varName+1) == ':'));
if (lookGlobal) {
*indexPtr = -1;
flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY;
} else {
| > | > > | > | 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 |
|| (cxtNsPtr == iPtr->globalNsPtr)
|| ((*varName == ':') && (*(varName+1) == ':'));
if (lookGlobal) {
*indexPtr = -1;
flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY;
} else {
if (flags & TCL_AVOID_RESOLVERS) {
flags = (flags | TCL_NAMESPACE_ONLY);
}
if (flags & TCL_NAMESPACE_ONLY) {
*indexPtr = -2;
}
}
/*
* Don't pass TCL_LEAVE_ERR_MSG, we may yet create the variable, or
* otherwise generate our own error!
*/
|
| ︙ | ︙ | |||
974 975 976 977 978 979 980 |
}
} else { /* Local var: look in frame varFramePtr. */
int localCt = varFramePtr->numCompiledLocals;
if (localCt > 0) {
Tcl_Obj **objPtrPtr = &varFramePtr->localCachePtr->varName0;
const char *localNameStr;
| | | | | 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 |
}
} else { /* Local var: look in frame varFramePtr. */
int localCt = varFramePtr->numCompiledLocals;
if (localCt > 0) {
Tcl_Obj **objPtrPtr = &varFramePtr->localCachePtr->varName0;
const char *localNameStr;
int localLen;
for (i=0 ; i<localCt ; i++, objPtrPtr++) {
Tcl_Obj *objPtr = *objPtrPtr;
if (objPtr) {
localNameStr = TclGetStringFromObj(objPtr, &localLen);
if ((varLen == localLen) && (varName[0] == localNameStr[0])
&& !memcmp(varName, localNameStr, varLen)) {
*indexPtr = i;
return (Var *) &varFramePtr->compiledLocals[i];
}
}
}
}
tablePtr = varFramePtr->varTablePtr;
if (create) {
if (tablePtr == NULL) {
tablePtr = (TclVarHashTable *)ckalloc(sizeof(TclVarHashTable));
TclInitVarHashTable(tablePtr, NULL);
varFramePtr->varTablePtr = tablePtr;
}
varPtr = VarHashCreateVar(tablePtr, varNamePtr, &isNew);
} else {
varPtr = NULL;
if (tablePtr != NULL) {
|
| ︙ | ︙ | |||
1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 |
}
return varPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetVar2 --
*
* Return the value of a Tcl variable as a string, given a two-part name
* consisting of array name and element within array.
*
* Results:
* The return value points to the current value of the variable given by
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
}
return varPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetVar --
*
* Return the value of a Tcl variable as a string.
*
* Results:
* The return value points to the current value of varName as a string.
* If the variable is not defined or can't be read because of a clash in
* array usage then a NULL pointer is returned and an error message is
* left in the interp's result if the TCL_LEAVE_ERR_MSG flag is set.
* Note: the return value is only valid up until the next change to the
* variable; if you depend on the value lasting longer than that, then
* make yourself a private copy.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
#undef Tcl_GetVar
const char *
Tcl_GetVar(
Tcl_Interp *interp, /* Command interpreter in which varName is to
* be looked up. */
const char *varName, /* Name of a variable in interp. */
int flags) /* OR-ed combination of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG
* bits. */
{
Tcl_Obj *varNamePtr = Tcl_NewStringObj(varName, -1);
Tcl_Obj *resultPtr = Tcl_ObjGetVar2(interp, varNamePtr, NULL, flags);
TclDecrRefCount(varNamePtr);
if (resultPtr == NULL) {
return NULL;
}
return TclGetString(resultPtr);
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_GetVar2 --
*
* Return the value of a Tcl variable as a string, given a two-part name
* consisting of array name and element within array.
*
* Results:
* The return value points to the current value of the variable given by
|
| ︙ | ︙ | |||
1273 1274 1275 1276 1277 1278 1279 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_ObjGetVar2(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be looked up. */
| | | | 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_ObjGetVar2(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be looked up. */
Tcl_Obj *part1Ptr, /* Points to an object holding the name of an
* array (if part2 is non-NULL) or the name of
* a variable. */
Tcl_Obj *part2Ptr, /* If non-null, points to an object holding
* the name of an element in the array
* part1Ptr. */
int flags) /* OR-ed combination of TCL_GLOBAL_ONLY and
* TCL_LEAVE_ERR_MSG bits. */
{
Var *varPtr, *arrayPtr;
|
| ︙ | ︙ | |||
1371 1372 1373 1374 1375 1376 1377 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclPtrGetVarIdx(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be looked up. */
| | | 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclPtrGetVarIdx(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be looked up. */
Var *varPtr, /* The variable to be read.*/
Var *arrayPtr, /* NULL for scalar variables, pointer to the
* containing array otherwise. */
Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or
* the name of a variable. */
Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element
* in the array part1. */
const int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, and
|
| ︙ | ︙ | |||
1473 1474 1475 1476 1477 1478 1479 | * * Side effects: * A variable's value may be changed. * *---------------------------------------------------------------------- */ | < | | | 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 |
*
* Side effects:
* A variable's value may be changed.
*
*----------------------------------------------------------------------
*/
int
Tcl_SetObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,/* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *varValueObj;
if (objc == 2) {
varValueObj = Tcl_ObjGetVar2(interp, objv[1], NULL,TCL_LEAVE_ERR_MSG);
|
| ︙ | ︙ | |||
1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 |
return TCL_OK;
} else {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?newValue?");
return TCL_ERROR;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetVar2 --
*
* Given a two-part variable name, which may refer either to a scalar
* variable or an element of an array, change the value of the variable.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 |
return TCL_OK;
} else {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?newValue?");
return TCL_ERROR;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetVar --
*
* Change the value of a variable.
*
* Results:
* Returns a pointer to the malloc'ed string which is the character
* representation of the variable's new value. The caller must not modify
* this string. If the write operation was disallowed then NULL is
* returned; if the TCL_LEAVE_ERR_MSG flag is set, then an explanatory
* message will be left in the interp's result. Note that the returned
* string may not be the same as newValue; this is because variable
* traces may modify the variable's value.
*
* Side effects:
* If varName is defined as a local or global variable in interp, its
* value is changed to newValue. If varName isn't currently defined, then
* a new global variable by that name is created.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
#undef Tcl_SetVar
const char *
Tcl_SetVar(
Tcl_Interp *interp, /* Command interpreter in which varName is to
* be looked up. */
const char *varName, /* Name of a variable in interp. */
const char *newValue, /* New value for varName. */
int flags) /* Various flags that tell how to set value:
* any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
* TCL_LEAVE_ERR_MSG. */
{
Tcl_Obj *varValuePtr = Tcl_SetVar2Ex(interp, varName, NULL,
Tcl_NewStringObj(newValue, -1), flags);
if (varValuePtr == NULL) {
return NULL;
}
return TclGetString(varValuePtr);
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_SetVar2 --
*
* Given a two-part variable name, which may refer either to a scalar
* variable or an element of an array, change the value of the variable.
|
| ︙ | ︙ | |||
1654 1655 1656 1657 1658 1659 1660 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_ObjSetVar2(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be found. */
| | | | 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
Tcl_ObjSetVar2(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be found. */
Tcl_Obj *part1Ptr, /* Points to an object holding the name of an
* array (if part2 is non-NULL) or the name of
* a variable. */
Tcl_Obj *part2Ptr, /* If non-NULL, points to an object holding
* the name of an element in the array
* part1Ptr. */
Tcl_Obj *newValuePtr, /* New value for variable. */
int flags) /* Various flags that tell how to set value:
* any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT, or
* TCL_LEAVE_ERR_MSG. */
|
| ︙ | ︙ | |||
1894 1895 1896 1897 1898 1899 1900 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclPtrSetVarIdx(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be looked up. */
| | | 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 |
*----------------------------------------------------------------------
*/
Tcl_Obj *
TclPtrSetVarIdx(
Tcl_Interp *interp, /* Command interpreter in which variable is to
* be looked up. */
Var *varPtr, /* Reference to the variable to set. */
Var *arrayPtr, /* Reference to the array containing the
* variable, or NULL if the variable is a
* scalar. */
Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or
* the name of a variable. NULL if the 'index'
* parameter is >= 0 */
Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element
|
| ︙ | ︙ | |||
2214 2215 2216 2217 2218 2219 2220 |
* any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
* TCL_LEAVE_ERR_MSG. */
int index) /* Index into the local variable table of the
* variable, or -1. Only used when part1Ptr is
* NULL. */
{
| | | 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 |
* any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
* TCL_LEAVE_ERR_MSG. */
int index) /* Index into the local variable table of the
* variable, or -1. Only used when part1Ptr is
* NULL. */
{
Tcl_Obj *varValuePtr;
if (TclIsVarInHash(varPtr)) {
VarHashRefCount(varPtr)++;
}
varValuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, part1Ptr,
part2Ptr, flags, index);
if (TclIsVarInHash(varPtr)) {
|
| ︙ | ︙ | |||
2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 |
part2Ptr, varValuePtr, flags, index);
} else {
return NULL;
}
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_UnsetVar2 --
*
* Delete a variable, given a 2-part name.
*
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
part2Ptr, varValuePtr, flags, index);
} else {
return NULL;
}
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_UnsetVar --
*
* Delete a variable, so that it may not be accessed anymore.
*
* Results:
* Returns TCL_OK if the variable was successfully deleted, TCL_ERROR if
* the variable can't be unset. In the event of an error, if the
* TCL_LEAVE_ERR_MSG flag is set then an error message is left in the
* interp's result.
*
* Side effects:
* If varName is defined as a local or global variable in interp, it is
* deleted.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
#undef Tcl_UnsetVar
int
Tcl_UnsetVar(
Tcl_Interp *interp, /* Command interpreter in which varName is to
* be looked up. */
const char *varName, /* Name of a variable in interp. May be either
* a scalar name or an array name or an
* element in an array. */
int flags) /* OR-ed combination of any of
* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY or
* TCL_LEAVE_ERR_MSG. */
{
int result;
Tcl_Obj *varNamePtr;
varNamePtr = Tcl_NewStringObj(varName, -1);
Tcl_IncrRefCount(varNamePtr);
/*
* Filter to pass through only the flags this interface supports.
*/
flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG);
result = TclObjUnsetVar2(interp, varNamePtr, NULL, flags);
Tcl_DecrRefCount(varNamePtr);
return result;
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_UnsetVar2 --
*
* Delete a variable, given a 2-part name.
*
|
| ︙ | ︙ | |||
2424 2425 2426 2427 2428 2429 2430 |
*----------------------------------------------------------------------
*/
int
TclPtrUnsetVarIdx(
Tcl_Interp *interp, /* Command interpreter in which varName is to
* be looked up. */
| | | 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 |
*----------------------------------------------------------------------
*/
int
TclPtrUnsetVarIdx(
Tcl_Interp *interp, /* Command interpreter in which varName is to
* be looked up. */
Var *varPtr, /* The variable to be unset. */
Var *arrayPtr, /* NULL for scalar variables, pointer to the
* containing array otherwise. */
Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or
* the name of a variable. */
Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element
* in the array part1. */
const int flags, /* OR-ed combination of any of
|
| ︙ | ︙ | |||
2557 2558 2559 2560 2561 2562 2563 | * Transfer any existing traces on var, IF there are unset traces. * Otherwise just delete them. */ int isNew; tPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr); | | | 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 |
* Transfer any existing traces on var, IF there are unset traces.
* Otherwise just delete them.
*/
int isNew;
tPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr);
tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr);
varPtr->flags &= ~VAR_ALL_TRACES;
Tcl_DeleteHashEntry(tPtr);
if (dummyVar.flags & VAR_TRACED_UNSET) {
tPtr = Tcl_CreateHashEntry(&iPtr->varTraces,
&dummyVar, &isNew);
Tcl_SetHashValue(tPtr, tracePtr);
}
|
| ︙ | ︙ | |||
2584 2585 2586 2587 2588 2589 2590 |
* the set of traces. If so, reload the traces to manipulate.
*/
tracePtr = NULL;
if (TclIsVarTraced(&dummyVar)) {
tPtr = Tcl_FindHashEntry(&iPtr->varTraces, &dummyVar);
if (tPtr) {
| | | 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 |
* the set of traces. If so, reload the traces to manipulate.
*/
tracePtr = NULL;
if (TclIsVarTraced(&dummyVar)) {
tPtr = Tcl_FindHashEntry(&iPtr->varTraces, &dummyVar);
if (tPtr) {
tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr);
Tcl_DeleteHashEntry(tPtr);
}
}
}
if (tracePtr) {
ActiveVarTrace *activePtr;
|
| ︙ | ︙ | |||
2670 2671 2672 2673 2674 2675 2676 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | | | 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_UnsetObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int i, flags = TCL_LEAVE_ERR_MSG;
const char *name;
if (objc == 1) {
/*
* Do nothing if no arguments supplied, so as to match command
* documentation.
*/
|
| ︙ | ︙ | |||
2738 2739 2740 2741 2742 2743 2744 | * * Side effects: * A variable's value may be changed. * *---------------------------------------------------------------------- */ | < | | | 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 |
*
* Side effects:
* A variable's value may be changed.
*
*----------------------------------------------------------------------
*/
int
Tcl_AppendObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Var *varPtr, *arrayPtr;
Tcl_Obj *varValuePtr = NULL;
/* Initialized to avoid compiler warning. */
int i;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "varName ?value ...?");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2804 2805 2806 2807 2808 2809 2810 | * * Side effects: * A variable's value may be changed. * *---------------------------------------------------------------------- */ | < | | 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 |
*
* Side effects:
* A variable's value may be changed.
*
*----------------------------------------------------------------------
*/
int
Tcl_LappendObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Obj *varValuePtr, *newValuePtr;
int numElems, createdNewObj;
Var *varPtr, *arrayPtr;
|
| ︙ | ︙ | |||
3013 3014 3015 3016 3017 3018 3019 |
*valuePtrPtr = valueObj;
return donerc;
}
static int
ArrayForObjCmd(
| | | | | 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 |
*valuePtrPtr = valueObj;
return donerc;
}
static int
ArrayForObjCmd(
ClientData clientData,
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
return Tcl_NRCallObjProc(interp, ArrayForNRCmd, clientData, objc, objv);
}
static int
ArrayForNRCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv)
{
Tcl_Obj *varListObj, *arrayNameObj, *scriptObj;
ArraySearch *searchPtr = NULL;
Var *varPtr;
|
| ︙ | ︙ | |||
3071 3072 3073 3074 3075 3076 3077 |
return NotArrayError(interp, arrayNameObj);
}
/*
* Make a new array search, put it on the stack.
*/
| | | 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 |
return NotArrayError(interp, arrayNameObj);
}
/*
* Make a new array search, put it on the stack.
*/
searchPtr = (ArraySearch *)ckalloc(sizeof(ArraySearch));
ArrayPopulateSearch(interp, arrayNameObj, varPtr, searchPtr);
/*
* Make sure that these objects (which we need throughout the body of the
* loop) don't vanish.
*/
|
| ︙ | ︙ | |||
3099 3100 3101 3102 3103 3104 3105 |
static int
ArrayForLoopCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
| | | | | | 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 |
static int
ArrayForLoopCallback(
ClientData data[],
Tcl_Interp *interp,
int result)
{
Interp *iPtr = (Interp *) interp;
ArraySearch *searchPtr = (ArraySearch *)data[0];
Tcl_Obj *varListObj = (Tcl_Obj *)data[1];
Tcl_Obj *arrayNameObj = (Tcl_Obj *)data[2];
Tcl_Obj *scriptObj = (Tcl_Obj *)data[3];
Tcl_Obj **varv;
Tcl_Obj *keyObj, *valueObj;
Var *varPtr;
Var *arrayPtr;
int done, varc;
/*
|
| ︙ | ︙ | |||
3192 3193 3194 3195 3196 3197 3198 | /* * If the search was terminated by an array change, the * VAR_SEARCH_ACTIVE flag will no longer be set. */ ArrayDoneSearch(iPtr, varPtr, searchPtr); Tcl_DecrRefCount(searchPtr->name); | | | 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 |
/*
* If the search was terminated by an array change, the
* VAR_SEARCH_ACTIVE flag will no longer be set.
*/
ArrayDoneSearch(iPtr, varPtr, searchPtr);
Tcl_DecrRefCount(searchPtr->name);
ckfree(searchPtr);
}
TclDecrRefCount(varListObj);
TclDecrRefCount(scriptObj);
return result;
}
|
| ︙ | ︙ | |||
3222 3223 3224 3225 3226 3227 3228 |
hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
if (isNew) {
searchPtr->id = 1;
varPtr->flags |= VAR_SEARCH_ACTIVE;
searchPtr->nextPtr = NULL;
} else {
searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
| | | 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 |
hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
if (isNew) {
searchPtr->id = 1;
varPtr->flags |= VAR_SEARCH_ACTIVE;
searchPtr->nextPtr = NULL;
} else {
searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
searchPtr->nextPtr = (ArraySearch *)Tcl_GetHashValue(hPtr);
}
searchPtr->varPtr = varPtr;
searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
&searchPtr->search);
Tcl_SetHashValue(hPtr, searchPtr);
searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id,
TclGetString(arrayNameObj));
|
| ︙ | ︙ | |||
3250 3251 3252 3253 3254 3255 3256 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < < | | 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayStartSearchCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Var *varPtr;
int isArray;
ArraySearch *searchPtr;
|
| ︙ | ︙ | |||
3280 3281 3282 3283 3284 3285 3286 |
return NotArrayError(interp, objv[1]);
}
/*
* Make a new array search with a free name.
*/
| | | 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 |
return NotArrayError(interp, objv[1]);
}
/*
* Make a new array search with a free name.
*/
searchPtr = (ArraySearch *)ckalloc(sizeof(ArraySearch));
ArrayPopulateSearch(interp, objv[1], varPtr, searchPtr);
Tcl_SetObjResult(interp, searchPtr->name);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
3321 3322 3323 3324 3325 3326 3327 |
if (searchPtr->nextPtr) {
Tcl_SetHashValue(hPtr, searchPtr->nextPtr);
} else {
varPtr->flags &= ~VAR_SEARCH_ACTIVE;
Tcl_DeleteHashEntry(hPtr);
}
} else {
| | | 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 |
if (searchPtr->nextPtr) {
Tcl_SetHashValue(hPtr, searchPtr->nextPtr);
} else {
varPtr->flags &= ~VAR_SEARCH_ACTIVE;
Tcl_DeleteHashEntry(hPtr);
}
} else {
for (prevPtr = (ArraySearch *)Tcl_GetHashValue(hPtr); ; prevPtr=prevPtr->nextPtr) {
if (prevPtr->nextPtr == searchPtr) {
prevPtr->nextPtr = searchPtr->nextPtr;
break;
}
}
}
}
|
| ︙ | ︙ | |||
3347 3348 3349 3350 3351 3352 3353 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayAnyMoreCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
Var *varPtr;
Tcl_Obj *varNameObj, *searchObj;
|
| ︙ | ︙ | |||
3426 3427 3428 3429 3430 3431 3432 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayNextElementCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Var *varPtr;
Tcl_Obj *varNameObj, *searchObj;
ArraySearch *searchPtr;
|
| ︙ | ︙ | |||
3507 3508 3509 3510 3511 3512 3513 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayDoneSearchCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *) interp;
Var *varPtr;
Tcl_Obj *varNameObj, *searchObj;
|
| ︙ | ︙ | |||
3547 3548 3549 3550 3551 3552 3553 |
searchPtr = ParseSearchId(interp, varPtr, varNameObj, searchObj);
if (searchPtr == NULL) {
return TCL_ERROR;
}
ArrayDoneSearch(iPtr, varPtr, searchPtr);
Tcl_DecrRefCount(searchPtr->name);
| | < | | 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 |
searchPtr = ParseSearchId(interp, varPtr, varNameObj, searchObj);
if (searchPtr == NULL) {
return TCL_ERROR;
}
ArrayDoneSearch(iPtr, varPtr, searchPtr);
Tcl_DecrRefCount(searchPtr->name);
ckfree(searchPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ArrayExistsCmd --
*
* This object-based function is invoked to process the "array exists"
* Tcl command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result object.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayExistsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Interp *iPtr = (Interp *)interp;
int isArray;
|
| ︙ | ︙ | |||
3609 3610 3611 3612 3613 3614 3615 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayGetCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Var *varPtr, *varPtr2;
Tcl_Obj *varNameObj, *nameObj, *valueObj, *nameLstObj, *tmpResObj;
Tcl_Obj **nameObjPtr, *patternObj;
|
| ︙ | ︙ | |||
3769 3770 3771 3772 3773 3774 3775 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayNamesCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
static const char *const options[] = {
"-exact", "-glob", "-regexp", NULL
};
|
| ︙ | ︙ | |||
3937 3938 3939 3940 3941 3942 3943 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArraySetCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *arrayNameObj;
Tcl_Obj *arrayElemObj;
Var *varPtr, *arrayPtr;
|
| ︙ | ︙ | |||
4113 4114 4115 4116 4117 4118 4119 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArraySizeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Var *varPtr;
Tcl_HashSearch search;
Var *varPtr2;
|
| ︙ | ︙ | |||
4173 4174 4175 4176 4177 4178 4179 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 4315 4316 4317 4318 4319 4320 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayStatsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Var *varPtr;
Tcl_Obj *varNameObj;
char *stats;
|
| ︙ | ︙ | |||
4207 4208 4209 4210 4211 4212 4213 |
stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr);
if (stats == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"error reading array statistics", -1));
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1));
| | < | | 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 |
stats = Tcl_HashStats((Tcl_HashTable *) varPtr->value.tablePtr);
if (stats == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"error reading array statistics", -1));
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1));
ckfree(stats);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ArrayUnsetCmd --
*
* This object-based function is invoked to process the "array unset" Tcl
* command. See the user documentation for details on what it does.
*
* Results:
* A standard Tcl result object.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayUnsetCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Var *varPtr, *varPtr2, *protectedVarPtr;
Tcl_Obj *varNameObj, *patternObj, *nameObj;
Tcl_HashSearch search;
|
| ︙ | ︙ | |||
4365 4366 4367 4368 4369 4370 4371 | * * Side effects: * Creates a command in the global namespace. * *---------------------------------------------------------------------- */ | < | 4494 4495 4496 4497 4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 |
*
* Side effects:
* Creates a command in the global namespace.
*
*----------------------------------------------------------------------
*/
Tcl_Command
TclInitArrayCmd(
Tcl_Interp *interp) /* Current interpreter. */
{
static const EnsembleImplMap arrayImplMap[] = {
{"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
{"default", ArrayDefaultCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0},
|
| ︙ | ︙ | |||
4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 |
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UpVar2 --
*
* This function links one variable to another, just like the "upvar"
* command.
*
* Results:
* A standard Tcl completion code. If an error occurs then an error
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 4818 4819 4820 4821 4822 4823 4824 4825 4826 4827 4828 4829 4830 4831 4832 4833 4834 4835 4836 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 |
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_UpVar --
*
* This function links one variable to another, just like the "upvar"
* command.
*
* Results:
* A standard Tcl completion code. If an error occurs then an error
* message is left in the interp's result.
*
* Side effects:
* The variable in frameName whose name is given by varName becomes
* accessible under the name localNameStr, so that references to
* localNameStr are redirected to the other variable like a symbolic
* link.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
#undef Tcl_UpVar
int
Tcl_UpVar(
Tcl_Interp *interp, /* Command interpreter in which varName is to
* be looked up. */
const char *frameName, /* Name of the frame containing the source
* variable, such as "1" or "#0". */
const char *varName, /* Name of a variable in interp to link to.
* May be either a scalar name or an element
* in an array. */
const char *localNameStr, /* Name of link variable. */
int flags) /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY:
* indicates scope of localNameStr. */
{
int result;
CallFrame *framePtr;
Tcl_Obj *varNamePtr, *localNamePtr;
if (TclGetFrame(interp, frameName, &framePtr) == -1) {
return TCL_ERROR;
}
varNamePtr = Tcl_NewStringObj(varName, -1);
Tcl_IncrRefCount(varNamePtr);
localNamePtr = Tcl_NewStringObj(localNameStr, -1);
Tcl_IncrRefCount(localNamePtr);
result = ObjMakeUpvar(interp, framePtr, varNamePtr, NULL, 0,
localNamePtr, flags, -1);
Tcl_DecrRefCount(varNamePtr);
Tcl_DecrRefCount(localNamePtr);
return result;
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_UpVar2 --
*
* This function links one variable to another, just like the "upvar"
* command.
*
* Results:
* A standard Tcl completion code. If an error occurs then an error
|
| ︙ | ︙ | |||
4746 4747 4748 4749 4750 4751 4752 |
Tcl_Interp *interp, /* Interpreter containing the variable. */
Tcl_Var variable, /* Token for the variable returned by a
* previous call to Tcl_FindNamespaceVar. */
Tcl_Obj *objPtr) /* Points to the object onto which the
* variable's full name is appended. */
{
Interp *iPtr = (Interp *) interp;
| | | 4931 4932 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 |
Tcl_Interp *interp, /* Interpreter containing the variable. */
Tcl_Var variable, /* Token for the variable returned by a
* previous call to Tcl_FindNamespaceVar. */
Tcl_Obj *objPtr) /* Points to the object onto which the
* variable's full name is appended. */
{
Interp *iPtr = (Interp *) interp;
Var *varPtr = (Var *) variable;
Tcl_Obj *namePtr;
Namespace *nsPtr;
if (!varPtr || TclIsVarArrayElement(varPtr)) {
return;
}
|
| ︙ | ︙ | |||
4800 4801 4802 4803 4804 4805 4806 | * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_GlobalObjCmd( | | | | | 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 4996 4997 4998 4999 5000 5001 5002 5003 5004 5005 5006 5007 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_GlobalObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *objPtr, *tailPtr;
const char *varName;
const char *tail;
int result, i;
/*
* If we are not executing inside a Tcl procedure, just return.
*/
if (!HasLocalVars(iPtr->varFramePtr)) {
|
| ︙ | ︙ | |||
4904 4905 4906 4907 4908 4909 4910 | * result in the interpreter's result object. * *---------------------------------------------------------------------- */ int Tcl_VariableObjCmd( | | | 5089 5090 5091 5092 5093 5094 5095 5096 5097 5098 5099 5100 5101 5102 5103 |
* result in the interpreter's result object.
*
*----------------------------------------------------------------------
*/
int
Tcl_VariableObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
const char *varName, *tail, *cp;
Var *varPtr, *arrayPtr;
|
| ︙ | ︙ | |||
5035 5036 5037 5038 5039 5040 5041 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_UpvarObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
CallFrame *framePtr;
int result, hasLevel;
Tcl_Obj *levelObj;
|
| ︙ | ︙ | |||
5152 5153 5154 5155 5156 5157 5158 |
char *end;
if (varPtr->flags & VAR_SEARCH_ACTIVE) {
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(&iPtr->varSearches, varPtr);
/* First look for same (Tcl_Obj *) */
| | | | 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 |
char *end;
if (varPtr->flags & VAR_SEARCH_ACTIVE) {
Tcl_HashEntry *hPtr =
Tcl_FindHashEntry(&iPtr->varSearches, varPtr);
/* First look for same (Tcl_Obj *) */
for (searchPtr = (ArraySearch *)Tcl_GetHashValue(hPtr); searchPtr != NULL;
searchPtr = searchPtr->nextPtr) {
if (searchPtr->name == handleObj) {
return searchPtr;
}
}
/* Fallback: do string compares. */
for (searchPtr = (ArraySearch *)Tcl_GetHashValue(hPtr); searchPtr != NULL;
searchPtr = searchPtr->nextPtr) {
if (strcmp(TclGetString(searchPtr->name), handle) == 0) {
return searchPtr;
}
}
}
if ((handle[0] != 's') || (handle[1] != '-')
|
| ︙ | ︙ | |||
5203 5204 5205 5206 5207 5208 5209 |
*
*----------------------------------------------------------------------
*/
static void
DeleteSearches(
Interp *iPtr,
| | | | | 5387 5388 5389 5390 5391 5392 5393 5394 5395 5396 5397 5398 5399 5400 5401 5402 5403 5404 5405 5406 5407 5408 5409 5410 5411 5412 5413 |
*
*----------------------------------------------------------------------
*/
static void
DeleteSearches(
Interp *iPtr,
Var *arrayVarPtr) /* Variable whose searches are to be
* deleted. */
{
ArraySearch *searchPtr, *nextPtr;
Tcl_HashEntry *sPtr;
if (arrayVarPtr->flags & VAR_SEARCH_ACTIVE) {
sPtr = Tcl_FindHashEntry(&iPtr->varSearches, arrayVarPtr);
for (searchPtr = (ArraySearch *)Tcl_GetHashValue(sPtr); searchPtr != NULL;
searchPtr = nextPtr) {
nextPtr = searchPtr->nextPtr;
Tcl_DecrRefCount(searchPtr->name);
ckfree(searchPtr);
}
arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE;
Tcl_DeleteHashEntry(sPtr);
}
}
/*
|
| ︙ | ︙ | |||
5281 5282 5283 5284 5285 5286 5287 |
* so we cannot let such things linger. That would be a leak.
*
* First we destroy all traces. ...
*/
if (TclIsVarTraced(varPtr)) {
Tcl_HashEntry *tPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr);
| | | 5465 5466 5467 5468 5469 5470 5471 5472 5473 5474 5475 5476 5477 5478 5479 |
* so we cannot let such things linger. That would be a leak.
*
* First we destroy all traces. ...
*/
if (TclIsVarTraced(varPtr)) {
Tcl_HashEntry *tPtr = Tcl_FindHashEntry(&iPtr->varTraces, varPtr);
VarTrace *tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr);
ActiveVarTrace *activePtr;
while (tracePtr) {
VarTrace *prevPtr = tracePtr;
tracePtr = tracePtr->nextPtr;
prevPtr->nextPtr = NULL;
|
| ︙ | ︙ | |||
5345 5346 5347 5348 5349 5350 5351 |
TclDeleteVars(
Interp *iPtr, /* Interpreter to which variables belong. */
TclVarHashTable *tablePtr) /* Hash table containing variables to
* delete. */
{
Tcl_Interp *interp = (Tcl_Interp *) iPtr;
Tcl_HashSearch search;
| | | 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 |
TclDeleteVars(
Interp *iPtr, /* Interpreter to which variables belong. */
TclVarHashTable *tablePtr) /* Hash table containing variables to
* delete. */
{
Tcl_Interp *interp = (Tcl_Interp *) iPtr;
Tcl_HashSearch search;
Var *varPtr;
int flags;
Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
/*
* Determine what flags to pass to the trace callback functions.
*/
|
| ︙ | ︙ | |||
5397 5398 5399 5400 5401 5402 5403 |
void
TclDeleteCompiledLocalVars(
Interp *iPtr, /* Interpreter to which variables belong. */
CallFrame *framePtr) /* Procedure call frame containing compiler-
* assigned local variables to delete. */
{
| | | 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 |
void
TclDeleteCompiledLocalVars(
Interp *iPtr, /* Interpreter to which variables belong. */
CallFrame *framePtr) /* Procedure call frame containing compiler-
* assigned local variables to delete. */
{
Var *varPtr;
int numLocals, i;
Tcl_Obj **namePtrPtr;
numLocals = framePtr->numCompiledLocals;
varPtr = framePtr->compiledLocals;
namePtrPtr = &localName(framePtr, 0);
for (i=0 ; i<numLocals ; i++, namePtrPtr++, varPtr++) {
|
| ︙ | ︙ | |||
5446 5447 5448 5449 5450 5451 5452 |
int flags, /* Flags to pass to TclCallVarTraces:
* TCL_TRACE_UNSETS and sometimes
* TCL_NAMESPACE_ONLY or TCL_GLOBAL_ONLY. */
int index)
{
Tcl_HashSearch search;
Tcl_HashEntry *tPtr;
| | | 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 |
int flags, /* Flags to pass to TclCallVarTraces:
* TCL_TRACE_UNSETS and sometimes
* TCL_NAMESPACE_ONLY or TCL_GLOBAL_ONLY. */
int index)
{
Tcl_HashSearch search;
Tcl_HashEntry *tPtr;
Var *elPtr;
ActiveVarTrace *activePtr;
Tcl_Obj *objPtr;
VarTrace *tracePtr;
for (elPtr = VarHashFirstVar(varPtr->value.tablePtr, &search);
elPtr != NULL; elPtr = VarHashNextVar(&search)) {
if (TclIsVarScalar(elPtr) && (elPtr->value.objPtr != NULL)) {
|
| ︙ | ︙ | |||
5478 5479 5480 5481 5482 5483 5484 | Tcl_Obj *elNamePtr = VarHashGetKey(elPtr); elPtr->flags &= ~VAR_TRACE_ACTIVE; TclObjCallVarTraces(iPtr, NULL, elPtr, arrayNamePtr, elNamePtr, flags,/* leaveErrMsg */ 0, index); } tPtr = Tcl_FindHashEntry(&iPtr->varTraces, elPtr); | | | 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 |
Tcl_Obj *elNamePtr = VarHashGetKey(elPtr);
elPtr->flags &= ~VAR_TRACE_ACTIVE;
TclObjCallVarTraces(iPtr, NULL, elPtr, arrayNamePtr,
elNamePtr, flags,/* leaveErrMsg */ 0, index);
}
tPtr = Tcl_FindHashEntry(&iPtr->varTraces, elPtr);
tracePtr = (VarTrace *)Tcl_GetHashValue(tPtr);
while (tracePtr) {
VarTrace *prevPtr = tracePtr;
tracePtr = tracePtr->nextPtr;
prevPtr->nextPtr = NULL;
Tcl_EventuallyFree(prevPtr, TCL_DYNAMIC);
}
|
| ︙ | ︙ | |||
5635 5636 5637 5638 5639 5640 5641 |
* Tcl_Obj), or NULL if it is a scalar variable
*/
static void
FreeParsedVarName(
Tcl_Obj *objPtr)
{
| | | | 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 5849 5850 |
* Tcl_Obj), or NULL if it is a scalar variable
*/
static void
FreeParsedVarName(
Tcl_Obj *objPtr)
{
Tcl_Obj *arrayPtr, *elem;
int parsed;
ParsedGetIntRep(objPtr, parsed, arrayPtr, elem);
parsed++; /* Silence compiler. */
if (arrayPtr != NULL) {
TclDecrRefCount(arrayPtr);
TclDecrRefCount(elem);
}
}
static void
DupParsedVarName(
Tcl_Obj *srcPtr,
Tcl_Obj *dupPtr)
{
Tcl_Obj *arrayPtr, *elem;
int parsed;
ParsedGetIntRep(srcPtr, parsed, arrayPtr, elem);
parsed++; /* Silence compiler. */
ParsedSetIntRep(dupPtr, arrayPtr, elem);
}
|
| ︙ | ︙ | |||
5741 5742 5743 5744 5745 5746 5747 |
* TCL_GLOBAL_ONLY is ignored. */
{
Interp *iPtr = (Interp *) interp;
ResolverScheme *resPtr;
Namespace *nsPtr[2], *cxtNsPtr;
const char *simpleName;
Var *varPtr;
| | | 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 |
* TCL_GLOBAL_ONLY is ignored. */
{
Interp *iPtr = (Interp *) interp;
ResolverScheme *resPtr;
Namespace *nsPtr[2], *cxtNsPtr;
const char *simpleName;
Var *varPtr;
int search;
int result;
Tcl_Var var;
Tcl_Obj *simpleNamePtr;
const char *name = TclGetString(namePtr);
/*
* If this namespace has a variable resolver, then give it first crack at
|
| ︙ | ︙ | |||
5791 5792 5793 5794 5795 5796 5797 |
}
}
/*
* Find the namespace(s) that contain the variable.
*/
| < < < < | 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 |
}
}
/*
* Find the namespace(s) that contain the variable.
*/
TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
/*
* Look for the variable in the variable table of its namespace. Be sure
* to check both possible search paths: from the specified namespace
* context and from the global namespace.
|
| ︙ | ︙ | |||
5853 5854 5855 5856 5857 5858 5859 | * error, the result is an error message. * *---------------------------------------------------------------------- */ int TclInfoVarsCmd( | | | 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
int
TclInfoVarsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
const char *varName, *pattern, *simplePattern;
Tcl_HashSearch search;
|
| ︙ | ︙ | |||
6044 6045 6046 6047 6048 6049 6050 | * error, the result is an error message. * *---------------------------------------------------------------------- */ int TclInfoGlobalsCmd( | | | 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
int
TclInfoGlobalsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *varName, *pattern;
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
Tcl_HashSearch search;
|
| ︙ | ︙ | |||
6137 6138 6139 6140 6141 6142 6143 | * error, the result is an error message. * *---------------------------------------------------------------------- */ int TclInfoLocalsCmd( | | | 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 6330 6331 |
* error, the result is an error message.
*
*----------------------------------------------------------------------
*/
int
TclInfoLocalsCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *patternPtr, *listPtr;
|
| ︙ | ︙ | |||
6288 6289 6290 6291 6292 6293 6294 |
objectVars:
if (!includeLinks) {
return;
}
if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) {
Method *mPtr = (Method *)
| | | 6468 6469 6470 6471 6472 6473 6474 6475 6476 6477 6478 6479 6480 6481 6482 |
objectVars:
if (!includeLinks) {
return;
}
if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) {
Method *mPtr = (Method *)
Tcl_ObjectContextMethod((Tcl_ObjectContext)iPtr->varFramePtr->clientData);
PrivateVariableMapping *privatePtr;
if (mPtr->declaringObjectPtr) {
Object *oPtr = mPtr->declaringObjectPtr;
FOREACH(objNamePtr, oPtr->variables) {
Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
|
| ︙ | ︙ | |||
6352 6353 6354 6355 6356 6357 6358 |
Tcl_InitCustomHashTable(&tablePtr->table,
TCL_CUSTOM_TYPE_KEYS, &tclVarHashKeyType);
tablePtr->nsPtr = nsPtr;
}
static Tcl_HashEntry *
AllocVarEntry(
| | | | 6532 6533 6534 6535 6536 6537 6538 6539 6540 6541 6542 6543 6544 6545 6546 6547 6548 6549 6550 6551 6552 6553 |
Tcl_InitCustomHashTable(&tablePtr->table,
TCL_CUSTOM_TYPE_KEYS, &tclVarHashKeyType);
tablePtr->nsPtr = nsPtr;
}
static Tcl_HashEntry *
AllocVarEntry(
TCL_UNUSED(Tcl_HashTable *),
void *keyPtr) /* Key to store in the hash table entry. */
{
Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr;
Tcl_HashEntry *hPtr;
Var *varPtr;
varPtr = (Var *)ckalloc(sizeof(VarInHash));
varPtr->flags = VAR_IN_HASHTABLE;
varPtr->value.objPtr = NULL;
VarHashRefCount(varPtr) = 1;
hPtr = &(((VarInHash *) varPtr)->entry);
Tcl_SetHashValue(hPtr, varPtr);
hPtr->key.objPtr = objPtr;
|
| ︙ | ︙ | |||
6381 6382 6383 6384 6385 6386 6387 |
Tcl_HashEntry *hPtr)
{
Var *varPtr = VarHashGetValue(hPtr);
Tcl_Obj *objPtr = hPtr->key.objPtr;
if (TclIsVarUndefined(varPtr) && !TclIsVarTraced(varPtr)
&& (VarHashRefCount(varPtr) == 1)) {
| | | | | | 6561 6562 6563 6564 6565 6566 6567 6568 6569 6570 6571 6572 6573 6574 6575 6576 6577 6578 6579 6580 6581 6582 6583 6584 6585 6586 6587 6588 6589 6590 6591 6592 |
Tcl_HashEntry *hPtr)
{
Var *varPtr = VarHashGetValue(hPtr);
Tcl_Obj *objPtr = hPtr->key.objPtr;
if (TclIsVarUndefined(varPtr) && !TclIsVarTraced(varPtr)
&& (VarHashRefCount(varPtr) == 1)) {
ckfree(varPtr);
} else {
VarHashInvalidateEntry(varPtr);
TclSetVarUndefined(varPtr);
VarHashRefCount(varPtr)--;
}
Tcl_DecrRefCount(objPtr);
}
static int
CompareVarKeys(
void *keyPtr, /* New key to compare. */
Tcl_HashEntry *hPtr) /* Existing key to compare. */
{
Tcl_Obj *objPtr1 = (Tcl_Obj *)keyPtr;
Tcl_Obj *objPtr2 = hPtr->key.objPtr;
const char *p1, *p2;
int l1, l2;
/*
* If the object pointers are the same then they match.
* OPT: this comparison was moved to the caller
*
* if (objPtr1 == objPtr2) return 1;
*/
|
| ︙ | ︙ | |||
6440 6441 6442 6443 6444 6445 6446 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 6620 6621 6622 6623 6624 6625 6626 6627 6628 6629 6630 6631 6632 6633 6634 6635 6636 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
ArrayDefaultCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const options[] = {
"get", "set", "exists", "unset", NULL
};
|
| ︙ | ︙ | |||
6589 6590 6591 6592 6593 6594 6595 |
* Initialize array variable.
*/
void
TclInitArrayVar(
Var *arrayPtr)
{
| | | 6768 6769 6770 6771 6772 6773 6774 6775 6776 6777 6778 6779 6780 6781 6782 |
* Initialize array variable.
*/
void
TclInitArrayVar(
Var *arrayPtr)
{
ArrayVarHashTable *tablePtr = (ArrayVarHashTable *)ckalloc(sizeof(ArrayVarHashTable));
/*
* Mark the variable as an array.
*/
TclSetVarArray(arrayPtr);
|
| ︙ | ︙ | |||
6633 6634 6635 6636 6637 6638 6639 |
SetArrayDefault(arrayPtr, NULL);
/*
* Regular TclVarHashTable cleanup.
*/
VarHashDeleteTable(arrayPtr->value.tablePtr);
| | | 6812 6813 6814 6815 6816 6817 6818 6819 6820 6821 6822 6823 6824 6825 6826 |
SetArrayDefault(arrayPtr, NULL);
/*
* Regular TclVarHashTable cleanup.
*/
VarHashDeleteTable(arrayPtr->value.tablePtr);
ckfree(tablePtr);
}
/*
* Get array default value if any.
*/
Tcl_Obj *
|
| ︙ | ︙ |
Changes to generic/tclZipfs.c.
| ︙ | ︙ | |||
22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | #ifndef _WIN32 #include <sys/mman.h> #endif /* _WIN32*/ #ifndef MAP_FILE #define MAP_FILE 0 #endif /* !MAP_FILE */ #ifdef HAVE_ZLIB #include "zlib.h" #include "crypt.h" #ifdef CFG_RUNTIME_DLLFILE /* ** We are compiling as part of the core. ** TIP430 style zipfs prefix */ | > > > > > > > | 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 | #ifndef _WIN32 #include <sys/mman.h> #endif /* _WIN32*/ #ifndef MAP_FILE #define MAP_FILE 0 #endif /* !MAP_FILE */ #define NOBYFOUR #define crc32tab crc_table[0] #ifndef TBLS #define TBLS 1 #endif #ifdef HAVE_ZLIB #include "zlib.h" #include "crypt.h" #include "zutil.h" #include "crc32.h" #ifdef CFG_RUNTIME_DLLFILE /* ** We are compiling as part of the core. ** TIP430 style zipfs prefix */ |
| ︙ | ︙ | |||
273 274 275 276 277 278 279 280 281 282 283 284 285 |
int waiters; /* RW lock, see below */
int wrmax; /* Maximum write size of a file */
int idCount; /* Counter for channel names */
Tcl_HashTable fileHash; /* File name to ZipEntry mapping */
Tcl_HashTable zipHash; /* Mount to ZipFile mapping */
} ZipFS = {
0, 0, 0, DEFAULT_WRITE_MAX_SIZE, 0,
};
/*
* For password rotation.
*/
| > > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 |
int waiters; /* RW lock, see below */
int wrmax; /* Maximum write size of a file */
int idCount; /* Counter for channel names */
Tcl_HashTable fileHash; /* File name to ZipEntry mapping */
Tcl_HashTable zipHash; /* Mount to ZipFile mapping */
} ZipFS = {
0, 0, 0, DEFAULT_WRITE_MAX_SIZE, 0,
{0,{0,0,0,0},0,0,0,0,0,0,0,0,0},
{0,{0,0,0,0},0,0,0,0,0,0,0,0,0}
};
/*
* For password rotation.
*/
static const char pwrot[17] =
"\x00\x80\x40\xC0\x20\xA0\x60\xE0"
"\x10\x90\x50\xD0\x30\xB0\x70\xF0";
static const char *zipfs_literal_tcl_library = NULL;
/* Function prototypes */
static inline int DescribeMounted(Tcl_Interp *interp,
const char *mountPoint);
static inline int ListMountPoints(Tcl_Interp *interp);
|
| ︙ | ︙ | |||
379 380 381 382 383 384 385 | Tcl_Obj *pathPtr, Tcl_Obj *objPtr); static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); static void ZipfsExitHandler(ClientData clientData); static void ZipfsSetup(void); static int ZipChannelClose(void *instanceData, | | | < > > > > < < | | 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 |
Tcl_Obj *pathPtr, Tcl_Obj *objPtr);
static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path,
Tcl_LoadHandle *loadHandle,
Tcl_FSUnloadFileProc **unloadProcPtr, int flags);
static void ZipfsExitHandler(ClientData clientData);
static void ZipfsSetup(void);
static int ZipChannelClose(void *instanceData,
Tcl_Interp *interp, int flags);
static Tcl_DriverGetHandleProc ZipChannelGetFile;
static int ZipChannelRead(void *instanceData, char *buf,
int toRead, int *errloc);
#ifndef TCL_NO_DEPRECATED
static int ZipChannelSeek(void *instanceData, long offset,
int mode, int *errloc);
#endif
static Tcl_WideInt ZipChannelWideSeek(void *instanceData, Tcl_WideInt offset,
int mode, int *errloc);
static void ZipChannelWatchChannel(void *instanceData,
int mask);
static int ZipChannelWrite(void *instanceData,
const char *buf, int toWrite, int *errloc);
/*
* Define the ZIP filesystem dispatch table.
*/
static const Tcl_Filesystem zipfsFilesystem = {
"zipfs",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_2,
ZipFSPathInFilesystemProc,
NULL, /* dupInternalRepProc */
NULL, /* freeInternalRepProc */
NULL, /* internalToNormalizedProc */
|
| ︙ | ︙ | |||
426 427 428 429 430 431 432 |
NULL, /* createDirectoryProc */
NULL, /* removeDirectoryProc */
NULL, /* deleteFileProc */
NULL, /* copyFileProc */
NULL, /* renameFileProc */
NULL, /* copyDirectoryProc */
NULL, /* lstatProc */
| | | > > > > | | > > > > > > | 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 |
NULL, /* createDirectoryProc */
NULL, /* removeDirectoryProc */
NULL, /* deleteFileProc */
NULL, /* copyFileProc */
NULL, /* renameFileProc */
NULL, /* copyDirectoryProc */
NULL, /* lstatProc */
(Tcl_FSLoadFileProc *)(void *)ZipFSLoadFile,
NULL, /* getCwdProc */
NULL, /* chdirProc */
};
/*
* The channel type/driver definition used for ZIP archive members.
*/
static Tcl_ChannelType ZipChannelType = {
"zip", /* Type name. */
TCL_CHANNEL_VERSION_5,
TCL_CLOSE2PROC, /* Close channel, clean instance data */
ZipChannelRead, /* Handle read request */
ZipChannelWrite, /* Handle write request */
#ifndef TCL_NO_DEPRECATED
ZipChannelSeek, /* Move location of access point, NULL'able */
#else
NULL, /* Move location of access point, NULL'able */
#endif
NULL, /* Set options, NULL'able */
NULL, /* Get options, NULL'able */
ZipChannelWatchChannel, /* Initialize notifier */
ZipChannelGetFile, /* Get OS handle from the channel */
ZipChannelClose, /* 2nd version of close channel, NULL'able */
NULL, /* Set blocking mode for raw channel, NULL'able */
NULL, /* Function to flush channel, NULL'able */
NULL, /* Function to handle event, NULL'able */
ZipChannelWideSeek, /* Wide seek function, NULL'able */
NULL, /* Thread action function, NULL'able */
NULL, /* Truncate function, NULL'able */
};
/*
* Miscellaneous constants.
*/
#define ERROR_LENGTH ((size_t) -1)
/*
*-------------------------------------------------------------------------
*
* ReadLock, WriteLock, Unlock --
*
* POSIX like rwlock functions to support multiple readers and single
|
| ︙ | ︙ | |||
835 836 837 838 839 840 841 |
char *filename)
{
Tcl_HashEntry *hPtr;
ZipEntry *z = NULL;
hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, filename);
if (hPtr) {
| | | 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 |
char *filename)
{
Tcl_HashEntry *hPtr;
ZipEntry *z = NULL;
hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, filename);
if (hPtr) {
z = (ZipEntry *)Tcl_GetHashValue(hPtr);
}
return z;
}
/*
*-------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
900 901 902 903 904 905 906 |
static void
ZipFSCloseArchive(
Tcl_Interp *interp, /* Current interpreter. */
ZipFile *zf)
{
if (zf->nameLength) {
| | | | | | 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 |
static void
ZipFSCloseArchive(
Tcl_Interp *interp, /* Current interpreter. */
ZipFile *zf)
{
if (zf->nameLength) {
ckfree(zf->name);
}
if (zf->isMemBuffer) {
/* Pointer to memory */
if (zf->ptrToFree) {
ckfree(zf->ptrToFree);
zf->ptrToFree = NULL;
}
zf->data = NULL;
return;
}
#ifdef _WIN32
if (zf->data && !zf->ptrToFree) {
UnmapViewOfFile(zf->data);
zf->data = NULL;
}
if (zf->mountHandle != INVALID_HANDLE_VALUE) {
CloseHandle(zf->mountHandle);
}
#else /* !_WIN32 */
if ((zf->data != MAP_FAILED) && !zf->ptrToFree) {
munmap(zf->data, zf->length);
zf->data = (unsigned char *)MAP_FAILED;
}
#endif /* _WIN32 */
if (zf->ptrToFree) {
ckfree(zf->ptrToFree);
zf->ptrToFree = NULL;
}
if (zf->chan) {
Tcl_Close(interp, zf->chan);
zf->chan = NULL;
}
}
|
| ︙ | ︙ | |||
1093 1094 1095 1096 1097 1098 1099 |
zf->nameLength = 0;
zf->isMemBuffer = 0;
#ifdef _WIN32
zf->data = NULL;
zf->mountHandle = INVALID_HANDLE_VALUE;
#else /* !_WIN32 */
| | | | | 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 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 |
zf->nameLength = 0;
zf->isMemBuffer = 0;
#ifdef _WIN32
zf->data = NULL;
zf->mountHandle = INVALID_HANDLE_VALUE;
#else /* !_WIN32 */
zf->data = (unsigned char *)MAP_FAILED;
#endif /* _WIN32 */
zf->length = 0;
zf->numFiles = 0;
zf->baseOffset = zf->passOffset = 0;
zf->ptrToFree = NULL;
zf->passBuf[0] = 0;
zf->chan = Tcl_OpenFileChannel(interp, zipname, "rb", 0);
if (!zf->chan) {
return TCL_ERROR;
}
if (Tcl_GetChannelHandle(zf->chan, TCL_READABLE, &handle) != TCL_OK) {
zf->length = Tcl_Seek(zf->chan, 0, SEEK_END);
if (zf->length == ERROR_LENGTH) {
ZIPFS_POSIX_ERROR(interp, "seek error");
goto error;
}
if ((zf->length - ZIP_CENTRAL_END_LEN)
> (64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) {
ZIPFS_ERROR(interp, "illegal file size");
if (interp) {
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_SIZE", NULL);
}
goto error;
}
if (Tcl_Seek(zf->chan, 0, SEEK_SET) == -1) {
ZIPFS_POSIX_ERROR(interp, "seek error");
goto error;
}
zf->ptrToFree = zf->data = (unsigned char *)attemptckalloc(zf->length);
if (!zf->ptrToFree) {
ZIPFS_ERROR(interp, "out of memory");
if (interp) {
Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
}
goto error;
}
|
| ︙ | ︙ | |||
1151 1152 1153 1154 1155 1156 1157 |
zf->length = GetFileSize((HANDLE) handle, 0);
readSuccessful = (zf->length != (size_t) INVALID_FILE_SIZE);
# endif /* _WIN64 */
if (!readSuccessful || (zf->length < ZIP_CENTRAL_END_LEN)) {
ZIPFS_POSIX_ERROR(interp, "invalid file size");
goto error;
}
| | | | | 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 |
zf->length = GetFileSize((HANDLE) handle, 0);
readSuccessful = (zf->length != (size_t) INVALID_FILE_SIZE);
# endif /* _WIN64 */
if (!readSuccessful || (zf->length < ZIP_CENTRAL_END_LEN)) {
ZIPFS_POSIX_ERROR(interp, "invalid file size");
goto error;
}
zf->mountHandle = CreateFileMappingW((HANDLE) handle, 0, PAGE_READONLY,
0, zf->length, 0);
if (zf->mountHandle == INVALID_HANDLE_VALUE) {
ZIPFS_POSIX_ERROR(interp, "file mapping failed");
goto error;
}
zf->data = (unsigned char *)MapViewOfFile(zf->mountHandle, FILE_MAP_READ, 0, 0,
zf->length);
if (!zf->data) {
ZIPFS_POSIX_ERROR(interp, "file mapping failed");
goto error;
}
#else /* !_WIN32 */
zf->length = lseek(PTR2INT(handle), 0, SEEK_END);
if (zf->length == ERROR_LENGTH || zf->length < ZIP_CENTRAL_END_LEN) {
ZIPFS_POSIX_ERROR(interp, "invalid file size");
goto error;
}
lseek(PTR2INT(handle), 0, SEEK_SET);
zf->data = (unsigned char *) mmap(0, zf->length, PROT_READ,
MAP_FILE | MAP_PRIVATE, PTR2INT(handle), 0);
if (zf->data == MAP_FAILED) {
|
| ︙ | ︙ | |||
1253 1254 1255 1256 1257 1258 1259 |
mountPoint = "";
} else {
mountPoint = CanonicalPath("", mountPoint, &dsm, 1);
}
hPtr = Tcl_CreateHashEntry(&ZipFS.zipHash, mountPoint, &isNew);
if (!isNew) {
if (interp) {
| | | | | | | | | 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 |
mountPoint = "";
} else {
mountPoint = CanonicalPath("", mountPoint, &dsm, 1);
}
hPtr = Tcl_CreateHashEntry(&ZipFS.zipHash, mountPoint, &isNew);
if (!isNew) {
if (interp) {
zf = (ZipFile *)Tcl_GetHashValue(hPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s is already mounted on %s", zf->name, mountPoint));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "MOUNTED", NULL);
}
Unlock();
ZipFSCloseArchive(interp, zf0);
return TCL_ERROR;
}
zf = (ZipFile *)attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1);
if (!zf) {
if (interp) {
Tcl_AppendResult(interp, "out of memory", (char *) NULL);
Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
}
Unlock();
ZipFSCloseArchive(interp, zf0);
return TCL_ERROR;
}
Unlock();
*zf = *zf0;
zf->mountPoint = (char *)Tcl_GetHashKey(&ZipFS.zipHash, hPtr);
Tcl_CreateExitHandler(ZipfsExitHandler, zf);
zf->mountPointLen = strlen(zf->mountPoint);
zf->nameLength = strlen(zipname);
zf->name = (char *)ckalloc(zf->nameLength + 1);
memcpy(zf->name, zipname, zf->nameLength + 1);
zf->entries = NULL;
zf->topEnts = NULL;
zf->numOpen = 0;
Tcl_SetHashValue(hPtr, zf);
if ((zf->passBuf[0] == 0) && pwlen) {
int k = 0;
zf->passBuf[k++] = pwlen;
for (i = pwlen; i-- > 0 ;) {
zf->passBuf[k++] = (passwd[i] & 0x0f)
| pwrot[(passwd[i] >> 4) & 0x0f];
}
zf->passBuf[k] = '\0';
}
if (mountPoint[0] != '\0') {
hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, mountPoint, &isNew);
if (isNew) {
z = (ZipEntry *)ckalloc(sizeof(ZipEntry));
Tcl_SetHashValue(hPtr, z);
z->tnext = NULL;
z->depth = CountSlashes(mountPoint);
z->zipFilePtr = zf;
z->isDirectory = (zf->baseOffset == 0) ? 1 : -1; /* root marker */
z->isEncrypted = 0;
z->offset = zf->baseOffset;
z->crc32 = 0;
z->timestamp = 0;
z->numBytes = z->numCompressedBytes = 0;
z->compressMethod = ZIP_COMPMETH_STORED;
z->data = NULL;
z->name = (char *)Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
z->next = zf->entries;
zf->entries = z;
}
}
q = zf->data + zf->directoryOffset;
Tcl_DStringInit(&fpBuf);
for (i = 0; i < zf->numFiles; i++) {
|
| ︙ | ︙ | |||
1393 1394 1395 1396 1397 1398 1399 | * Regular files skipped when mounting on root. */ goto nextent; #endif /* ANDROID */ } Tcl_DStringSetLength(&fpBuf, 0); fullpath = CanonicalPath(mountPoint, path, &fpBuf, 1); | | | 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 | * Regular files skipped when mounting on root. */ goto nextent; #endif /* ANDROID */ } Tcl_DStringSetLength(&fpBuf, 0); fullpath = CanonicalPath(mountPoint, path, &fpBuf, 1); z = (ZipEntry *)ckalloc(sizeof(ZipEntry)); z->name = NULL; z->tnext = NULL; z->depth = CountSlashes(fullpath); z->zipFilePtr = zf; z->isDirectory = isdir; z->isEncrypted = (ZipReadShort(lq + ZIP_LOCAL_FLAGS_OFFS) & 1) && (nbcompr > 12); |
| ︙ | ︙ | |||
1422 1423 1424 1425 1426 1427 1428 |
z->compressMethod = ZipReadShort(lq + ZIP_LOCAL_COMPMETH_OFFS);
}
z->numCompressedBytes = nbcompr;
z->data = NULL;
hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew);
if (!isNew) {
/* should not happen but skip it anyway */
| | | | 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 |
z->compressMethod = ZipReadShort(lq + ZIP_LOCAL_COMPMETH_OFFS);
}
z->numCompressedBytes = nbcompr;
z->data = NULL;
hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew);
if (!isNew) {
/* should not happen but skip it anyway */
ckfree(z);
} else {
Tcl_SetHashValue(hPtr, z);
z->name = (char *)Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
z->next = zf->entries;
zf->entries = z;
if (isdir && (mountPoint[0] == '\0') && (z->depth == 1)) {
z->tnext = zf->topEnts;
zf->topEnts = z;
}
if (!z->isDirectory && (z->depth > 1)) {
|
| ︙ | ︙ | |||
1447 1448 1449 1450 1451 1452 1453 |
for (end = strrchr(dir, '/'); end && (end != dir);
end = strrchr(dir, '/')) {
Tcl_DStringSetLength(&ds, end - dir);
hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew);
if (!isNew) {
break;
}
| | | | 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 |
for (end = strrchr(dir, '/'); end && (end != dir);
end = strrchr(dir, '/')) {
Tcl_DStringSetLength(&ds, end - dir);
hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew);
if (!isNew) {
break;
}
zd = (ZipEntry *)ckalloc(sizeof(ZipEntry));
zd->name = NULL;
zd->tnext = NULL;
zd->depth = CountSlashes(dir);
zd->zipFilePtr = zf;
zd->isDirectory = 1;
zd->isEncrypted = 0;
zd->offset = z->offset;
zd->crc32 = 0;
zd->timestamp = z->timestamp;
zd->numBytes = zd->numCompressedBytes = 0;
zd->compressMethod = ZIP_COMPMETH_STORED;
zd->data = NULL;
Tcl_SetHashValue(hPtr, zd);
zd->name = (char *)Tcl_GetHashKey(&ZipFS.fileHash, hPtr);
zd->next = zf->entries;
zf->entries = zd;
if ((mountPoint[0] == '\0') && (zd->depth == 1)) {
zd->tnext = zf->topEnts;
zf->topEnts = zd;
}
}
|
| ︙ | ︙ | |||
1547 1548 1549 1550 1551 1552 1553 |
ZipFile *zf;
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
if (!interp) {
return TCL_OK;
}
| | | 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 |
ZipFile *zf;
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
if (!interp) {
return TCL_OK;
}
zf = (ZipFile *)Tcl_GetHashValue(hPtr);
Tcl_AppendElement(interp, zf->mountPoint);
Tcl_AppendElement(interp, zf->name);
}
return (interp ? TCL_OK : TCL_BREAK);
}
/*
|
| ︙ | ︙ | |||
1584 1585 1586 1587 1588 1589 1590 |
{
Tcl_HashEntry *hPtr;
ZipFile *zf;
if (interp) {
hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint);
if (hPtr) {
| | | 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 |
{
Tcl_HashEntry *hPtr;
ZipFile *zf;
if (interp) {
hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint);
if (hPtr) {
zf = (ZipFile *)Tcl_GetHashValue(hPtr);
Tcl_SetObjResult(interp, Tcl_NewStringObj(zf->name, -1));
return TCL_OK;
}
}
return (interp ? TCL_OK : TCL_BREAK);
}
|
| ︙ | ︙ | |||
1661 1662 1663 1664 1665 1666 1667 |
Tcl_SetObjResult(interp,
Tcl_NewStringObj("illegal password", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL);
}
return TCL_ERROR;
}
}
| | | | | | 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 |
Tcl_SetObjResult(interp,
Tcl_NewStringObj("illegal password", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL);
}
return TCL_ERROR;
}
}
zf = (ZipFile *)attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1);
if (!zf) {
if (interp) {
Tcl_AppendResult(interp, "out of memory", (char *) NULL);
Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
}
return TCL_ERROR;
}
if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) {
ckfree(zf);
return TCL_ERROR;
}
if (ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname)
!= TCL_OK) {
ckfree(zf);
return TCL_ERROR;
}
ckfree(zf);
return TCL_OK;
}
/*
*-------------------------------------------------------------------------
*
* TclZipfs_MountBuffer --
|
| ︙ | ︙ | |||
1742 1743 1744 1745 1746 1747 1748 |
}
Unlock();
/*
* Have both a mount point and data to mount there.
*/
| | | | | 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 |
}
Unlock();
/*
* Have both a mount point and data to mount there.
*/
zf = (ZipFile *)attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1);
if (!zf) {
if (interp) {
Tcl_AppendResult(interp, "out of memory", (char *) NULL);
Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
}
return TCL_ERROR;
}
zf->isMemBuffer = 1;
zf->length = datalen;
if (copy) {
zf->data = (unsigned char *)attemptckalloc(datalen);
if (!zf->data) {
if (interp) {
Tcl_AppendResult(interp, "out of memory", (char *) NULL);
Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
}
return TCL_ERROR;
}
memcpy(zf->data, data, datalen);
zf->ptrToFree = zf->data;
} else {
zf->data = data;
zf->ptrToFree = NULL;
}
zf->passBuf[0] = 0; /* stop valgrind cries */
if (ZipFSFindTOC(interp, 0, zf) != TCL_OK) {
return TCL_ERROR;
}
result = ZipFSCatalogFilesystem(interp, zf, mountPoint, NULL,
"Memory Buffer");
ckfree(zf);
return result;
}
/*
*-------------------------------------------------------------------------
*
* TclZipfs_Unmount --
|
| ︙ | ︙ | |||
1823 1824 1825 1826 1827 1828 1829 |
hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint);
/* don't report no-such-mount as an error */
if (!hPtr) {
goto done;
}
| | | | | | | 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 |
hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint);
/* don't report no-such-mount as an error */
if (!hPtr) {
goto done;
}
zf = (ZipFile *)Tcl_GetHashValue(hPtr);
if (zf->numOpen > 0) {
ZIPFS_ERROR(interp, "filesystem is busy");
ret = TCL_ERROR;
goto done;
}
Tcl_DeleteHashEntry(hPtr);
for (z = zf->entries; z; z = znext) {
znext = z->next;
hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name);
if (hPtr) {
Tcl_DeleteHashEntry(hPtr);
}
if (z->data) {
ckfree(z->data);
}
ckfree(z);
}
ZipFSCloseArchive(interp, zf);
Tcl_DeleteExitHandler(ZipfsExitHandler, zf);
ckfree(zf);
unmounted = 1;
done:
Unlock();
if (unmounted) {
Tcl_FSMountsChanged(NULL);
}
return ret;
|
| ︙ | ︙ | |||
1871 1872 1873 1874 1875 1876 1877 | * A ZIP archive file is mounted, resources are allocated. * *------------------------------------------------------------------------- */ static int ZipFSMountObjCmd( | | > | | | | | | | > > > | 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 |
* A ZIP archive file is mounted, resources are allocated.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSMountObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
"?mountpoint? ?zipfile? ?password?");
return TCL_ERROR;
}
return TclZipfs_Mount(interp, (objc > 1) ? Tcl_GetString(objv[1]) : NULL,
(objc > 2) ? Tcl_GetString(objv[2]) : NULL,
(objc > 3) ? Tcl_GetString(objv[3]) : NULL);
}
/*
*-------------------------------------------------------------------------
*
* ZipFSMountBufferObjCmd --
*
* This procedure is invoked to process the [zipfs mount_data] command.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* A ZIP archive file is mounted, resources are allocated.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSMountBufferObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
const char *mountPoint; /* Mount point path. */
unsigned char *data;
int length;
if (objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? ?data?");
return TCL_ERROR;
}
if (objc < 2) {
int ret;
ReadLock();
ret = ListMountPoints(interp);
Unlock();
return ret;
}
mountPoint = Tcl_GetString(objv[1]);
if (objc < 3) {
ReadLock();
DescribeMounted(interp, mountPoint);
Unlock();
return TCL_OK;
}
data = TclGetBytesFromObj(interp, objv[2], &length);
if (data == NULL) {
return TCL_ERROR;
}
return TclZipfs_MountBuffer(interp, mountPoint, data, length, 1);
}
/*
*-------------------------------------------------------------------------
*
* ZipFSRootObjCmd --
|
| ︙ | ︙ | |||
1957 1958 1959 1960 1961 1962 1963 | * Side effects: * *------------------------------------------------------------------------- */ static int ZipFSRootObjCmd( | | | | | 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 |
* Side effects:
*
*-------------------------------------------------------------------------
*/
static int
ZipFSRootObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *)) /*objv*/
{
Tcl_SetObjResult(interp, Tcl_NewStringObj(ZIPFS_VOLUME, -1));
return TCL_OK;
}
/*
*-------------------------------------------------------------------------
|
| ︙ | ︙ | |||
1984 1985 1986 1987 1988 1989 1990 | * A mounted ZIP archive file is unmounted, resources are free'd. * *------------------------------------------------------------------------- */ static int ZipFSUnmountObjCmd( | | > | | 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 |
* A mounted ZIP archive file is unmounted, resources are free'd.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSUnmountObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "zipfile");
return TCL_ERROR;
}
return TclZipfs_Unmount(interp, Tcl_GetString(objv[1]));
}
/*
*-------------------------------------------------------------------------
*
* ZipFSMkKeyObjCmd --
*
|
| ︙ | ︙ | |||
2015 2016 2017 2018 2019 2020 2021 | * None. * *------------------------------------------------------------------------- */ static int ZipFSMkKeyObjCmd( | | | | 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSMkKeyObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int len, i = 0;
char *pw, passBuf[264];
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "password");
return TCL_ERROR;
}
pw = Tcl_GetString(objv[1]);
len = strlen(pw);
if (len == 0) {
return TCL_OK;
}
if ((len > 255) || strchr(pw, 0xff)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("illegal password", -1));
return TCL_ERROR;
|
| ︙ | ︙ | |||
2144 2145 2146 2147 2148 2149 2150 |
Tcl_DecrRefCount(pathObj);
}
Tcl_ResetResult(interp);
crc = 0;
nbyte = nbytecompr = 0;
while (1) {
len = Tcl_Read(in, buf, bufsize);
| | | 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 |
Tcl_DecrRefCount(pathObj);
}
Tcl_ResetResult(interp);
crc = 0;
nbyte = nbytecompr = 0;
while (1) {
len = Tcl_Read(in, buf, bufsize);
if (len == ERROR_LENGTH) {
if (nbyte == 0 && errno == EISDIR) {
Tcl_Close(interp, in);
return TCL_OK;
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf("read error on \"%s\": %s",
path, Tcl_PosixError(interp)));
Tcl_Close(interp, in);
|
| ︙ | ︙ | |||
2170 2171 2172 2173 2174 2175 2176 |
Tcl_Close(interp, in);
return TCL_ERROR;
}
pos[0] = Tcl_Tell(out);
memset(buf, '\0', ZIP_LOCAL_HEADER_LEN);
memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpath, zpathlen);
len = zpathlen + ZIP_LOCAL_HEADER_LEN;
| | | | 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 |
Tcl_Close(interp, in);
return TCL_ERROR;
}
pos[0] = Tcl_Tell(out);
memset(buf, '\0', ZIP_LOCAL_HEADER_LEN);
memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpath, zpathlen);
len = zpathlen + ZIP_LOCAL_HEADER_LEN;
if ((size_t) Tcl_Write(out, buf, len) != len) {
wrerr:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"write error on %s: %s", path, Tcl_PosixError(interp)));
Tcl_Close(interp, in);
return TCL_ERROR;
}
if ((len + pos[0]) & 3) {
unsigned char abuf[8];
/*
* Align payload to next 4-byte boundary using a dummy extra entry
* similar to the zipalign tool from Android's SDK.
*/
align = 4 + ((len + pos[0]) & 3);
ZipWriteShort(abuf, 0xffff);
ZipWriteShort(abuf + 2, align - 4);
ZipWriteInt(abuf + 4, 0x03020100);
if ((size_t) Tcl_Write(out, (const char *) abuf, align) != align) {
goto wrerr;
}
}
if (passwd) {
int i, ch, tmp;
unsigned char kvbuf[24];
Tcl_Obj *ret;
|
| ︙ | ︙ | |||
2222 2223 2224 2225 2226 2227 2228 | i); Tcl_AppendObjToErrorInfo(interp, eiPtr); Tcl_Close(interp, in); return TCL_ERROR; } ch = (int) (r * 256); | | < | | | | 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 |
i);
Tcl_AppendObjToErrorInfo(interp, eiPtr);
Tcl_Close(interp, in);
return TCL_ERROR;
}
ch = (int) (r * 256);
kvbuf[i + 12] = UCHAR(zencode(keys, crc32tab, ch, tmp));
}
Tcl_ResetResult(interp);
init_keys(passwd, keys, crc32tab);
for (i = 0; i < 12 - 2; i++) {
kvbuf[i] = UCHAR(zencode(keys, crc32tab, kvbuf[i + 12], tmp));
}
kvbuf[i++] = UCHAR(zencode(keys, crc32tab, crc >> 16, tmp));
kvbuf[i++] = UCHAR(zencode(keys, crc32tab, crc >> 24, tmp));
len = Tcl_Write(out, (char *) kvbuf, 12);
memset(kvbuf, 0, 24);
if (len != 12) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"write error on %s: %s", path, Tcl_PosixError(interp)));
Tcl_Close(interp, in);
return TCL_ERROR;
|
| ︙ | ︙ | |||
2260 2261 2262 2263 2264 2265 2266 |
"compression init error on \"%s\"", path));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DEFLATE_INIT", NULL);
Tcl_Close(interp, in);
return TCL_ERROR;
}
do {
len = Tcl_Read(in, buf, bufsize);
| | | 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 |
"compression init error on \"%s\"", path));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DEFLATE_INIT", NULL);
Tcl_Close(interp, in);
return TCL_ERROR;
}
do {
len = Tcl_Read(in, buf, bufsize);
if (len == ERROR_LENGTH) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"read error on %s: %s", path, Tcl_PosixError(interp)));
deflateEnd(&stream);
Tcl_Close(interp, in);
return TCL_ERROR;
}
stream.avail_in = len;
|
| ︙ | ︙ | |||
2291 2292 2293 2294 2295 2296 2297 |
size_t i;
int tmp;
for (i = 0; i < olen; i++) {
obuf[i] = (char) zencode(keys, crc32tab, obuf[i], tmp);
}
}
| | | 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 |
size_t i;
int tmp;
for (i = 0; i < olen; i++) {
obuf[i] = (char) zencode(keys, crc32tab, obuf[i], tmp);
}
}
if (olen && ((size_t) Tcl_Write(out, obuf, olen) != olen)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"write error: %s", Tcl_PosixError(interp)));
deflateEnd(&stream);
Tcl_Close(interp, in);
return TCL_ERROR;
}
nbytecompr += olen;
|
| ︙ | ︙ | |||
2321 2322 2323 2324 2325 2326 2327 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"seek error: %s", Tcl_PosixError(interp)));
return TCL_ERROR;
}
nbytecompr = (passwd ? 12 : 0);
while (1) {
len = Tcl_Read(in, buf, bufsize);
| | | | 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 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"seek error: %s", Tcl_PosixError(interp)));
return TCL_ERROR;
}
nbytecompr = (passwd ? 12 : 0);
while (1) {
len = Tcl_Read(in, buf, bufsize);
if (len == ERROR_LENGTH) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"read error on \"%s\": %s",
path, Tcl_PosixError(interp)));
Tcl_Close(interp, in);
return TCL_ERROR;
} else if (len == 0) {
break;
}
if (passwd) {
size_t i;
int tmp;
for (i = 0; i < len; i++) {
buf[i] = (char) zencode(keys0, crc32tab, buf[i], tmp);
}
}
if ((size_t) Tcl_Write(out, buf, len) != len) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"write error: %s", Tcl_PosixError(interp)));
Tcl_Close(interp, in);
return TCL_ERROR;
}
nbytecompr += len;
}
|
| ︙ | ︙ | |||
2361 2362 2363 2364 2365 2366 2367 |
if (!isNew) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"non-unique path name \"%s\"", path));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DUPLICATE_PATH", NULL);
return TCL_ERROR;
}
| | | | | | | 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 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 |
if (!isNew) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"non-unique path name \"%s\"", path));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DUPLICATE_PATH", NULL);
return TCL_ERROR;
}
z = (ZipEntry *)ckalloc(sizeof(ZipEntry));
Tcl_SetHashValue(hPtr, z);
z->name = NULL;
z->tnext = NULL;
z->depth = 0;
z->zipFilePtr = NULL;
z->isDirectory = 0;
z->isEncrypted = (passwd ? 1 : 0);
z->offset = pos[0];
z->crc32 = crc;
z->timestamp = mtime;
z->numBytes = nbyte;
z->numCompressedBytes = nbytecompr;
z->compressMethod = compMeth;
z->data = NULL;
z->name = (char *)Tcl_GetHashKey(fileHash, hPtr);
z->next = NULL;
/*
* Write final local header information.
*/
ZipWriteInt(buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG);
ZipWriteShort(buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION);
ZipWriteShort(buf + ZIP_LOCAL_FLAGS_OFFS, z->isEncrypted);
ZipWriteShort(buf + ZIP_LOCAL_COMPMETH_OFFS, z->compressMethod);
ZipWriteShort(buf + ZIP_LOCAL_MTIME_OFFS, ToDosTime(z->timestamp));
ZipWriteShort(buf + ZIP_LOCAL_MDATE_OFFS, ToDosDate(z->timestamp));
ZipWriteInt(buf + ZIP_LOCAL_CRC32_OFFS, z->crc32);
ZipWriteInt(buf + ZIP_LOCAL_COMPLEN_OFFS, z->numCompressedBytes);
ZipWriteInt(buf + ZIP_LOCAL_UNCOMPLEN_OFFS, z->numBytes);
ZipWriteShort(buf + ZIP_LOCAL_PATHLEN_OFFS, zpathlen);
ZipWriteShort(buf + ZIP_LOCAL_EXTRALEN_OFFS, align);
if (Tcl_Seek(out, pos[0], SEEK_SET) != pos[0]) {
Tcl_DeleteHashEntry(hPtr);
ckfree(z);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"seek error: %s", Tcl_PosixError(interp)));
return TCL_ERROR;
}
if (Tcl_Write(out, buf, ZIP_LOCAL_HEADER_LEN) != ZIP_LOCAL_HEADER_LEN) {
Tcl_DeleteHashEntry(hPtr);
ckfree(z);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"write error: %s", Tcl_PosixError(interp)));
return TCL_ERROR;
}
Tcl_Flush(out);
if (Tcl_Seek(out, pos[1], SEEK_SET) != pos[1]) {
Tcl_DeleteHashEntry(hPtr);
ckfree(z);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"seek error: %s", Tcl_PosixError(interp)));
return TCL_ERROR;
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
2462 2463 2464 2465 2466 2467 2468 |
/*
* Caller has verified that the number of arguments is correct.
*/
passBuf[0] = 0;
if (objc > (isList ? 3 : 4)) {
| | | 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 |
/*
* Caller has verified that the number of arguments is correct.
*/
passBuf[0] = 0;
if (objc > (isList ? 3 : 4)) {
pw = Tcl_GetString(objv[isList ? 3 : 4]);
pwlen = strlen(pw);
if ((pwlen > 255) || strchr(pw, 0xff)) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("illegal password", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
2506 2507 2508 2509 2510 2511 2512 |
}
if (lobjc == 0) {
Tcl_DecrRefCount(list);
Tcl_SetObjResult(interp, Tcl_NewStringObj("empty archive", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "EMPTY", NULL);
return TCL_ERROR;
}
| | | | | 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 |
}
if (lobjc == 0) {
Tcl_DecrRefCount(list);
Tcl_SetObjResult(interp, Tcl_NewStringObj("empty archive", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "EMPTY", NULL);
return TCL_ERROR;
}
out = Tcl_OpenFileChannel(interp, Tcl_GetString(objv[1]), "wb", 0755);
if (out == NULL) {
Tcl_DecrRefCount(list);
return TCL_ERROR;
}
if (pwlen <= 0) {
pw = NULL;
pwlen = 0;
}
if (isImg) {
ZipFile *zf, zf0;
int isMounted = 0;
const char *imgName;
if (isList) {
imgName = (objc > 4) ? Tcl_GetString(objv[4]) :
Tcl_GetNameOfExecutable();
} else {
imgName = (objc > 5) ? Tcl_GetString(objv[5]) :
Tcl_GetNameOfExecutable();
}
if (pwlen) {
i = 0;
for (len = pwlen; len-- > 0;) {
int ch = pw[len];
|
| ︙ | ︙ | |||
2551 2552 2553 2554 2555 2556 2557 |
/*
* Check for mounted image.
*/
WriteLock();
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
| | | | 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 |
/*
* Check for mounted image.
*/
WriteLock();
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
zf = (ZipFile *)Tcl_GetHashValue(hPtr);
if (strcmp(zf->name, imgName) == 0) {
isMounted = 1;
zf->numOpen++;
break;
}
}
Unlock();
if (!isMounted) {
zf = &zf0;
}
if (isMounted || ZipFSOpenArchive(interp, imgName, 0, zf) == TCL_OK) {
if ((size_t) Tcl_Write(out, (char *) zf->data,
zf->passOffset) != zf->passOffset) {
memset(passBuf, 0, sizeof(passBuf));
Tcl_DecrRefCount(list);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"write error: %s", Tcl_PosixError(interp)));
Tcl_Close(interp, out);
if (zf == &zf0) {
|
| ︙ | ︙ | |||
2606 2607 2608 2609 2610 2611 2612 |
if (!in) {
memset(passBuf, 0, sizeof(passBuf));
Tcl_DecrRefCount(list);
Tcl_Close(interp, out);
return TCL_ERROR;
}
i = Tcl_Seek(in, 0, SEEK_END);
| | | 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 |
if (!in) {
memset(passBuf, 0, sizeof(passBuf));
Tcl_DecrRefCount(list);
Tcl_Close(interp, out);
return TCL_ERROR;
}
i = Tcl_Seek(in, 0, SEEK_END);
if (i == ERROR_LENGTH) {
cperr:
memset(passBuf, 0, sizeof(passBuf));
Tcl_DecrRefCount(list);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"%s: %s", errMsg, Tcl_PosixError(interp)));
Tcl_Close(interp, out);
Tcl_Close(interp, in);
|
| ︙ | ︙ | |||
2654 2655 2656 2657 2658 2659 2660 |
}
memset(passBuf, 0, sizeof(passBuf));
Tcl_Flush(out);
}
Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS);
pos[0] = Tcl_Tell(out);
if (!isList && (objc > 3)) {
| | | | | 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 |
}
memset(passBuf, 0, sizeof(passBuf));
Tcl_Flush(out);
}
Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS);
pos[0] = Tcl_Tell(out);
if (!isList && (objc > 3)) {
strip = Tcl_GetString(objv[3]);
slen = strlen(strip);
}
for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) {
const char *path, *name;
path = Tcl_GetString(lobjv[i]);
if (isList) {
name = Tcl_GetString(lobjv[i + 1]);
} else {
name = path;
if (slen > 0) {
len = strlen(name);
if ((len <= slen) || (strncmp(strip, name, slen) != 0)) {
continue;
}
|
| ︙ | ︙ | |||
2689 2690 2691 2692 2693 2694 2695 |
}
}
pos[1] = Tcl_Tell(out);
count = 0;
for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) {
const char *path, *name;
| | | | | | 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 |
}
}
pos[1] = Tcl_Tell(out);
count = 0;
for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) {
const char *path, *name;
path = Tcl_GetString(lobjv[i]);
if (isList) {
name = Tcl_GetString(lobjv[i + 1]);
} else {
name = path;
if (slen > 0) {
len = strlen(name);
if ((len <= slen) || (strncmp(strip, name, slen) != 0)) {
continue;
}
name += slen;
}
}
while (name[0] == '/') {
++name;
}
if (name[0] == '\0') {
continue;
}
hPtr = Tcl_FindHashEntry(&fileHash, name);
if (!hPtr) {
continue;
}
z = (ZipEntry *)Tcl_GetHashValue(hPtr);
len = strlen(z->name);
ZipWriteInt(buf + ZIP_CENTRAL_SIG_OFFS, ZIP_CENTRAL_HEADER_SIG);
ZipWriteShort(buf + ZIP_CENTRAL_VERSIONMADE_OFFS, ZIP_MIN_VERSION);
ZipWriteShort(buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION);
ZipWriteShort(buf + ZIP_CENTRAL_FLAGS_OFFS, z->isEncrypted);
ZipWriteShort(buf + ZIP_CENTRAL_COMPMETH_OFFS, z->compressMethod);
ZipWriteShort(buf + ZIP_CENTRAL_MTIME_OFFS, ToDosTime(z->timestamp));
ZipWriteShort(buf + ZIP_CENTRAL_MDATE_OFFS, ToDosDate(z->timestamp));
ZipWriteInt(buf + ZIP_CENTRAL_CRC32_OFFS, z->crc32);
ZipWriteInt(buf + ZIP_CENTRAL_COMPLEN_OFFS, z->numCompressedBytes);
ZipWriteInt(buf + ZIP_CENTRAL_UNCOMPLEN_OFFS, z->numBytes);
ZipWriteShort(buf + ZIP_CENTRAL_PATHLEN_OFFS, len);
ZipWriteShort(buf + ZIP_CENTRAL_EXTRALEN_OFFS, 0);
ZipWriteShort(buf + ZIP_CENTRAL_FCOMMENTLEN_OFFS, 0);
ZipWriteShort(buf + ZIP_CENTRAL_DISKFILE_OFFS, 0);
ZipWriteShort(buf + ZIP_CENTRAL_IATTR_OFFS, 0);
ZipWriteInt(buf + ZIP_CENTRAL_EATTR_OFFS, 0);
ZipWriteInt(buf + ZIP_CENTRAL_LOCALHDR_OFFS, z->offset - pos[0]);
if ((Tcl_Write(out, buf,
ZIP_CENTRAL_HEADER_LEN) != ZIP_CENTRAL_HEADER_LEN)
|| ((size_t) Tcl_Write(out, z->name, len) != len)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"write error: %s", Tcl_PosixError(interp)));
goto done;
}
count++;
}
Tcl_Flush(out);
|
| ︙ | ︙ | |||
2767 2768 2769 2770 2771 2772 2773 |
ret = Tcl_Close(interp, out);
} else {
Tcl_Close(interp, out);
}
Tcl_DecrRefCount(list);
for (hPtr = Tcl_FirstHashEntry(&fileHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
| | | | 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 |
ret = Tcl_Close(interp, out);
} else {
Tcl_Close(interp, out);
}
Tcl_DecrRefCount(list);
for (hPtr = Tcl_FirstHashEntry(&fileHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
z = (ZipEntry *)Tcl_GetHashValue(hPtr);
ckfree(z);
Tcl_DeleteHashEntry(hPtr);
}
Tcl_DeleteHashTable(&fileHash);
return ret;
}
/*
|
| ︙ | ︙ | |||
2794 2795 2796 2797 2798 2799 2800 | * See description of ZipFSMkZipOrImgCmd(). * *------------------------------------------------------------------------- */ static int ZipFSMkZipObjCmd( | | | | 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 |
* See description of ZipFSMkZipOrImgCmd().
*
*-------------------------------------------------------------------------
*/
static int
ZipFSMkZipObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc < 3 || objc > 5) {
Tcl_WrongNumArgs(interp, 1, objv, "outfile indir ?strip? ?password?");
return TCL_ERROR;
}
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"operation not permitted in a safe interpreter", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL);
return TCL_ERROR;
}
return ZipFSMkZipOrImgObjCmd(interp, 0, 0, objc, objv);
}
static int
ZipFSLMkZipObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
2851 2852 2853 2854 2855 2856 2857 | * See description of ZipFSMkZipOrImgCmd(). * *------------------------------------------------------------------------- */ static int ZipFSMkImgObjCmd( | | | | 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 |
* See description of ZipFSMkZipOrImgCmd().
*
*-------------------------------------------------------------------------
*/
static int
ZipFSMkImgObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc < 3 || objc > 6) {
Tcl_WrongNumArgs(interp, 1, objv,
"outfile indir ?strip? ?password? ?infile?");
return TCL_ERROR;
}
if (Tcl_IsSafe(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"operation not permitted in a safe interpreter", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL);
return TCL_ERROR;
}
return ZipFSMkZipOrImgObjCmd(interp, 1, 0, objc, objv);
}
static int
ZipFSLMkImgObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
if (objc < 3 || objc > 5) {
Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password infile?");
return TCL_ERROR;
|
| ︙ | ︙ | |||
2909 2910 2911 2912 2913 2914 2915 | * None. * *------------------------------------------------------------------------- */ static int ZipFSCanonicalObjCmd( | | | | | | | | 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 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSCanonicalObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
char *mntpoint = NULL;
char *filename = NULL;
char *result;
Tcl_DString dPath;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? filename ?inZipfs?");
return TCL_ERROR;
}
Tcl_DStringInit(&dPath);
if (objc == 2) {
filename = Tcl_GetString(objv[1]);
result = CanonicalPath("", filename, &dPath, 1);
} else if (objc == 3) {
mntpoint = Tcl_GetString(objv[1]);
filename = Tcl_GetString(objv[2]);
result = CanonicalPath(mntpoint, filename, &dPath, 1);
} else {
int zipfs = 0;
if (Tcl_GetBooleanFromObj(interp, objv[3], &zipfs)) {
return TCL_ERROR;
}
mntpoint = Tcl_GetString(objv[1]);
filename = Tcl_GetString(objv[2]);
result = CanonicalPath(mntpoint, filename, &dPath, zipfs);
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1));
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
2965 2966 2967 2968 2969 2970 2971 | * None. * *------------------------------------------------------------------------- */ static int ZipFSExistsObjCmd( | | | | 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 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSExistsObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
char *filename;
int exists;
Tcl_DString ds;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "filename");
return TCL_ERROR;
}
/*
* Prepend ZIPFS_VOLUME to filename, eliding the final /
*/
filename = Tcl_GetString(objv[1]);
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN - 1);
Tcl_DStringAppend(&ds, filename, -1);
filename = Tcl_DStringValue(&ds);
ReadLock();
exists = ZipFSLookup(filename) != NULL;
|
| ︙ | ︙ | |||
3018 3019 3020 3021 3022 3023 3024 | * None. * *------------------------------------------------------------------------- */ static int ZipFSInfoObjCmd( | | | | 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 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSInfoObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
char *filename;
ZipEntry *z;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "filename");
return TCL_ERROR;
}
filename = Tcl_GetString(objv[1]);
ReadLock();
z = ZipFSLookup(filename);
if (z) {
Tcl_Obj *result = Tcl_GetObjResult(interp);
Tcl_ListObjAppendElement(interp, result,
Tcl_NewStringObj(z->zipFilePtr->name, -1));
|
| ︙ | ︙ | |||
3068 3069 3070 3071 3072 3073 3074 | * None. * *------------------------------------------------------------------------- */ static int ZipFSListObjCmd( | | | | | | | | | | | 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 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSListObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
char *pattern = NULL;
Tcl_RegExp regexp = NULL;
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Tcl_Obj *result = Tcl_GetObjResult(interp);
if (objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?(-glob|-regexp)? ?pattern?");
return TCL_ERROR;
}
if (objc == 3) {
int n;
char *what = Tcl_GetStringFromObj(objv[1], &n);
if ((n >= 2) && (strncmp(what, "-glob", n) == 0)) {
pattern = Tcl_GetString(objv[2]);
} else if ((n >= 2) && (strncmp(what, "-regexp", n) == 0)) {
regexp = Tcl_RegExpCompile(interp, Tcl_GetString(objv[2]));
if (!regexp) {
return TCL_ERROR;
}
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unknown option \"%s\"", what));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_OPT", NULL);
return TCL_ERROR;
}
} else if (objc == 2) {
pattern = Tcl_GetString(objv[1]);
}
ReadLock();
if (pattern) {
for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
ZipEntry *z = (ZipEntry *)Tcl_GetHashValue(hPtr);
if (Tcl_StringMatch(z->name, pattern)) {
Tcl_ListObjAppendElement(interp, result,
Tcl_NewStringObj(z->name, -1));
}
}
} else if (regexp) {
for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
hPtr; hPtr = Tcl_NextHashEntry(&search)) {
ZipEntry *z = (ZipEntry *)Tcl_GetHashValue(hPtr);
if (Tcl_RegExpExec(interp, regexp, z->name, z->name)) {
Tcl_ListObjAppendElement(interp, result,
Tcl_NewStringObj(z->name, -1));
}
}
} else {
for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
hPtr; hPtr = Tcl_NextHashEntry(&search)) {
ZipEntry *z = (ZipEntry *)Tcl_GetHashValue(hPtr);
Tcl_ListObjAppendElement(interp, result,
Tcl_NewStringObj(z->name, -1));
}
}
Unlock();
return TCL_OK;
|
| ︙ | ︙ | |||
3168 3169 3170 3171 3172 3173 3174 |
TclZipfs_TclLibrary(void)
{
Tcl_Obj *vfsInitScript;
int found;
#ifdef _WIN32
HMODULE hModule;
WCHAR wName[MAX_PATH + LIBRARY_SIZE];
| | | 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 |
TclZipfs_TclLibrary(void)
{
Tcl_Obj *vfsInitScript;
int found;
#ifdef _WIN32
HMODULE hModule;
WCHAR wName[MAX_PATH + LIBRARY_SIZE];
char dllName[(MAX_PATH + LIBRARY_SIZE) * 3];
#endif /* _WIN32 */
/*
* Use the cached value if that has been set; we don't want to repeat the
* searching and mounting.
*/
|
| ︙ | ︙ | |||
3265 3266 3267 3268 3269 3270 3271 | * This cache is never cleared. * *------------------------------------------------------------------------- */ static int ZipFSTclLibraryObjCmd( | | | | | 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 |
* This cache is never cleared.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSTclLibraryObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *)) /*objv*/
{
if (!Tcl_IsSafe(interp)) {
Tcl_Obj *pResult = TclZipfs_TclLibrary();
if (!pResult) {
pResult = Tcl_NewObj();
}
|
| ︙ | ︙ | |||
3300 3301 3302 3303 3304 3305 3306 |
*
*-------------------------------------------------------------------------
*/
static int
ZipChannelClose(
void *instanceData,
| | > | > > > > | | | | | | 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 |
*
*-------------------------------------------------------------------------
*/
static int
ZipChannelClose(
void *instanceData,
TCL_UNUSED(Tcl_Interp *),
int flags)
{
ZipChannel *info = (ZipChannel *)instanceData;
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
if (info->iscompr && info->ubuf) {
ckfree(info->ubuf);
info->ubuf = NULL;
}
if (info->isEncrypted) {
info->isEncrypted = 0;
memset(info->keys, 0, sizeof(info->keys));
}
if (info->isWriting) {
ZipEntry *z = info->zipEntryPtr;
unsigned char *newdata = (unsigned char *)attemptckrealloc(info->ubuf, info->numRead);
if (newdata) {
if (z->data) {
ckfree(z->data);
}
z->data = newdata;
z->numBytes = z->numCompressedBytes = info->numBytes;
z->compressMethod = ZIP_COMPMETH_STORED;
z->timestamp = time(NULL);
z->isDirectory = 0;
z->isEncrypted = 0;
z->offset = 0;
z->crc32 = 0;
} else {
ckfree(info->ubuf);
}
}
WriteLock();
info->zipFilePtr->numOpen--;
Unlock();
ckfree(info);
return TCL_OK;
}
/*
*-------------------------------------------------------------------------
*
* ZipChannelRead --
|
| ︙ | ︙ | |||
3462 3463 3464 3465 3466 3467 3468 |
*errloc = 0;
return toWrite;
}
/*
*-------------------------------------------------------------------------
*
| | | | | | | 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 |
*errloc = 0;
return toWrite;
}
/*
*-------------------------------------------------------------------------
*
* ZipChannelSeek/ZipChannelWideSeek --
*
* This function is called to position file pointer of channel.
*
* Results:
* New file position or -1 on error with error number set.
*
* Side effects:
* File pointer is repositioned according to offset and mode.
*
*-------------------------------------------------------------------------
*/
static Tcl_WideInt
ZipChannelWideSeek(
void *instanceData,
Tcl_WideInt offset,
int mode,
int *errloc)
{
ZipChannel *info = (ZipChannel *) instanceData;
size_t end;
if (!info->isWriting && (info->isDirectory < 0)) {
/*
* Special case: when executable combined with ZIP archive file, seek
* within front of ZIP, i.e. the executable itself.
*/
end = info->zipFilePtr->baseOffset;
|
| ︙ | ︙ | |||
3515 3516 3517 3518 3519 3520 3521 |
return -1;
}
if (offset < 0) {
*errloc = EINVAL;
return -1;
}
if (info->isWriting) {
| | | | | > > > > > > > > > > > > | | | 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 |
return -1;
}
if (offset < 0) {
*errloc = EINVAL;
return -1;
}
if (info->isWriting) {
if ((size_t) offset > info->maxWrite) {
*errloc = EINVAL;
return -1;
}
if ((size_t) offset > info->numBytes) {
info->numBytes = offset;
}
} else if ((size_t) offset > end) {
*errloc = EINVAL;
return -1;
}
info->numRead = (size_t) offset;
return info->numRead;
}
#ifndef TCL_NO_DEPRECATED
static int
ZipChannelSeek(
void *instanceData,
long offset,
int mode,
int *errloc)
{
return ZipChannelWideSeek(instanceData, offset, mode, errloc);
}
#endif
/*
*-------------------------------------------------------------------------
*
* ZipChannelWatchChannel --
*
* This function is called for event notifications on channel. Does
* nothing.
*
* Results:
* None.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------------
*/
static void
ZipChannelWatchChannel(
TCL_UNUSED(ClientData),
TCL_UNUSED(int) /*mask*/)
{
return;
}
/*
*-------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3574 3575 3576 3577 3578 3579 3580 | * None. * *------------------------------------------------------------------------- */ static int ZipChannelGetFile( | | | | | 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
ZipChannelGetFile(
TCL_UNUSED(ClientData),
TCL_UNUSED(int) /*direction*/,
TCL_UNUSED(ClientData *) /*handlePtr*/)
{
return TCL_ERROR;
}
/*
*-------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3603 3604 3605 3606 3607 3608 3609 |
*/
static Tcl_Channel
ZipChannelOpen(
Tcl_Interp *interp, /* Current interpreter. */
char *filename,
int mode,
| | | 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 |
*/
static Tcl_Channel
ZipChannelOpen(
Tcl_Interp *interp, /* Current interpreter. */
char *filename,
int mode,
TCL_UNUSED(int) /*permissions*/)
{
ZipEntry *z;
ZipChannel *info;
int i, ch, trunc, wr, flags = 0;
char cname[128];
if ((mode & O_APPEND)
|
| ︙ | ︙ | |||
3665 3666 3667 3668 3669 3670 3671 |
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_SIZE", NULL);
}
goto error;
}
} else {
flags = TCL_WRITABLE;
}
| | | | | | | 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 |
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_SIZE", NULL);
}
goto error;
}
} else {
flags = TCL_WRITABLE;
}
info = (ZipChannel *)attemptckalloc(sizeof(ZipChannel));
if (!info) {
ZIPFS_ERROR(interp, "out of memory");
if (interp) {
Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
}
goto error;
}
info->zipFilePtr = z->zipFilePtr;
info->zipEntryPtr = z;
info->numRead = 0;
if (wr) {
flags |= TCL_WRITABLE;
info->isWriting = 1;
info->isDirectory = 0;
info->maxWrite = ZipFS.wrmax;
info->iscompr = 0;
info->isEncrypted = 0;
info->ubuf = (unsigned char *)attemptckalloc(info->maxWrite);
if (!info->ubuf) {
merror0:
if (info->ubuf) {
ckfree(info->ubuf);
}
ckfree(info);
ZIPFS_ERROR(interp, "out of memory");
if (interp) {
Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
}
goto error;
}
memset(info->ubuf, 0, info->maxWrite);
if (trunc) {
info->numBytes = 0;
} else if (z->data) {
unsigned int j = z->numBytes;
if (j > info->maxWrite) {
j = info->maxWrite;
}
memcpy(info->ubuf, z->data, j);
info->numBytes = j;
} else {
|
| ︙ | ︙ | |||
3738 3739 3740 3741 3742 3743 3744 |
memset(&stream, 0, sizeof(z_stream));
stream.zalloc = Z_NULL;
stream.zfree = Z_NULL;
stream.opaque = Z_NULL;
stream.avail_in = z->numCompressedBytes;
if (z->isEncrypted) {
| | | | 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 |
memset(&stream, 0, sizeof(z_stream));
stream.zalloc = Z_NULL;
stream.zfree = Z_NULL;
stream.opaque = Z_NULL;
stream.avail_in = z->numCompressedBytes;
if (z->isEncrypted) {
unsigned int j;
stream.avail_in -= 12;
cbuf = (unsigned char *)attemptckalloc(stream.avail_in);
if (!cbuf) {
goto merror0;
}
for (j = 0; j < stream.avail_in; j++) {
ch = info->ubuf[j];
cbuf[j] = zdecode(info->keys, crc32tab, ch);
}
|
| ︙ | ︙ | |||
3764 3765 3766 3767 3768 3769 3770 |
}
err = inflate(&stream, Z_SYNC_FLUSH);
inflateEnd(&stream);
if ((err == Z_STREAM_END)
|| ((err == Z_OK) && (stream.avail_in == 0))) {
if (cbuf) {
memset(info->keys, 0, sizeof(info->keys));
| | | | | | 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 |
}
err = inflate(&stream, Z_SYNC_FLUSH);
inflateEnd(&stream);
if ((err == Z_STREAM_END)
|| ((err == Z_OK) && (stream.avail_in == 0))) {
if (cbuf) {
memset(info->keys, 0, sizeof(info->keys));
ckfree(cbuf);
}
goto wrapchan;
}
cerror0:
if (cbuf) {
memset(info->keys, 0, sizeof(info->keys));
ckfree(cbuf);
}
if (info->ubuf) {
ckfree(info->ubuf);
}
ckfree(info);
ZIPFS_ERROR(interp, "decompression error");
if (interp) {
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "CORRUPT", NULL);
}
goto error;
} else if (z->isEncrypted) {
for (i = 0; i < z->numBytes - 12; i++) {
|
| ︙ | ︙ | |||
3832 3833 3834 3835 3836 3837 3838 |
}
info->ubuf += i;
}
if (info->iscompr) {
z_stream stream;
int err;
unsigned char *ubuf = NULL;
| | | | | | | | | | | | | | 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 |
}
info->ubuf += i;
}
if (info->iscompr) {
z_stream stream;
int err;
unsigned char *ubuf = NULL;
unsigned int j;
memset(&stream, 0, sizeof(z_stream));
stream.zalloc = Z_NULL;
stream.zfree = Z_NULL;
stream.opaque = Z_NULL;
stream.avail_in = z->numCompressedBytes;
if (info->isEncrypted) {
stream.avail_in -= 12;
ubuf = (unsigned char *)attemptckalloc(stream.avail_in);
if (!ubuf) {
info->ubuf = NULL;
goto merror;
}
for (j = 0; j < stream.avail_in; j++) {
ch = info->ubuf[j];
ubuf[j] = zdecode(info->keys, crc32tab, ch);
}
stream.next_in = ubuf;
} else {
stream.next_in = info->ubuf;
}
stream.next_out = info->ubuf = (unsigned char *)attemptckalloc(info->numBytes);
if (!info->ubuf) {
merror:
if (ubuf) {
info->isEncrypted = 0;
memset(info->keys, 0, sizeof(info->keys));
ckfree(ubuf);
}
ckfree(info);
if (interp) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("out of memory", -1));
Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL);
}
goto error;
}
stream.avail_out = info->numBytes;
if (inflateInit2(&stream, -15) != Z_OK) {
goto cerror;
}
err = inflate(&stream, Z_SYNC_FLUSH);
inflateEnd(&stream);
if ((err == Z_STREAM_END)
|| ((err == Z_OK) && (stream.avail_in == 0))) {
if (ubuf) {
info->isEncrypted = 0;
memset(info->keys, 0, sizeof(info->keys));
ckfree(ubuf);
}
goto wrapchan;
}
cerror:
if (ubuf) {
info->isEncrypted = 0;
memset(info->keys, 0, sizeof(info->keys));
ckfree(ubuf);
}
if (info->ubuf) {
ckfree(info->ubuf);
}
ckfree(info);
ZIPFS_ERROR(interp, "decompression error");
if (interp) {
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "CORRUPT", NULL);
}
goto error;
} else if (info->isEncrypted) {
unsigned char *ubuf = NULL;
unsigned int j, len;
/*
* Decode encrypted but uncompressed file, since we support
* Tcl_Seek() on it, and it can be randomly accessed later.
*/
len = z->numCompressedBytes - 12;
ubuf = (unsigned char *) attemptckalloc(len);
if (ubuf == NULL) {
ckfree((char *) info);
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("out of memory", -1));
}
goto error;
}
for (j = 0; j < len; j++) {
|
| ︙ | ︙ | |||
4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 |
static Tcl_Channel
ZipFSOpenFileChannelProc(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *pathPtr,
int mode,
int permissions)
{
pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (!pathPtr) {
return NULL;
}
| > > | | 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 |
static Tcl_Channel
ZipFSOpenFileChannelProc(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *pathPtr,
int mode,
int permissions)
{
int len;
pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (!pathPtr) {
return NULL;
}
return ZipChannelOpen(interp, Tcl_GetStringFromObj(pathPtr, &len), mode,
permissions);
}
/*
*-------------------------------------------------------------------------
*
* ZipFSStatProc --
|
| ︙ | ︙ | |||
4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 |
*/
static int
ZipFSStatProc(
Tcl_Obj *pathPtr,
Tcl_StatBuf *buf)
{
pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (!pathPtr) {
return -1;
}
| > | | 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 |
*/
static int
ZipFSStatProc(
Tcl_Obj *pathPtr,
Tcl_StatBuf *buf)
{
int len;
pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (!pathPtr) {
return -1;
}
return ZipEntryStat(Tcl_GetStringFromObj(pathPtr, &len), buf);
}
/*
*-------------------------------------------------------------------------
*
* ZipFSAccessProc --
*
|
| ︙ | ︙ | |||
4096 4097 4098 4099 4100 4101 4102 4103 4104 4105 4106 |
*/
static int
ZipFSAccessProc(
Tcl_Obj *pathPtr,
int mode)
{
pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (!pathPtr) {
return -1;
}
| > > | | 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 |
*/
static int
ZipFSAccessProc(
Tcl_Obj *pathPtr,
int mode)
{
int len;
pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (!pathPtr) {
return -1;
}
return ZipEntryAccess(Tcl_GetStringFromObj(pathPtr, &len), mode);
}
/*
*-------------------------------------------------------------------------
*
* ZipFSFilesystemSeparatorProc --
*
|
| ︙ | ︙ | |||
4124 4125 4126 4127 4128 4129 4130 | * None. * *------------------------------------------------------------------------- */ static Tcl_Obj * ZipFSFilesystemSeparatorProc( | | | 4106 4107 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 |
* None.
*
*-------------------------------------------------------------------------
*/
static Tcl_Obj *
ZipFSFilesystemSeparatorProc(
TCL_UNUSED(Tcl_Obj *) /*pathPtr*/)
{
return Tcl_NewStringObj("/", -1);
}
/*
*-------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4150 4151 4152 4153 4154 4155 4156 | * None. * *------------------------------------------------------------------------- */ static int ZipFSMatchInDirectoryProc( | | | | | | > | 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 4155 4156 4157 4158 4159 4160 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 |
* None.
*
*-------------------------------------------------------------------------
*/
static int
ZipFSMatchInDirectoryProc(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *result,
Tcl_Obj *pathPtr,
const char *pattern,
Tcl_GlobTypeData *types)
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
int scnt, l, dirOnly = -1, prefixLen, strip = 0;
size_t len;
char *pat, *prefix, *path;
Tcl_DString dsPref;
if (!normPathPtr) {
return -1;
}
if (types) {
dirOnly = (types->type & TCL_GLOB_TYPE_DIR) == TCL_GLOB_TYPE_DIR;
}
/*
* The prefix that gets prepended to results.
*/
prefix = Tcl_GetStringFromObj(pathPtr, &prefixLen);
/*
* The (normalized) path we're searching.
*/
path = Tcl_GetString(normPathPtr);
len = normPathPtr->length;
Tcl_DStringInit(&dsPref);
Tcl_DStringAppend(&dsPref, prefix, prefixLen);
if (strcmp(prefix, path) == 0) {
prefix = NULL;
} else {
|
| ︙ | ︙ | |||
4209 4210 4211 4212 4213 4214 4215 |
l++;
}
if (!pattern || (pattern[0] == '\0')) {
pattern = "*";
}
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
| | | 4192 4193 4194 4195 4196 4197 4198 4199 4200 4201 4202 4203 4204 4205 4206 |
l++;
}
if (!pattern || (pattern[0] == '\0')) {
pattern = "*";
}
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
ZipFile *zf = (ZipFile *)Tcl_GetHashValue(hPtr);
if (zf->mountPointLen == 0) {
ZipEntry *z;
for (z = zf->topEnts; z; z = z->tnext) {
size_t lenz = strlen(z->name);
|
| ︙ | ︙ | |||
4260 4261 4262 4263 4264 4265 4266 |
}
goto end;
}
if (!pattern || (pattern[0] == '\0')) {
hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path);
if (hPtr) {
| | | | | | 4243 4244 4245 4246 4247 4248 4249 4250 4251 4252 4253 4254 4255 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 4279 4280 4281 4282 4283 4284 4285 4286 4287 4288 4289 4290 4291 4292 4293 4294 4295 4296 4297 4298 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 |
}
goto end;
}
if (!pattern || (pattern[0] == '\0')) {
hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path);
if (hPtr) {
ZipEntry *z = (ZipEntry *)Tcl_GetHashValue(hPtr);
if ((dirOnly < 0) || (!dirOnly && !z->isDirectory)
|| (dirOnly && z->isDirectory)) {
if (prefix) {
Tcl_DStringAppend(&dsPref, z->name, -1);
Tcl_ListObjAppendElement(NULL, result,
Tcl_NewStringObj(Tcl_DStringValue(&dsPref),
Tcl_DStringLength(&dsPref)));
Tcl_DStringSetLength(&dsPref, prefixLen);
} else {
Tcl_ListObjAppendElement(NULL, result,
Tcl_NewStringObj(z->name, -1));
}
}
}
goto end;
}
l = strlen(pattern);
pat = (char *)ckalloc(len + l + 2);
memcpy(pat, path, len);
while ((len > 1) && (pat[len - 1] == '/')) {
--len;
}
if ((len > 1) || (pat[0] != '/')) {
pat[len] = '/';
++len;
}
memcpy(pat + len, pattern, l + 1);
scnt = CountSlashes(pat);
for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search);
hPtr; hPtr = Tcl_NextHashEntry(&search)) {
ZipEntry *z = (ZipEntry *)Tcl_GetHashValue(hPtr);
if ((dirOnly >= 0) && ((dirOnly && !z->isDirectory)
|| (!dirOnly && z->isDirectory))) {
continue;
}
if ((z->depth == scnt) && Tcl_StringCaseMatch(z->name, pat, 0)) {
if (prefix) {
Tcl_DStringAppend(&dsPref, z->name + strip, -1);
Tcl_ListObjAppendElement(NULL, result,
Tcl_NewStringObj(Tcl_DStringValue(&dsPref),
Tcl_DStringLength(&dsPref)));
Tcl_DStringSetLength(&dsPref, prefixLen);
} else {
Tcl_ListObjAppendElement(NULL, result,
Tcl_NewStringObj(z->name + strip, -1));
}
}
}
ckfree(pat);
end:
Unlock();
Tcl_DStringFree(&dsPref);
return TCL_OK;
}
|
| ︙ | ︙ | |||
4340 4341 4342 4343 4344 4345 4346 |
*
*-------------------------------------------------------------------------
*/
static int
ZipFSPathInFilesystemProc(
Tcl_Obj *pathPtr,
| | | > > | | 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 4364 4365 4366 |
*
*-------------------------------------------------------------------------
*/
static int
ZipFSPathInFilesystemProc(
Tcl_Obj *pathPtr,
TCL_UNUSED(ClientData *))
{
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
int ret = -1;
size_t len;
char *path;
pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (!pathPtr) {
return -1;
}
path = Tcl_GetString(pathPtr);
if (strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) != 0) {
return -1;
}
len = pathPtr->length;
ReadLock();
hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path);
if (hPtr) {
ret = TCL_OK;
goto endloop;
}
for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr;
hPtr = Tcl_NextHashEntry(&search)) {
ZipFile *zf = (ZipFile *)Tcl_GetHashValue(hPtr);
if (zf->mountPointLen == 0) {
ZipEntry *z;
for (z = zf->topEnts; z != NULL; z = z->tnext) {
size_t lenz = strlen(z->name);
|
| ︙ | ︙ | |||
4434 4435 4436 4437 4438 4439 4440 | * None. * *------------------------------------------------------------------------- */ static const char *const * ZipFSFileAttrStringsProc( | | | > | 4419 4420 4421 4422 4423 4424 4425 4426 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 4442 4443 4444 4445 |
* None.
*
*-------------------------------------------------------------------------
*/
static const char *const *
ZipFSFileAttrStringsProc(
TCL_UNUSED(Tcl_Obj *) /*pathPtr*/,
TCL_UNUSED(Tcl_Obj **) /*objPtrRef*/)
{
static const char *const attrs[] = {
"-uncompsize",
"-compsize",
"-offset",
"-mount",
"-archive",
"-permissions",
NULL,
};
return attrs;
}
/*
*-------------------------------------------------------------------------
*
* ZipFSFileAttrsGetProc --
|
| ︙ | ︙ | |||
4476 4477 4478 4479 4480 4481 4482 |
static int
ZipFSFileAttrsGetProc(
Tcl_Interp *interp, /* Current interpreter. */
int index,
Tcl_Obj *pathPtr,
Tcl_Obj **objPtrRef)
{
| | | | 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 |
static int
ZipFSFileAttrsGetProc(
Tcl_Interp *interp, /* Current interpreter. */
int index,
Tcl_Obj *pathPtr,
Tcl_Obj **objPtrRef)
{
int len, ret = TCL_OK;
char *path;
ZipEntry *z;
pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (!pathPtr) {
return -1;
}
path = Tcl_GetStringFromObj(pathPtr, &len);
ReadLock();
z = ZipFSLookup(path);
if (!z) {
Tcl_SetErrno(ENOENT);
ZIPFS_POSIX_ERROR(interp, "file not found");
ret = TCL_ERROR;
goto done;
|
| ︙ | ︙ | |||
4543 4544 4545 4546 4547 4548 4549 |
*
*-------------------------------------------------------------------------
*/
static int
ZipFSFileAttrsSetProc(
Tcl_Interp *interp, /* Current interpreter. */
| | | | | 4529 4530 4531 4532 4533 4534 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 |
*
*-------------------------------------------------------------------------
*/
static int
ZipFSFileAttrsSetProc(
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*index*/,
TCL_UNUSED(Tcl_Obj *) /*pathPtr*/,
TCL_UNUSED(Tcl_Obj *) /*objPtr*/)
{
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported operation", -1));
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "UNSUPPORTED_OP", NULL);
}
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
4568 4569 4570 4571 4572 4573 4574 | * Side effects: * *------------------------------------------------------------------------- */ static Tcl_Obj * ZipFSFilesystemPathTypeProc( | | | 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 |
* Side effects:
*
*-------------------------------------------------------------------------
*/
static Tcl_Obj *
ZipFSFilesystemPathTypeProc(
TCL_UNUSED(Tcl_Obj *) /*pathPtr*/)
{
return Tcl_NewStringObj("zip", -1);
}
/*
*-------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
4678 4679 4680 4681 4682 4683 4684 |
if (objs[0]) {
Tcl_DecrRefCount(objs[0]);
}
if (objs[1]) {
Tcl_DecrRefCount(objs[1]);
}
| | | 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 |
if (objs[0]) {
Tcl_DecrRefCount(objs[0]);
}
if (objs[1]) {
Tcl_DecrRefCount(objs[1]);
}
loadFileProc = (Tcl_FSLoadFileProc2 *)(void *)tclNativeFilesystem.loadFileProc;
if (loadFileProc) {
ret = loadFileProc(interp, path, loadHandle, unloadProcPtr, flags);
} else {
Tcl_SetErrno(ENOENT);
ZIPFS_ERROR(interp, Tcl_PosixError(interp));
}
if (altPath) {
|
| ︙ | ︙ | |||
4711 4712 4713 4714 4715 4716 4717 | * Side effects: * Initializes this module if not already initialized, and adds module * related commands to the given interpreter. * *------------------------------------------------------------------------- */ | | | 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 |
* Side effects:
* Initializes this module if not already initialized, and adds module
* related commands to the given interpreter.
*
*-------------------------------------------------------------------------
*/
int
TclZipfs_Init(
Tcl_Interp *interp) /* Current interpreter. */
{
#ifdef HAVE_ZLIB
static const EnsembleImplMap initMap[] = {
{"mkimg", ZipFSMkImgObjCmd, NULL, NULL, NULL, 1},
{"mkzip", ZipFSMkZipObjCmd, NULL, NULL, NULL, 1},
|
| ︙ | ︙ | |||
4781 4782 4783 4784 4785 4786 4787 |
*/
Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj);
Tcl_DictObjPut(NULL, mapObj, Tcl_NewStringObj("find", -1),
Tcl_NewStringObj("::tcl::zipfs::find", -1));
Tcl_CreateObjCommand(interp, "::tcl::zipfs::tcl_library_init",
ZipFSTclLibraryObjCmd, NULL, NULL);
| | | 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 |
*/
Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj);
Tcl_DictObjPut(NULL, mapObj, Tcl_NewStringObj("find", -1),
Tcl_NewStringObj("::tcl::zipfs::find", -1));
Tcl_CreateObjCommand(interp, "::tcl::zipfs::tcl_library_init",
ZipFSTclLibraryObjCmd, NULL, NULL);
Tcl_PkgProvide(interp, "zipfs", "2.0");
}
return TCL_OK;
#else /* !HAVE_ZLIB */
ZIPFS_ERROR(interp, "no zlib available");
Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL);
return TCL_ERROR;
#endif /* HAVE_ZLIB */
|
| ︙ | ︙ | |||
4851 4852 4853 4854 4855 4856 4857 4858 4859 |
* Performs the argument munging for the shell
*
*-------------------------------------------------------------------------
*/
int
TclZipfs_AppHook(
int *argcPtr, /* Pointer to argc */
#ifdef _WIN32
| > > > > | | < > > > > | 4837 4838 4839 4840 4841 4842 4843 4844 4845 4846 4847 4848 4849 4850 4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 4865 4866 4867 4868 |
* Performs the argument munging for the shell
*
*-------------------------------------------------------------------------
*/
int
TclZipfs_AppHook(
#ifdef SUPPORT_BUILTIN_ZIP_INSTALL
int *argcPtr, /* Pointer to argc */
#else
TCL_UNUSED(int *), /*argcPtr*/
#endif
#ifdef _WIN32
TCL_UNUSED(WCHAR ***)) /* argvPtr */
#else /* !_WIN32 */
char ***argvPtr) /* Pointer to argv */
#endif /* _WIN32 */
{
char *archive;
#ifdef _WIN32
Tcl_FindExecutable(NULL);
#else
Tcl_FindExecutable((*argvPtr)[0]);
#endif
archive = (char *) Tcl_GetNameOfExecutable();
TclZipfs_Init(NULL);
/*
* Look for init.tcl in one of the locations mounted later in this
* function.
*/
|
| ︙ | ︙ | |||
4911 4912 4913 4914 4915 4916 4917 | * If the first argument is "install", run the supplied installer * script. */ #ifdef _WIN32 Tcl_DString ds; | > | | 4904 4905 4906 4907 4908 4909 4910 4911 4912 4913 4914 4915 4916 4917 4918 4919 |
* If the first argument is "install", run the supplied installer
* script.
*/
#ifdef _WIN32
Tcl_DString ds;
Tcl_DStringInit(&ds);
archive = Tcl_WCharToUtfDString((*argvPtr)[1], -1, &ds);
#else /* !_WIN32 */
archive = (*argvPtr)[1];
#endif /* _WIN32 */
if (strcmp(archive, "install") == 0) {
Tcl_Obj *vfsInitScript;
/*
|
| ︙ | ︙ |
Changes to generic/tclZlib.c.
| ︙ | ︙ | |||
60 61 62 63 64 65 66 |
typedef struct {
Tcl_Interp *interp;
z_stream stream; /* The interface to the zlib library. */
int streamEnd; /* If we've got to end-of-stream. */
Tcl_Obj *inData, *outData; /* Input / output buffers (lists) */
Tcl_Obj *currentInput; /* Pointer to what is currently being
* inflated. */
| | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
typedef struct {
Tcl_Interp *interp;
z_stream stream; /* The interface to the zlib library. */
int streamEnd; /* If we've got to end-of-stream. */
Tcl_Obj *inData, *outData; /* Input / output buffers (lists) */
Tcl_Obj *currentInput; /* Pointer to what is currently being
* inflated. */
int outPos;
int mode; /* Either TCL_ZLIB_STREAM_DEFLATE or
* TCL_ZLIB_STREAM_INFLATE. */
int format; /* Flags from the TCL_ZLIB_FORMAT_* */
int level; /* Default 5, 0-9 */
int flush; /* Stores the flush param for deferred the
* decompression. */
int wbits; /* The encoded compression mode, so we can
|
| ︙ | ︙ | |||
156 157 158 159 160 161 162 | /* * Prototypes for private procedures defined later in this file: */ static Tcl_CmdDeleteProc ZlibStreamCmdDelete; static Tcl_DriverBlockModeProc ZlibTransformBlockMode; | | | | | | | | 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 |
/*
* Prototypes for private procedures defined later in this file:
*/
static Tcl_CmdDeleteProc ZlibStreamCmdDelete;
static Tcl_DriverBlockModeProc ZlibTransformBlockMode;
static Tcl_DriverClose2Proc ZlibTransformClose;
static Tcl_DriverGetHandleProc ZlibTransformGetHandle;
static Tcl_DriverGetOptionProc ZlibTransformGetOption;
static Tcl_DriverHandlerProc ZlibTransformEventHandler;
static Tcl_DriverInputProc ZlibTransformInput;
static Tcl_DriverOutputProc ZlibTransformOutput;
static Tcl_DriverSetOptionProc ZlibTransformSetOption;
static Tcl_DriverWatchProc ZlibTransformWatch;
static Tcl_ObjCmdProc ZlibCmd;
static Tcl_ObjCmdProc ZlibStreamCmd;
static Tcl_ObjCmdProc ZlibStreamAddCmd;
static Tcl_ObjCmdProc ZlibStreamHeaderCmd;
static Tcl_ObjCmdProc ZlibStreamPutCmd;
static void ConvertError(Tcl_Interp *interp, int code,
uLong adler);
static Tcl_Obj * ConvertErrorToList(int code, uLong adler);
static inline int Deflate(z_streamp strm, void *bufferPtr,
int bufferSize, int flush, int *writtenPtr);
static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj);
static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj,
GzipHeader *headerPtr, int *extraSizePtr);
static int ZlibPushSubcmd(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static inline int ResultCopy(ZlibChannelData *cd, char *buf,
int toRead);
static int ResultGenerate(ZlibChannelData *cd, int n, int flush,
int *errorCodePtr);
static Tcl_Channel ZlibStackChannelTransform(Tcl_Interp *interp,
int mode, int format, int level, int limit,
Tcl_Channel channel, Tcl_Obj *gzipHeaderDictPtr,
Tcl_Obj *compDictObj);
static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr);
static int ZlibStreamSubcmd(Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static inline void ZlibTransformEventTimerKill(ZlibChannelData *cd);
static void ZlibTransformTimerRun(void *clientData);
/*
* Type of zlib-based compressing and decompressing channels.
*/
static const Tcl_ChannelType zlibChannelType = {
"zlib",
TCL_CHANNEL_VERSION_5,
TCL_CLOSE2PROC,
ZlibTransformInput,
ZlibTransformOutput,
NULL, /* seekProc */
ZlibTransformSetOption,
ZlibTransformGetOption,
ZlibTransformWatch,
ZlibTransformGetHandle,
ZlibTransformClose, /* close2Proc */
ZlibTransformBlockMode,
NULL, /* flushProc */
ZlibTransformEventHandler,
NULL, /* wideSeekProc */
NULL,
NULL
};
|
| ︙ | ︙ | |||
418 419 420 421 422 423 424 |
* parsed. */
GzipHeader *headerPtr, /* Where to store the parsed-out values. */
int *extraSizePtr) /* Variable to add the length of header
* strings (filename, comment) to. */
{
Tcl_Obj *value;
int len, result = TCL_ERROR;
| < | | | | | 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 |
* parsed. */
GzipHeader *headerPtr, /* Where to store the parsed-out values. */
int *extraSizePtr) /* Variable to add the length of header
* strings (filename, comment) to. */
{
Tcl_Obj *value;
int len, result = TCL_ERROR;
Tcl_WideInt wideValue = 0;
const char *valueStr;
Tcl_Encoding latin1enc;
static const char *const types[] = {
"binary", "text"
};
/*
* RFC 1952 says that header strings are in ISO 8859-1 (LATIN-1).
*/
latin1enc = Tcl_GetEncoding(NULL, "iso8859-1");
if (latin1enc == NULL) {
Tcl_Panic("no latin-1 encoding");
}
if (GetValue(interp, dictObj, "comment", &value) != TCL_OK) {
goto error;
} else if (value != NULL) {
valueStr = TclGetStringFromObj(value, &len);
Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL,
headerPtr->nativeCommentBuf, MAX_COMMENT_LEN-1, NULL, &len,
NULL);
headerPtr->nativeCommentBuf[len] = '\0';
headerPtr->header.comment = (Bytef *) headerPtr->nativeCommentBuf;
if (extraSizePtr != NULL) {
*extraSizePtr += len;
}
}
if (GetValue(interp, dictObj, "crc", &value) != TCL_OK) {
goto error;
} else if (value != NULL &&
Tcl_GetBooleanFromObj(interp, value, &headerPtr->header.hcrc)) {
goto error;
}
if (GetValue(interp, dictObj, "filename", &value) != TCL_OK) {
goto error;
} else if (value != NULL) {
valueStr = TclGetStringFromObj(value, &len);
Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL,
headerPtr->nativeFilenameBuf, MAXPATHLEN-1, NULL, &len, NULL);
headerPtr->nativeFilenameBuf[len] = '\0';
headerPtr->header.name = (Bytef *) headerPtr->nativeFilenameBuf;
if (extraSizePtr != NULL) {
*extraSizePtr += len;
}
}
|
| ︙ | ︙ | |||
589 590 591 592 593 594 595 |
static int
SetInflateDictionary(
z_streamp strm,
Tcl_Obj *compDictObj)
{
if (compDictObj != NULL) {
| | | | | | | | | 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 |
static int
SetInflateDictionary(
z_streamp strm,
Tcl_Obj *compDictObj)
{
if (compDictObj != NULL) {
int length;
unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length);
return inflateSetDictionary(strm, bytes, length);
}
return Z_OK;
}
static int
SetDeflateDictionary(
z_streamp strm,
Tcl_Obj *compDictObj)
{
if (compDictObj != NULL) {
int length;
unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length);
return deflateSetDictionary(strm, bytes, length);
}
return Z_OK;
}
static inline int
Deflate(
z_streamp strm,
void *bufferPtr,
int bufferSize,
int flush,
int *writtenPtr)
{
int e;
strm->next_out = (Bytef *) bufferPtr;
strm->avail_out = bufferSize;
e = deflate(strm, flush);
if (writtenPtr != NULL) {
*writtenPtr = bufferSize - strm->avail_out;
}
return e;
}
static inline void
AppendByteArray(
Tcl_Obj *listObj,
void *buffer,
int size)
{
if (size > 0) {
Tcl_Obj *baObj = Tcl_NewByteArrayObj((unsigned char *) buffer, size);
Tcl_ListObjAppendElement(NULL, listObj, baObj);
}
}
|
| ︙ | ︙ | |||
696 697 698 699 700 701 702 |
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
if (dictObj) {
| | | | 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 |
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
if (dictObj) {
gzHeaderPtr = (GzipHeader *)ckalloc(sizeof(GzipHeader));
memset(gzHeaderPtr, 0, sizeof(GzipHeader));
if (GenerateHeader(interp, dictObj, gzHeaderPtr,
NULL) != TCL_OK) {
ckfree(gzHeaderPtr);
return TCL_ERROR;
}
}
break;
case TCL_ZLIB_FORMAT_ZLIB:
wbits = WBITS_ZLIB;
break;
|
| ︙ | ︙ | |||
730 731 732 733 734 735 736 |
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
| | | 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 |
switch (format) {
case TCL_ZLIB_FORMAT_RAW:
wbits = WBITS_RAW;
break;
case TCL_ZLIB_FORMAT_GZIP:
wbits = WBITS_GZIP;
gzHeaderPtr = (GzipHeader *)ckalloc(sizeof(GzipHeader));
memset(gzHeaderPtr, 0, sizeof(GzipHeader));
gzHeaderPtr->header.name = (Bytef *)
gzHeaderPtr->nativeFilenameBuf;
gzHeaderPtr->header.name_max = MAXPATHLEN - 1;
gzHeaderPtr->header.comment = (Bytef *)
gzHeaderPtr->nativeCommentBuf;
gzHeaderPtr->header.name_max = MAX_COMMENT_LEN - 1;
|
| ︙ | ︙ | |||
756 757 758 759 760 761 762 |
}
break;
default:
Tcl_Panic("bad mode, must be TCL_ZLIB_STREAM_DEFLATE or"
" TCL_ZLIB_STREAM_INFLATE");
}
| | | 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 |
}
break;
default:
Tcl_Panic("bad mode, must be TCL_ZLIB_STREAM_DEFLATE or"
" TCL_ZLIB_STREAM_INFLATE");
}
zshPtr = (ZlibStreamHandle *)ckalloc(sizeof(ZlibStreamHandle));
zshPtr->interp = interp;
zshPtr->mode = mode;
zshPtr->format = format;
zshPtr->level = level;
zshPtr->wbits = wbits;
zshPtr->currentInput = NULL;
zshPtr->streamEnd = 0;
|
| ︙ | ︙ | |||
856 857 858 859 860 861 862 |
return TCL_OK;
error:
if (zshPtr->compDictObj) {
Tcl_DecrRefCount(zshPtr->compDictObj);
}
if (zshPtr->gzHeaderPtr) {
| | | | 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 |
return TCL_OK;
error:
if (zshPtr->compDictObj) {
Tcl_DecrRefCount(zshPtr->compDictObj);
}
if (zshPtr->gzHeaderPtr) {
ckfree(zshPtr->gzHeaderPtr);
}
ckfree(zshPtr);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* ZlibStreamCmdDelete --
|
| ︙ | ︙ | |||
883 884 885 886 887 888 889 |
*----------------------------------------------------------------------
*/
static void
ZlibStreamCmdDelete(
void *cd)
{
| | | 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 |
*----------------------------------------------------------------------
*/
static void
ZlibStreamCmdDelete(
void *cd)
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *)cd;
zshPtr->cmd = NULL;
ZlibStreamCleanup(zshPtr);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
969 970 971 972 973 974 975 |
if (zshPtr->currentInput) {
Tcl_DecrRefCount(zshPtr->currentInput);
}
if (zshPtr->compDictObj) {
Tcl_DecrRefCount(zshPtr->compDictObj);
}
if (zshPtr->gzHeaderPtr) {
| | | | 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 |
if (zshPtr->currentInput) {
Tcl_DecrRefCount(zshPtr->currentInput);
}
if (zshPtr->compDictObj) {
Tcl_DecrRefCount(zshPtr->compDictObj);
}
if (zshPtr->gzHeaderPtr) {
ckfree(zshPtr->gzHeaderPtr);
}
ckfree(zshPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_ZlibStreamReset --
*
|
| ︙ | ︙ | |||
1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 |
void
Tcl_ZlibStreamSetCompressionDictionary(
Tcl_ZlibStream zshandle,
Tcl_Obj *compressionDictionaryObj)
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
if (compressionDictionaryObj != NULL) {
if (Tcl_IsShared(compressionDictionaryObj)) {
compressionDictionaryObj =
Tcl_DuplicateObj(compressionDictionaryObj);
}
Tcl_IncrRefCount(compressionDictionaryObj);
zshPtr->flags |= DICT_TO_SET;
| > > > > > | 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 |
void
Tcl_ZlibStreamSetCompressionDictionary(
Tcl_ZlibStream zshandle,
Tcl_Obj *compressionDictionaryObj)
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
if (compressionDictionaryObj && (NULL == TclGetBytesFromObj(NULL,
compressionDictionaryObj, NULL))) {
/* Missing or invalid compression dictionary */
compressionDictionaryObj = NULL;
}
if (compressionDictionaryObj != NULL) {
if (Tcl_IsShared(compressionDictionaryObj)) {
compressionDictionaryObj =
Tcl_DuplicateObj(compressionDictionaryObj);
}
Tcl_IncrRefCount(compressionDictionaryObj);
zshPtr->flags |= DICT_TO_SET;
|
| ︙ | ︙ | |||
1187 1188 1189 1190 1191 1192 1193 |
Tcl_ZlibStream zshandle, /* As obtained from Tcl_ZlibStreamInit */
Tcl_Obj *data, /* Data to compress/decompress */
int flush) /* TCL_ZLIB_NO_FLUSH, TCL_ZLIB_FLUSH,
* TCL_ZLIB_FULLFLUSH, or TCL_ZLIB_FINALIZE */
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
char *dataTmp = NULL;
| < | > > > > > > | | 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 |
Tcl_ZlibStream zshandle, /* As obtained from Tcl_ZlibStreamInit */
Tcl_Obj *data, /* Data to compress/decompress */
int flush) /* TCL_ZLIB_NO_FLUSH, TCL_ZLIB_FLUSH,
* TCL_ZLIB_FULLFLUSH, or TCL_ZLIB_FINALIZE */
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
char *dataTmp = NULL;
int e, size, outSize, toStore;
unsigned char *bytes;
if (zshPtr->streamEnd) {
if (zshPtr->interp) {
Tcl_SetObjResult(zshPtr->interp, Tcl_NewStringObj(
"already past compressed stream end", -1));
Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "CLOSED", NULL);
}
return TCL_ERROR;
}
bytes = TclGetBytesFromObj(zshPtr->interp, data, &size);
if (bytes == NULL) {
return TCL_ERROR;
}
if (zshPtr->mode == TCL_ZLIB_STREAM_DEFLATE) {
zshPtr->stream.next_in = bytes;
zshPtr->stream.avail_in = size;
/*
* Must not do a zero-length compress unless finalizing. [Bug 25842c161]
*/
if (size == 0 && flush != Z_FINISH) {
|
| ︙ | ︙ | |||
1231 1232 1233 1234 1235 1236 1237 |
* size.
*/
outSize = deflateBound(&zshPtr->stream, size) + 100;
if (outSize > BUFFER_SIZE_LIMIT) {
outSize = BUFFER_SIZE_LIMIT;
}
| | | 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 |
* size.
*/
outSize = deflateBound(&zshPtr->stream, size) + 100;
if (outSize > BUFFER_SIZE_LIMIT) {
outSize = BUFFER_SIZE_LIMIT;
}
dataTmp = (char *)ckalloc(outSize);
while (1) {
e = Deflate(&zshPtr->stream, dataTmp, outSize, flush, &toStore);
/*
* Test if we've filled the buffer up and have to ask deflate() to
* give us some more. Note that the condition for needing to
|
| ︙ | ︙ | |||
1265 1266 1267 1268 1269 1270 1271 |
*/
AppendByteArray(zshPtr->outData, dataTmp, outSize);
if (outSize < BUFFER_SIZE_LIMIT) {
outSize = BUFFER_SIZE_LIMIT;
/* There may be *lots* of data left to output... */
| | | | 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 |
*/
AppendByteArray(zshPtr->outData, dataTmp, outSize);
if (outSize < BUFFER_SIZE_LIMIT) {
outSize = BUFFER_SIZE_LIMIT;
/* There may be *lots* of data left to output... */
dataTmp = (char *)ckrealloc(dataTmp, outSize);
}
}
/*
* And append the final data block to the outData list.
*/
AppendByteArray(zshPtr->outData, dataTmp, toStore);
ckfree(dataTmp);
} else {
/*
* This is easy. Just append to the inData list.
*/
Tcl_ListObjAppendElement(NULL, zshPtr->inData, data);
|
| ︙ | ︙ | |||
1307 1308 1309 1310 1311 1312 1313 |
*----------------------------------------------------------------------
*/
int
Tcl_ZlibStreamGet(
Tcl_ZlibStream zshandle, /* As obtained from Tcl_ZlibStreamInit */
Tcl_Obj *data, /* A place to append the data. */
| | | < | | > | > | | 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 |
*----------------------------------------------------------------------
*/
int
Tcl_ZlibStreamGet(
Tcl_ZlibStream zshandle, /* As obtained from Tcl_ZlibStreamInit */
Tcl_Obj *data, /* A place to append the data. */
int count) /* Number of bytes to grab as a maximum, you
* may get less! */
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
int e, i, listLen, itemLen, dataPos = 0;
Tcl_Obj *itemObj;
unsigned char *dataPtr, *itemPtr;
int existing;
/*
* Getting beyond the of stream, just return empty string.
*/
if (zshPtr->streamEnd) {
return TCL_OK;
}
if (NULL == TclGetBytesFromObj(zshPtr->interp, data, &existing)) {
return TCL_ERROR;
}
if (zshPtr->mode == TCL_ZLIB_STREAM_INFLATE) {
if (count == -1) {
/*
* The only safe thing to do is restict to 65k. We might cause a
* panic for out of memory if we just kept growing the buffer.
*/
count = MAX_BUFFER_SIZE;
}
|
| ︙ | ︙ | |||
1368 1369 1370 1371 1372 1373 1374 |
* under our feet. [Bug 3081008]
*/
Tcl_ListObjIndex(NULL, zshPtr->inData, 0, &itemObj);
if (Tcl_IsShared(itemObj)) {
itemObj = Tcl_DuplicateObj(itemObj);
}
| | | 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 |
* under our feet. [Bug 3081008]
*/
Tcl_ListObjIndex(NULL, zshPtr->inData, 0, &itemObj);
if (Tcl_IsShared(itemObj)) {
itemObj = Tcl_DuplicateObj(itemObj);
}
itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen);
Tcl_IncrRefCount(itemObj);
zshPtr->currentInput = itemObj;
zshPtr->stream.next_in = itemPtr;
zshPtr->stream.avail_in = itemLen;
/*
* And remove it from the list
|
| ︙ | ︙ | |||
1440 1441 1442 1443 1444 1445 1446 |
* representation to not vanish under our feet. [Bug 3081008]
*/
Tcl_ListObjIndex(zshPtr->interp, zshPtr->inData, 0, &itemObj);
if (Tcl_IsShared(itemObj)) {
itemObj = Tcl_DuplicateObj(itemObj);
}
| | | 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 |
* representation to not vanish under our feet. [Bug 3081008]
*/
Tcl_ListObjIndex(zshPtr->interp, zshPtr->inData, 0, &itemObj);
if (Tcl_IsShared(itemObj)) {
itemObj = Tcl_DuplicateObj(itemObj);
}
itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen);
Tcl_IncrRefCount(itemObj);
zshPtr->currentInput = itemObj;
zshPtr->stream.next_in = itemPtr;
zshPtr->stream.avail_in = itemLen;
/*
* Remove it from the list.
|
| ︙ | ︙ | |||
1485 1486 1487 1488 1489 1490 1491 |
Tcl_DecrRefCount(zshPtr->currentInput);
zshPtr->currentInput = 0;
}
inflateEnd(&zshPtr->stream);
}
} else {
Tcl_ListObjLength(NULL, zshPtr->outData, &listLen);
| | | | 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 |
Tcl_DecrRefCount(zshPtr->currentInput);
zshPtr->currentInput = 0;
}
inflateEnd(&zshPtr->stream);
}
} else {
Tcl_ListObjLength(NULL, zshPtr->outData, &listLen);
if (count == -1) {
count = 0;
for (i=0; i<listLen; i++) {
Tcl_ListObjIndex(NULL, zshPtr->outData, i, &itemObj);
(void) Tcl_GetByteArrayFromObj(itemObj, &itemLen);
if (i == 0) {
count += itemLen - zshPtr->outPos;
} else {
count += itemLen;
}
}
}
|
| ︙ | ︙ | |||
1514 1515 1516 1517 1518 1519 1520 |
&& (listLen > 0)) {
/*
* Get the next chunk off our list of chunks and grab the data out
* of it.
*/
Tcl_ListObjIndex(NULL, zshPtr->outData, 0, &itemObj);
| | | | 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 |
&& (listLen > 0)) {
/*
* Get the next chunk off our list of chunks and grab the data out
* of it.
*/
Tcl_ListObjIndex(NULL, zshPtr->outData, 0, &itemObj);
itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen);
if (itemLen-zshPtr->outPos >= count-dataPos) {
size_t len = count - dataPos;
memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len);
zshPtr->outPos += len;
dataPos += len;
if (zshPtr->outPos == itemLen) {
zshPtr->outPos = 0;
|
| ︙ | ︙ | |||
1561 1562 1563 1564 1565 1566 1567 |
Tcl_ZlibDeflate(
Tcl_Interp *interp,
int format,
Tcl_Obj *data,
int level,
Tcl_Obj *gzipHeaderDictObj)
{
| | < > > > > > > > > > > | 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 |
Tcl_ZlibDeflate(
Tcl_Interp *interp,
int format,
Tcl_Obj *data,
int level,
Tcl_Obj *gzipHeaderDictObj)
{
int wbits = 0, inLen = 0, e = 0, extraSize = 0;
Byte *inData = NULL;
z_stream stream;
GzipHeader header;
gz_header *headerPtr = NULL;
Tcl_Obj *obj;
if (!interp) {
return TCL_ERROR;
}
/*
* Obtain the pointer to the byte array, we'll pass this pointer straight
* to the deflate command.
*/
inData = TclGetBytesFromObj(interp, data, &inLen);
if (inData == NULL) {
return TCL_ERROR;
}
/*
* Compressed format is specified by the wbits parameter. See zlib.h for
* details.
*/
if (format == TCL_ZLIB_FORMAT_RAW) {
|
| ︙ | ︙ | |||
1617 1618 1619 1620 1621 1622 1623 |
/*
* Allocate some space to store the output.
*/
TclNewObj(obj);
| < < < < < < | | 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 |
/*
* Allocate some space to store the output.
*/
TclNewObj(obj);
memset(&stream, 0, sizeof(z_stream));
stream.avail_in = (uInt) inLen;
stream.next_in = inData;
/*
* No output buffer available yet, will alloc after deflateInit2.
*/
e = deflateInit2(&stream, level, Z_DEFLATED, wbits, MAX_MEM_LEVEL,
|
| ︙ | ︙ | |||
1709 1710 1711 1712 1713 1714 1715 |
*/
int
Tcl_ZlibInflate(
Tcl_Interp *interp,
int format,
Tcl_Obj *data,
| | | < > > > > > | 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 |
*/
int
Tcl_ZlibInflate(
Tcl_Interp *interp,
int format,
Tcl_Obj *data,
int bufferSize,
Tcl_Obj *gzipHeaderDictObj)
{
int wbits = 0, inLen = 0, e = 0, newBufferSize;
Byte *inData = NULL, *outData = NULL, *newOutData = NULL;
z_stream stream;
gz_header header, *headerPtr = NULL;
Tcl_Obj *obj;
char *nameBuf = NULL, *commentBuf = NULL;
if (!interp) {
return TCL_ERROR;
}
inData = TclGetBytesFromObj(interp, data, &inLen);
if (inData == NULL) {
return TCL_ERROR;
}
/*
* Compressed format is specified by the wbits parameter. See zlib.h for
* details.
*/
switch (format) {
|
| ︙ | ︙ | |||
1753 1754 1755 1756 1757 1758 1759 |
"TCL_ZLIB_FORMAT_GZIP, TCL_ZLIB_FORMAT_RAW or "
"TCL_ZLIB_FORMAT_AUTO");
}
if (gzipHeaderDictObj) {
headerPtr = &header;
memset(headerPtr, 0, sizeof(gz_header));
| | | < | | 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 |
"TCL_ZLIB_FORMAT_GZIP, TCL_ZLIB_FORMAT_RAW or "
"TCL_ZLIB_FORMAT_AUTO");
}
if (gzipHeaderDictObj) {
headerPtr = &header;
memset(headerPtr, 0, sizeof(gz_header));
nameBuf = (char *)ckalloc(MAXPATHLEN);
header.name = (Bytef *) nameBuf;
header.name_max = MAXPATHLEN - 1;
commentBuf = (char *)ckalloc(MAX_COMMENT_LEN);
header.comment = (Bytef *) commentBuf;
header.comm_max = MAX_COMMENT_LEN - 1;
}
if (bufferSize < 1) {
/*
* Start with a buffer (up to) 3 times the size of the input data.
*/
if (inLen < 32*1024*1024) {
bufferSize = 3*inLen;
} else if (inLen < 256*1024*1024) {
bufferSize = 2*inLen;
} else {
bufferSize = inLen;
}
}
TclNewObj(obj);
outData = Tcl_SetByteArrayLength(obj, bufferSize);
memset(&stream, 0, sizeof(z_stream));
stream.avail_in = (uInt) inLen+1; /* +1 because zlib can "over-request"
* input (but ignore it!) */
stream.next_in = inData;
stream.avail_out = bufferSize;
stream.next_out = outData;
/*
* Initialize zlib for decompression.
|
| ︙ | ︙ | |||
1862 1863 1864 1865 1866 1867 1868 |
*/
Tcl_SetByteArrayLength(obj, stream.total_out);
if (headerPtr != NULL) {
ExtractHeader(&header, gzipHeaderDictObj);
SetValue(gzipHeaderDictObj, "size",
Tcl_NewWideIntObj(stream.total_out));
| | | | | | | | | | < | 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 |
*/
Tcl_SetByteArrayLength(obj, stream.total_out);
if (headerPtr != NULL) {
ExtractHeader(&header, gzipHeaderDictObj);
SetValue(gzipHeaderDictObj, "size",
Tcl_NewWideIntObj(stream.total_out));
ckfree(nameBuf);
ckfree(commentBuf);
}
Tcl_SetObjResult(interp, obj);
return TCL_OK;
error:
TclDecrRefCount(obj);
ConvertError(interp, e, stream.adler);
if (nameBuf) {
ckfree(nameBuf);
}
if (commentBuf) {
ckfree(commentBuf);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ZlibCRC32, Tcl_ZlibAdler32 --
*
* Access to the checksumming engines.
*
*----------------------------------------------------------------------
*/
unsigned int
Tcl_ZlibCRC32(
unsigned int crc,
const unsigned char *buf,
int len)
{
/* Nothing much to do, just wrap the crc32(). */
return crc32(crc, (Bytef *) buf, len);
}
unsigned int
Tcl_ZlibAdler32(
unsigned int adler,
const unsigned char *buf,
int len)
{
return adler32(adler, (Bytef *) buf, len);
}
/*
*----------------------------------------------------------------------
*
* ZlibCmd --
*
* Implementation of the [zlib] command.
*
*----------------------------------------------------------------------
*/
static int
ZlibCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
int command, dlen, i, option, level = -1;
unsigned start, buffersize = 0;
Byte *data;
Tcl_Obj *headerDictObj;
const char *extraInfoStr = NULL;
static const char *const commands[] = {
"adler32", "compress", "crc32", "decompress", "deflate", "gunzip",
"gzip", "inflate", "push", "stream",
NULL
|
| ︙ | ︙ | |||
1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 |
switch ((enum zlibCommands) command) {
case CMD_ADLER: /* adler32 str ?startvalue?
* -> checksum */
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?startValue?");
return TCL_ERROR;
}
if (objc>3 && Tcl_GetIntFromObj(interp, objv[3],
(int *) &start) != TCL_OK) {
return TCL_ERROR;
}
if (objc < 4) {
start = Tcl_ZlibAdler32(0, NULL, 0);
}
| > > > > < > > > > < | 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 |
switch ((enum zlibCommands) command) {
case CMD_ADLER: /* adler32 str ?startvalue?
* -> checksum */
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?startValue?");
return TCL_ERROR;
}
data = TclGetBytesFromObj(interp, objv[2], &dlen);
if (data == NULL) {
return TCL_ERROR;
}
if (objc>3 && Tcl_GetIntFromObj(interp, objv[3],
(int *) &start) != TCL_OK) {
return TCL_ERROR;
}
if (objc < 4) {
start = Tcl_ZlibAdler32(0, NULL, 0);
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
(uLong) Tcl_ZlibAdler32(start, data, dlen)));
return TCL_OK;
case CMD_CRC: /* crc32 str ?startvalue?
* -> checksum */
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?startValue?");
return TCL_ERROR;
}
data = TclGetBytesFromObj(interp, objv[2], &dlen);
if (data == NULL) {
return TCL_ERROR;
}
if (objc>3 && Tcl_GetIntFromObj(interp, objv[3],
(int *) &start) != TCL_OK) {
return TCL_ERROR;
}
if (objc < 4) {
start = Tcl_ZlibCRC32(0, NULL, 0);
}
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((Tcl_WideInt)
(uLong) Tcl_ZlibCRC32(start, data, dlen)));
return TCL_OK;
case CMD_DEFLATE: /* deflate data ?level?
* -> rawCompressedData */
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?level?");
|
| ︙ | ︙ | |||
2075 2076 2077 2078 2079 2080 2081 |
case CMD_INFLATE: /* inflate rawcomprdata ?bufferSize?
* -> decompressedData */
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?bufferSize?");
return TCL_ERROR;
}
if (objc > 3) {
| | | | | < | | | | < | 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 |
case CMD_INFLATE: /* inflate rawcomprdata ?bufferSize?
* -> decompressedData */
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?bufferSize?");
return TCL_ERROR;
}
if (objc > 3) {
if (Tcl_GetIntFromObj(interp, objv[3],
(int *) &buffersize) != TCL_OK) {
return TCL_ERROR;
}
if (buffersize < MIN_NONSTREAM_BUFFER_SIZE
|| buffersize > MAX_BUFFER_SIZE) {
goto badBuffer;
}
}
return Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_RAW, objv[2],
buffersize, NULL);
case CMD_DECOMPRESS: /* decompress zlibcomprdata \
* ?bufferSize?
* -> decompressedData */
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 2, objv, "data ?bufferSize?");
return TCL_ERROR;
}
if (objc > 3) {
if (Tcl_GetIntFromObj(interp, objv[3],
(int *) &buffersize) != TCL_OK) {
return TCL_ERROR;
}
if (buffersize < MIN_NONSTREAM_BUFFER_SIZE
|| buffersize > MAX_BUFFER_SIZE) {
goto badBuffer;
}
}
return Tcl_ZlibInflate(interp, TCL_ZLIB_FORMAT_ZLIB, objv[2],
buffersize, NULL);
case CMD_GUNZIP: { /* gunzip gzippeddata ?bufferSize?
* -> decompressedData */
Tcl_Obj *headerVarObj;
|
| ︙ | ︙ | |||
2127 2128 2129 2130 2131 2132 2133 |
if (Tcl_GetIndexFromObj(interp, objv[i], gunzipopts, "option", 0,
&option) != TCL_OK) {
return TCL_ERROR;
}
switch (option) {
case 0:
| | | | | < | 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 |
if (Tcl_GetIndexFromObj(interp, objv[i], gunzipopts, "option", 0,
&option) != TCL_OK) {
return TCL_ERROR;
}
switch (option) {
case 0:
if (Tcl_GetIntFromObj(interp, objv[i+1],
(int *) &buffersize) != TCL_OK) {
return TCL_ERROR;
}
if (buffersize < MIN_NONSTREAM_BUFFER_SIZE
|| buffersize > MAX_BUFFER_SIZE) {
goto badBuffer;
}
break;
case 1:
headerVarObj = objv[i+1];
headerDictObj = Tcl_NewObj();
break;
}
}
|
| ︙ | ︙ | |||
2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 |
return TCL_ERROR;
} else if (level < 0 || level > 9) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9",-1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL);
Tcl_AddErrorInfo(interp, "\n (in -level option)");
return TCL_ERROR;
}
/*
* Construct the stream now we know its configuration.
*/
if (Tcl_ZlibStreamInit(interp, mode, format, level, gzipHeaderObj,
&zh) != TCL_OK) {
| > > > > > > | 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 |
return TCL_ERROR;
} else if (level < 0 || level > 9) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("level must be 0 to 9",-1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL);
Tcl_AddErrorInfo(interp, "\n (in -level option)");
return TCL_ERROR;
}
if (compDictObj) {
if (NULL == TclGetBytesFromObj(interp, compDictObj, NULL)) {
return TCL_ERROR;
}
}
/*
* Construct the stream now we know its configuration.
*/
if (Tcl_ZlibStreamInit(interp, mode, format, level, gzipHeaderObj,
&zh) != TCL_OK) {
|
| ︙ | ︙ | |||
2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 |
Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL);
goto genericOptionError;
}
compDictObj = objv[i];
break;
}
}
if (ZlibStackChannelTransform(interp, mode, format, level, limit, chan,
headerObj, compDictObj) == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[3]);
return TCL_OK;
| > > > > | 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 |
Tcl_SetErrorCode(interp, "TCL", "ZIP", "BADOPT", NULL);
goto genericOptionError;
}
compDictObj = objv[i];
break;
}
}
if (compDictObj && (NULL == TclGetBytesFromObj(interp, compDictObj, NULL))) {
return TCL_ERROR;
}
if (ZlibStackChannelTransform(interp, mode, format, level, limit, chan,
headerObj, compDictObj) == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, objv[3]);
return TCL_OK;
|
| ︙ | ︙ | |||
2526 2527 2528 2529 2530 2531 2532 |
static int
ZlibStreamCmd(
void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| | | 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 |
static int
ZlibStreamCmd(
void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd;
int command, count, code;
Tcl_Obj *obj;
static const char *const cmds[] = {
"add", "checksum", "close", "eof", "finalize", "flush",
"fullflush", "get", "header", "put", "reset",
NULL
};
|
| ︙ | ︙ | |||
2652 2653 2654 2655 2656 2657 2658 |
static int
ZlibStreamAddCmd(
void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| | | 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 |
static int
ZlibStreamAddCmd(
void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd;
int index, code, buffersize = -1, flush = -1, i;
Tcl_Obj *obj, *compDictObj = NULL;
static const char *const add_options[] = {
"-buffer", "-dictionary", "-finalize", "-flush", "-fullflush", NULL
};
enum addOptions {
ao_buffer, ao_dictionary, ao_finalize, ao_flush, ao_fullflush
|
| ︙ | ︙ | |||
2738 2739 2740 2741 2742 2743 2744 |
}
/*
* Set the compression dictionary if requested.
*/
if (compDictObj != NULL) {
| | > > > | | 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 |
}
/*
* Set the compression dictionary if requested.
*/
if (compDictObj != NULL) {
int len;
if (NULL == TclGetBytesFromObj(interp, compDictObj, &len)) {
return TCL_ERROR;
}
if (len == 0) {
compDictObj = NULL;
}
Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj);
}
/*
|
| ︙ | ︙ | |||
2776 2777 2778 2779 2780 2781 2782 |
static int
ZlibStreamPutCmd(
void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
| | | 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 |
static int
ZlibStreamPutCmd(
void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd;
int index, flush = -1, i;
Tcl_Obj *compDictObj = NULL;
static const char *const put_options[] = {
"-dictionary", "-finalize", "-flush", "-fullflush", NULL
};
enum putOptions {
po_dictionary, po_finalize, po_flush, po_fullflush
|
| ︙ | ︙ | |||
2842 2843 2844 2845 2846 2847 2848 |
}
/*
* Set the compression dictionary if requested.
*/
if (compDictObj != NULL) {
| | | > > | | 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 |
}
/*
* Set the compression dictionary if requested.
*/
if (compDictObj != NULL) {
int len;
if (NULL == TclGetBytesFromObj(interp, compDictObj, &len)) {
return TCL_ERROR;
}
if (len == 0) {
compDictObj = NULL;
}
Tcl_ZlibStreamSetCompressionDictionary(zstream, compDictObj);
}
/*
* Send the data to the stream core, along with any flushing directive.
*/
return Tcl_ZlibStreamPut(zstream, objv[objc-1], flush);
}
static int
ZlibStreamHeaderCmd(
void *cd,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *)cd;
Tcl_Obj *resultObj;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
} else if (zshPtr->mode != TCL_ZLIB_STREAM_INFLATE
|| zshPtr->format != TCL_ZLIB_FORMAT_GZIP) {
|
| ︙ | ︙ | |||
2900 2901 2902 2903 2904 2905 2906 |
*
*----------------------------------------------------------------------
*/
static int
ZlibTransformClose(
void *instanceData,
| | > | | | > > > | 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 |
*
*----------------------------------------------------------------------
*/
static int
ZlibTransformClose(
void *instanceData,
Tcl_Interp *interp,
int flags)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
int e, written, result = TCL_OK;
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
/*
* Delete the support timer.
*/
ZlibTransformEventTimerKill(cd);
|
| ︙ | ︙ | |||
2968 2969 2970 2971 2972 2973 2974 |
if (cd->compDictObj) {
Tcl_DecrRefCount(cd->compDictObj);
cd->compDictObj = NULL;
}
Tcl_DStringFree(&cd->decompressed);
if (cd->inBuffer) {
| | | | | | 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 |
if (cd->compDictObj) {
Tcl_DecrRefCount(cd->compDictObj);
cd->compDictObj = NULL;
}
Tcl_DStringFree(&cd->decompressed);
if (cd->inBuffer) {
ckfree(cd->inBuffer);
cd->inBuffer = NULL;
}
if (cd->outBuffer) {
ckfree(cd->outBuffer);
cd->outBuffer = NULL;
}
ckfree(cd);
return result;
}
/*
*----------------------------------------------------------------------
*
* ZlibTransformInput --
*
* Reader filter that does decompression.
*
*----------------------------------------------------------------------
*/
static int
ZlibTransformInput(
void *instanceData,
char *buf,
int toRead,
int *errorCodePtr)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
Tcl_DriverInputProc *inProc =
Tcl_ChannelInputProc(Tcl_GetChannelType(cd->parent));
int readBytes, gotBytes, copied;
if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) {
return inProc(Tcl_GetChannelInstanceData(cd->parent), buf, toRead,
errorCodePtr);
|
| ︙ | ︙ | |||
3041 3042 3043 3044 3045 3046 3047 | readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, cd->readAheadLimit); /* * Three cases here: * 1. Got some data from the underlying channel (readBytes > 0) so * it should be fed through the decompression engine. | | | | 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 |
readBytes = Tcl_ReadRaw(cd->parent, cd->inBuffer, cd->readAheadLimit);
/*
* Three cases here:
* 1. Got some data from the underlying channel (readBytes > 0) so
* it should be fed through the decompression engine.
* 2. Got an error (readBytes < 0) which we should report up except
* for the case where we can convert it to a short read.
* 3. Got an end-of-data from EOF or blocking (readBytes == 0). If
* it is EOF, try flushing the data out of the decompressor.
*/
if (readBytes < 0) {
/* See ReflectInput() in tclIORTrans.c */
if (Tcl_InputBlocked(cd->parent) && (gotBytes > 0)) {
return gotBytes;
}
*errorCodePtr = Tcl_GetErrno();
|
| ︙ | ︙ | |||
3110 3111 3112 3113 3114 3115 3116 |
static int
ZlibTransformOutput(
void *instanceData,
const char *buf,
int toWrite,
int *errorCodePtr)
{
| | < | | 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 |
static int
ZlibTransformOutput(
void *instanceData,
const char *buf,
int toWrite,
int *errorCodePtr)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
Tcl_DriverOutputProc *outProc =
Tcl_ChannelOutputProc(Tcl_GetChannelType(cd->parent));
int e, produced;
Tcl_Obj *errObj;
if (cd->mode == TCL_ZLIB_STREAM_INFLATE) {
return outProc(Tcl_GetChannelInstanceData(cd->parent), buf, toWrite,
errorCodePtr);
}
|
| ︙ | ︙ | |||
3176 3177 3178 3179 3180 3181 3182 |
static int
ZlibTransformFlush(
Tcl_Interp *interp,
ZlibChannelData *cd,
int flushType)
{
| | < | 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 |
static int
ZlibTransformFlush(
Tcl_Interp *interp,
ZlibChannelData *cd,
int flushType)
{
int e, len;
cd->outStream.avail_in = 0;
do {
/*
* Get the bytes to go out of the compression engine.
*/
|
| ︙ | ︙ | |||
3233 3234 3235 3236 3237 3238 3239 |
static int
ZlibTransformSetOption( /* not used */
void *instanceData,
Tcl_Interp *interp,
const char *optionName,
const char *value)
{
| | > | > > | 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 |
static int
ZlibTransformSetOption( /* not used */
void *instanceData,
Tcl_Interp *interp,
const char *optionName,
const char *value)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
Tcl_DriverSetOptionProc *setOptionProc =
Tcl_ChannelSetOptionProc(Tcl_GetChannelType(cd->parent));
static const char *compressChanOptions = "dictionary flush";
static const char *gzipChanOptions = "flush";
static const char *decompressChanOptions = "dictionary limit";
static const char *gunzipChanOptions = "flush limit";
int haveFlushOpt = (cd->mode == TCL_ZLIB_STREAM_DEFLATE);
if (optionName && (strcmp(optionName, "-dictionary") == 0)
&& (cd->format != TCL_ZLIB_FORMAT_GZIP)) {
Tcl_Obj *compDictObj;
int code;
TclNewStringObj(compDictObj, value, strlen(value));
Tcl_IncrRefCount(compDictObj);
if (NULL == TclGetBytesFromObj(interp, compDictObj, NULL)) {
Tcl_DecrRefCount(compDictObj);
return TCL_ERROR;
}
if (cd->compDictObj) {
TclDecrRefCount(cd->compDictObj);
}
cd->compDictObj = compDictObj;
code = Z_OK;
if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) {
code = SetDeflateDictionary(&cd->outStream, compDictObj);
|
| ︙ | ︙ | |||
3346 3347 3348 3349 3350 3351 3352 |
static int
ZlibTransformGetOption(
void *instanceData,
Tcl_Interp *interp,
const char *optionName,
Tcl_DString *dsPtr)
{
| | | 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 |
static int
ZlibTransformGetOption(
void *instanceData,
Tcl_Interp *interp,
const char *optionName,
Tcl_DString *dsPtr)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
Tcl_DriverGetOptionProc *getOptionProc =
Tcl_ChannelGetOptionProc(Tcl_GetChannelType(cd->parent));
static const char *compressChanOptions = "checksum dictionary";
static const char *gzipChanOptions = "checksum";
static const char *decompressChanOptions = "checksum dictionary limit";
static const char *gunzipChanOptions = "checksum header limit";
|
| ︙ | ︙ | |||
3390 3391 3392 3393 3394 3395 3396 |
* Embedded NUL bytes are ok; they'll be C080-encoded.
*/
if (optionName == NULL) {
Tcl_DStringAppendElement(dsPtr, "-dictionary");
if (cd->compDictObj) {
Tcl_DStringAppendElement(dsPtr,
| | | | | | | 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 |
* Embedded NUL bytes are ok; they'll be C080-encoded.
*/
if (optionName == NULL) {
Tcl_DStringAppendElement(dsPtr, "-dictionary");
if (cd->compDictObj) {
Tcl_DStringAppendElement(dsPtr,
Tcl_GetString(cd->compDictObj));
} else {
Tcl_DStringAppendElement(dsPtr, "");
}
} else {
if (cd->compDictObj) {
int len;
const char *str = TclGetStringFromObj(cd->compDictObj, &len);
Tcl_DStringAppend(dsPtr, str, len);
}
return TCL_OK;
}
}
/*
* The "header" option, which is only valid on inflating gzip channels,
* reports the header that has been read from the start of the stream.
*/
if ((cd->flags & IN_HEADER) && ((optionName == NULL) ||
(strcmp(optionName, "-header") == 0))) {
Tcl_Obj *tmpObj = Tcl_NewObj();
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);
Tcl_DecrRefCount(tmpObj);
return TCL_OK;
}
}
|
| ︙ | ︙ | |||
3464 3465 3466 3467 3468 3469 3470 |
*/
static void
ZlibTransformWatch(
void *instanceData,
int mask)
{
| | | 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 |
*/
static void
ZlibTransformWatch(
void *instanceData,
int mask)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
Tcl_DriverWatchProc *watchProc;
/*
* This code is based on the code in tclIORTrans.c
*/
watchProc = Tcl_ChannelWatchProc(Tcl_GetChannelType(cd->parent));
|
| ︙ | ︙ | |||
3487 3488 3489 3490 3491 3492 3493 |
}
static int
ZlibTransformEventHandler(
void *instanceData,
int interestMask)
{
| | | | 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 |
}
static int
ZlibTransformEventHandler(
void *instanceData,
int interestMask)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
ZlibTransformEventTimerKill(cd);
return interestMask;
}
static inline void
ZlibTransformEventTimerKill(
ZlibChannelData *cd)
{
if (cd->timer != NULL) {
Tcl_DeleteTimerHandler(cd->timer);
cd->timer = NULL;
}
}
static void
ZlibTransformTimerRun(
void *clientData)
{
ZlibChannelData *cd = (ZlibChannelData *)clientData;
cd->timer = NULL;
Tcl_NotifyChannel(cd->chan, TCL_READABLE);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
3530 3531 3532 3533 3534 3535 3536 |
static int
ZlibTransformGetHandle(
void *instanceData,
int direction,
void **handlePtr)
{
| | | | 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 |
static int
ZlibTransformGetHandle(
void *instanceData,
int direction,
void **handlePtr)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
return Tcl_GetChannelHandle(cd->parent, direction, handlePtr);
}
/*
*----------------------------------------------------------------------
*
* ZlibTransformBlockMode --
*
* We need to keep track of the blocking mode; it changes our behavior.
*
*----------------------------------------------------------------------
*/
static int
ZlibTransformBlockMode(
void *instanceData,
int mode)
{
ZlibChannelData *cd = (ZlibChannelData *)instanceData;
if (mode == TCL_MODE_NONBLOCKING) {
cd->flags |= ASYNC;
} else {
cd->flags &= ~ASYNC;
}
return TCL_OK;
|
| ︙ | ︙ | |||
3600 3601 3602 3603 3604 3605 3606 |
Tcl_Obj *gzipHeaderDictPtr, /* A description of header to use, or NULL to
* use a default. Ignored if not compressing
* to produce gzip-format data. */
Tcl_Obj *compDictObj) /* Byte-array object containing compression
* dictionary (not dictObj!) to use if
* necessary. */
{
| | | 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 |
Tcl_Obj *gzipHeaderDictPtr, /* A description of header to use, or NULL to
* use a default. Ignored if not compressing
* to produce gzip-format data. */
Tcl_Obj *compDictObj) /* Byte-array object containing compression
* dictionary (not dictObj!) to use if
* necessary. */
{
ZlibChannelData *cd = (ZlibChannelData *)ckalloc(sizeof(ZlibChannelData));
Tcl_Channel chan;
int wbits = 0;
if (mode != TCL_ZLIB_STREAM_DEFLATE && mode != TCL_ZLIB_STREAM_INFLATE) {
Tcl_Panic("unknown mode: %d", mode);
}
|
| ︙ | ︙ | |||
3660 3661 3662 3663 3664 3665 3666 |
*/
if (mode == TCL_ZLIB_STREAM_INFLATE) {
if (inflateInit2(&cd->inStream, wbits) != Z_OK) {
goto error;
}
cd->inAllocated = DEFAULT_BUFFER_SIZE;
| | | | 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 |
*/
if (mode == TCL_ZLIB_STREAM_INFLATE) {
if (inflateInit2(&cd->inStream, wbits) != Z_OK) {
goto error;
}
cd->inAllocated = DEFAULT_BUFFER_SIZE;
cd->inBuffer = (char *)ckalloc(cd->inAllocated);
if (cd->flags & IN_HEADER) {
if (inflateGetHeader(&cd->inStream, &cd->inHeader.header) != Z_OK) {
goto error;
}
}
if (cd->format == TCL_ZLIB_FORMAT_RAW && cd->compDictObj) {
if (SetInflateDictionary(&cd->inStream, cd->compDictObj) != Z_OK) {
goto error;
}
}
} else {
if (deflateInit2(&cd->outStream, level, Z_DEFLATED, wbits,
MAX_MEM_LEVEL, Z_DEFAULT_STRATEGY) != Z_OK) {
goto error;
}
cd->outAllocated = DEFAULT_BUFFER_SIZE;
cd->outBuffer = (char *)ckalloc(cd->outAllocated);
if (cd->flags & OUT_HEADER) {
if (deflateSetHeader(&cd->outStream, &cd->outHeader.header) != Z_OK) {
goto error;
}
}
if (cd->compDictObj) {
if (SetDeflateDictionary(&cd->outStream, cd->compDictObj) != Z_OK) {
|
| ︙ | ︙ | |||
3704 3705 3706 3707 3708 3709 3710 |
cd->chan = chan;
cd->parent = Tcl_GetStackedChannel(chan);
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
return chan;
error:
if (cd->inBuffer) {
| | | | | 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 |
cd->chan = chan;
cd->parent = Tcl_GetStackedChannel(chan);
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
return chan;
error:
if (cd->inBuffer) {
ckfree(cd->inBuffer);
inflateEnd(&cd->inStream);
}
if (cd->outBuffer) {
ckfree(cd->outBuffer);
deflateEnd(&cd->outStream);
}
if (cd->compDictObj) {
Tcl_DecrRefCount(cd->compDictObj);
}
ckfree(cd);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* ResultCopy --
|
| ︙ | ︙ | |||
3740 3741 3742 3743 3744 3745 3746 |
*----------------------------------------------------------------------
*/
static inline int
ResultCopy(
ZlibChannelData *cd, /* The location of the buffer to read from. */
char *buf, /* The buffer to copy into */
| | | | 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 |
*----------------------------------------------------------------------
*/
static inline int
ResultCopy(
ZlibChannelData *cd, /* The location of the buffer to read from. */
char *buf, /* The buffer to copy into */
int toRead) /* Number of requested bytes */
{
int have = Tcl_DStringLength(&cd->decompressed);
if (have == 0) {
/*
* Nothing to copy in the case of an empty buffer.
*/
return 0;
|
| ︙ | ︙ | |||
3842 3843 3844 3845 3846 3847 3848 | /* * The cases where we're definitely done. */ if (((flush == Z_SYNC_FLUSH) && (e == Z_BUF_ERROR)) || (e == Z_STREAM_END) | | | 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 |
/*
* The cases where we're definitely done.
*/
if (((flush == Z_SYNC_FLUSH) && (e == Z_BUF_ERROR))
|| (e == Z_STREAM_END)
|| (e == Z_OK && written == 0)) {
return TCL_OK;
}
/*
* Z_BUF_ERROR can be ignored as per http://www.zlib.net/zlib_how.html
*
* Just indicates that the zlib couldn't consume input/produce output,
|
| ︙ | ︙ | |||
3928 3929 3930 3931 3932 3933 3934 |
TclRegisterCommandTypeName(ZlibStreamCmd, "zlibStream");
/*
* Formally provide the package as a Tcl built-in.
*/
| | | 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 |
TclRegisterCommandTypeName(ZlibStreamCmd, "zlibStream");
/*
* Formally provide the package as a Tcl built-in.
*/
return Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION);
}
/*
*----------------------------------------------------------------------
* Stubs used when a suitable zlib installation was not found during
* configure.
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
4003 4004 4005 4006 4007 4008 4009 |
return TCL_OK;
}
int
Tcl_ZlibStreamGet(
Tcl_ZlibStream zshandle,
Tcl_Obj *data,
| | | 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 |
return TCL_OK;
}
int
Tcl_ZlibStreamGet(
Tcl_ZlibStream zshandle,
Tcl_Obj *data,
int count)
{
return TCL_OK;
}
int
Tcl_ZlibDeflate(
Tcl_Interp *interp,
|
| ︙ | ︙ | |||
4028 4029 4030 4031 4032 4033 4034 |
}
int
Tcl_ZlibInflate(
Tcl_Interp *interp,
int format,
Tcl_Obj *data,
| | | | | | | 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 |
}
int
Tcl_ZlibInflate(
Tcl_Interp *interp,
int format,
Tcl_Obj *data,
int bufferSize,
Tcl_Obj *gzipHeaderDictObj)
{
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("unimplemented", -1));
Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
}
return TCL_ERROR;
}
unsigned int
Tcl_ZlibCRC32(
unsigned int crc,
const char *buf,
int len)
{
return 0;
}
unsigned int
Tcl_ZlibAdler32(
unsigned int adler,
const char *buf,
int len)
{
return 0;
}
void
Tcl_ZlibStreamSetCompressionDictionary(
Tcl_ZlibStream zshandle,
|
| ︙ | ︙ |
Deleted generic/tommath.h.
|
| < |
Changes to library/clock.tcl.
| ︙ | ︙ | |||
3448 3449 3450 3451 3452 3453 3454 |
# arbitrary start time in front of the transitions.
binary scan $d @${seek}${iformat}${nTime}c${nTime} times tempCodes
incr seek [expr { ($ilen + 1) * $nTime }]
set times [linsert $times 0 $MINWIDE]
set codes {}
foreach c $tempCodes {
| | | 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 |
# arbitrary start time in front of the transitions.
binary scan $d @${seek}${iformat}${nTime}c${nTime} times tempCodes
incr seek [expr { ($ilen + 1) * $nTime }]
set times [linsert $times 0 $MINWIDE]
set codes {}
foreach c $tempCodes {
lappend codes [expr { $c & 0xFF }]
}
set codes [linsert $codes 0 0]
# Next come ${nType} time type descriptions, each of which has an offset
# (seconds east of GMT), a DST indicator, and an index into the
# abbreviation text.
|
| ︙ | ︙ |
Added library/cookiejar/cookiejar.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 |
# cookiejar.tcl --
#
# Implementation of an HTTP cookie storage engine using SQLite. The
# implementation is done as a TclOO class, and includes a punycode
# encoder and decoder (though only the encoder is currently used).
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
# Dependencies
package require Tcl 8.6
package require http 2.8.4
package require sqlite3
package require tcl::idna 1.0
#
# Configuration for the cookiejar package, plus basic support procedures.
#
# This is the class that we are creating
if {![llength [info commands ::http::cookiejar]]} {
::oo::class create ::http::cookiejar
}
namespace eval [info object namespace ::http::cookiejar] {
proc setInt {*var val} {
upvar 1 ${*var} var
if {[catch {incr dummy $val} msg]} {
return -code error $msg
}
set var $val
}
proc setInterval {trigger *var val} {
upvar 1 ${*var} var
if {![string is integer -strict $val] || $val < 1} {
return -code error "expected positive integer but got \"$val\""
}
set var $val
{*}$trigger
}
proc setBool {*var val} {
upvar 1 ${*var} var
if {[catch {if {$val} {}} msg]} {
return -code error $msg
}
set var [expr {!!$val}]
}
proc setLog {*var val} {
upvar 1 ${*var} var
set var [::tcl::prefix match -message "log level" \
{debug info warn error} $val]
}
# Keep this in sync with pkgIndex.tcl and with the install directories in
# Makefiles
variable version 0.2.0
variable domainlist \
http://publicsuffix.org/list/effective_tld_names.dat
variable domainfile \
[file join [file dirname [info script]] effective_tld_names.txt.gz]
# The list is directed to from http://publicsuffix.org/list/
variable loglevel info
variable vacuumtrigger 200
variable retainlimit 100
variable offline false
variable purgeinterval 60000
variable refreshinterval 10000000
variable domaincache {}
# Some support procedures, none particularly useful in general
namespace eval support {
# Set up a logger if the http package isn't actually loaded yet.
if {![llength [info commands ::http::Log]]} {
proc ::http::Log args {
# Do nothing by default...
}
}
namespace export *
proc locn {secure domain path {key ""}} {
if {$key eq ""} {
format "%s://%s%s" [expr {$secure?"https":"http"}] \
[::tcl::idna encode $domain] $path
} else {
format "%s://%s%s?%s" \
[expr {$secure?"https":"http"}] [::tcl::idna encode $domain] \
$path $key
}
}
proc splitDomain domain {
set pieces [split $domain "."]
for {set i [llength $pieces]} {[incr i -1] >= 0} {} {
lappend result [join [lrange $pieces $i end] "."]
}
return $result
}
proc splitPath path {
set pieces [split [string trimleft $path "/"] "/"]
set result /
for {set j 0} {$j < [llength $pieces]} {incr j} {
lappend result /[join [lrange $pieces 0 $j] "/"]
}
return $result
}
proc isoNow {} {
set ms [clock milliseconds]
set ts [expr {$ms / 1000}]
set ms [format %03d [expr {$ms % 1000}]]
clock format $ts -format "%Y%m%dT%H%M%S.${ms}Z" -gmt 1
}
proc log {level msg args} {
namespace upvar [info object namespace ::http::cookiejar] \
loglevel loglevel
set who [uplevel 1 self class]
set mth [uplevel 1 self method]
set map {debug 0 info 1 warn 2 error 3}
if {[string map $map $level] >= [string map $map $loglevel]} {
set msg [format $msg {*}$args]
set LVL [string toupper $level]
::http::Log "[isoNow] $LVL $who $mth - $msg"
}
}
}
}
# Now we have enough information to provide the package.
package provide cookiejar \
[set [info object namespace ::http::cookiejar]::version]
# The implementation of the cookiejar package
::oo::define ::http::cookiejar {
self {
method configure {{optionName "\u0000\u0000"} {optionValue "\u0000\u0000"}} {
set tbl {
-domainfile {domainfile set}
-domainlist {domainlist set}
-domainrefresh {refreshinterval setInterval}
-loglevel {loglevel setLog}
-offline {offline setBool}
-purgeold {purgeinterval setInterval}
-retain {retainlimit setInt}
-vacuumtrigger {vacuumtrigger setInt}
}
dict lappend tbl -domainrefresh [namespace code {
my IntervalTrigger PostponeRefresh
}]
dict lappend tbl -purgeold [namespace code {
my IntervalTrigger PostponePurge
}]
if {$optionName eq "\u0000\u0000"} {
return [dict keys $tbl]
}
set opt [::tcl::prefix match -message "option" \
[dict keys $tbl] $optionName]
set setter [lassign [dict get $tbl $opt] varname]
namespace upvar [namespace current] $varname var
if {$optionValue ne "\u0000\u0000"} {
{*}$setter var $optionValue
}
return $var
}
method IntervalTrigger {method} {
# TODO: handle subclassing
foreach obj [info class instances [self]] {
[info object namespace $obj]::my $method
}
}
}
variable purgeTimer deletions refreshTimer
constructor {{path ""}} {
namespace import [info object namespace [self class]]::support::*
if {$path eq ""} {
sqlite3 [namespace current]::db :memory:
set storeorigin "constructed cookie store in memory"
} else {
sqlite3 [namespace current]::db $path
db timeout 500
set storeorigin "loaded cookie store from $path"
}
set deletions 0
db transaction {
db eval {
--;# Store the persistent cookies in this table.
--;# Deletion policy: once they expire, or if explicitly
--;# killed.
CREATE TABLE IF NOT EXISTS persistentCookies (
id INTEGER PRIMARY KEY,
secure INTEGER NOT NULL,
domain TEXT NOT NULL COLLATE NOCASE,
path TEXT NOT NULL,
key TEXT NOT NULL,
value TEXT NOT NULL,
originonly INTEGER NOT NULL,
expiry INTEGER NOT NULL,
lastuse INTEGER NOT NULL,
creation INTEGER NOT NULL);
CREATE UNIQUE INDEX IF NOT EXISTS persistentUnique
ON persistentCookies (domain, path, key);
CREATE INDEX IF NOT EXISTS persistentLookup
ON persistentCookies (domain, path);
--;# Store the session cookies in this table.
--;# Deletion policy: at cookiejar instance deletion, if
--;# explicitly killed, or if the number of session cookies is
--;# too large and the cookie has not been used recently.
CREATE TEMP TABLE sessionCookies (
id INTEGER PRIMARY KEY,
secure INTEGER NOT NULL,
domain TEXT NOT NULL COLLATE NOCASE,
path TEXT NOT NULL,
key TEXT NOT NULL,
originonly INTEGER NOT NULL,
value TEXT NOT NULL,
lastuse INTEGER NOT NULL,
creation INTEGER NOT NULL);
CREATE UNIQUE INDEX sessionUnique
ON sessionCookies (domain, path, key);
CREATE INDEX sessionLookup ON sessionCookies (domain, path);
--;# View to allow for simple looking up of a cookie.
--;# Deletion policy: NOT SUPPORTED via this view.
CREATE TEMP VIEW cookies AS
SELECT id, domain, (
CASE originonly WHEN 1 THEN path ELSE '.' || path END
) AS path, key, value, secure, 1 AS persistent
FROM persistentCookies
UNION
SELECT id, domain, (
CASE originonly WHEN 1 THEN path ELSE '.' || path END
) AS path, key, value, secure, 0 AS persistent
FROM sessionCookies;
--;# Encoded domain permission policy; if forbidden is 1, no
--;# cookie may be ever set for the domain, and if forbidden
--;# is 0, cookies *may* be created for the domain (overriding
--;# the forbiddenSuper table).
--;# Deletion policy: normally not modified.
CREATE TABLE IF NOT EXISTS domains (
domain TEXT PRIMARY KEY NOT NULL,
forbidden INTEGER NOT NULL);
--;# Domains that may not have a cookie defined for direct
--;# child domains of them.
--;# Deletion policy: normally not modified.
CREATE TABLE IF NOT EXISTS forbiddenSuper (
domain TEXT PRIMARY KEY);
--;# When we last retrieved the domain list.
CREATE TABLE IF NOT EXISTS domainCacheMetadata (
id INTEGER PRIMARY KEY,
retrievalDate INTEGER,
installDate INTEGER);
}
set cookieCount "no"
db eval {
SELECT COUNT(*) AS cookieCount FROM persistentCookies
}
log info "%s with %s entries" $storeorigin $cookieCount
my PostponePurge
if {$path ne ""} {
if {[db exists {SELECT 1 FROM domains}]} {
my RefreshDomains
} else {
my InitDomainList
my PostponeRefresh
}
} else {
set data [my GetDomainListOffline metadata]
my InstallDomainData $data $metadata
my PostponeRefresh
}
}
}
method PostponePurge {} {
namespace upvar [info object namespace [self class]] \
purgeinterval interval
catch {after cancel $purgeTimer}
set purgeTimer [after $interval [namespace code {my PurgeCookies}]]
}
method PostponeRefresh {} {
namespace upvar [info object namespace [self class]] \
refreshinterval interval
catch {after cancel $refreshTimer}
set refreshTimer [after $interval [namespace code {my RefreshDomains}]]
}
method RefreshDomains {} {
# TODO: domain list refresh policy
my PostponeRefresh
}
method HttpGet {url {timeout 0} {maxRedirects 5}} {
for {set r 0} {$r < $maxRedirects} {incr r} {
set tok [::http::geturl $url -timeout $timeout]
try {
if {[::http::status $tok] eq "timeout"} {
return -code error "connection timed out"
} elseif {[::http::ncode $tok] == 200} {
return [::http::data $tok]
} elseif {[::http::ncode $tok] >= 400} {
return -code error [::http::error $tok]
} elseif {[dict exists [::http::meta $tok] Location]} {
set url [dict get [::http::meta $tok] Location]
continue
}
return -code error \
"unexpected state: [::http::code $tok]"
} finally {
::http::cleanup $tok
}
}
return -code error "too many redirects"
}
method GetDomainListOnline {metaVar} {
upvar 1 $metaVar meta
namespace upvar [info object namespace [self class]] \
domainlist url domaincache cache
lassign $cache when data
if {$when > [clock seconds] - 3600} {
log debug "using cached value created at %s" \
[clock format $when -format {%Y%m%dT%H%M%SZ} -gmt 1]
dict set meta retrievalDate $when
return $data
}
log debug "loading domain list from %s" $url
try {
set when [clock seconds]
set data [my HttpGet $url]
set cache [list $when $data]
# TODO: Should we use the Last-Modified header instead?
dict set meta retrievalDate $when
return $data
} on error msg {
log error "failed to fetch list of forbidden cookie domains from %s: %s" \
$url $msg
return {}
}
}
method GetDomainListOffline {metaVar} {
upvar 1 $metaVar meta
namespace upvar [info object namespace [self class]] \
domainfile filename
log debug "loading domain list from %s" $filename
try {
set f [open $filename]
try {
if {[string match *.gz $filename]} {
zlib push gunzip $f
}
fconfigure $f -encoding utf-8
dict set meta retrievalDate [file mtime $filename]
return [read $f]
} finally {
close $f
}
} on error {msg opt} {
log error "failed to read list of forbidden cookie domains from %s: %s" \
$filename $msg
return -options $opt $msg
}
}
method InitDomainList {} {
namespace upvar [info object namespace [self class]] \
offline offline
if {!$offline} {
try {
set data [my GetDomainListOnline metadata]
if {[string length $data]} {
my InstallDomainData $data $metadata
return
}
} on error {} {
log warn "attempting to fall back to built in version"
}
}
set data [my GetDomainListOffline metadata]
my InstallDomainData $data $metadata
}
method InstallDomainData {data meta} {
set n [db total_changes]
db transaction {
foreach line [split $data "\n"] {
if {[string trim $line] eq ""} {
continue
} elseif {[string match //* $line]} {
continue
} elseif {[string match !* $line]} {
set line [string range $line 1 end]
set idna [string tolower [::tcl::idna encode $line]]
set utf [::tcl::idna decode [string tolower $line]]
db eval {
INSERT OR REPLACE INTO domains (domain, forbidden)
VALUES ($utf, 0);
}
if {$idna ne $utf} {
db eval {
INSERT OR REPLACE INTO domains (domain, forbidden)
VALUES ($idna, 0);
}
}
} else {
if {[string match {\*.*} $line]} {
set line [string range $line 2 end]
set idna [string tolower [::tcl::idna encode $line]]
set utf [::tcl::idna decode [string tolower $line]]
db eval {
INSERT OR REPLACE INTO forbiddenSuper (domain)
VALUES ($utf);
}
if {$idna ne $utf} {
db eval {
INSERT OR REPLACE INTO forbiddenSuper (domain)
VALUES ($idna);
}
}
} else {
set idna [string tolower [::tcl::idna encode $line]]
set utf [::tcl::idna decode [string tolower $line]]
}
db eval {
INSERT OR REPLACE INTO domains (domain, forbidden)
VALUES ($utf, 1);
}
if {$idna ne $utf} {
db eval {
INSERT OR REPLACE INTO domains (domain, forbidden)
VALUES ($idna, 1);
}
}
}
if {$utf ne [::tcl::idna decode [string tolower $idna]]} {
log warn "mismatch in IDNA handling for %s (%d, %s, %s)" \
$idna $line $utf [::tcl::idna decode $idna]
}
}
dict with meta {
set installDate [clock seconds]
db eval {
INSERT OR REPLACE INTO domainCacheMetadata
(id, retrievalDate, installDate)
VALUES (1, $retrievalDate, $installDate);
}
}
}
set n [expr {[db total_changes] - $n}]
log info "constructed domain info with %d entries" $n
}
# This forces the rebuild of the domain data, loading it from
method forceLoadDomainData {} {
db transaction {
db eval {
DELETE FROM domains;
DELETE FROM forbiddenSuper;
INSERT OR REPLACE INTO domainCacheMetadata
(id, retrievalDate, installDate)
VALUES (1, -1, -1);
}
my InitDomainList
}
}
destructor {
catch {
after cancel $purgeTimer
}
catch {
after cancel $refreshTimer
}
catch {
db close
}
return
}
method GetCookiesForHostAndPath {listVar secure host path fullhost} {
upvar 1 $listVar result
log debug "check for cookies for %s" [locn $secure $host $path]
set exact [expr {$host eq $fullhost}]
db eval {
SELECT key, value FROM persistentCookies
WHERE domain = $host AND path = $path AND secure <= $secure
AND (NOT originonly OR domain = $fullhost)
AND originonly = $exact
} {
lappend result $key $value
db eval {
UPDATE persistentCookies SET lastuse = $now WHERE id = $id
}
}
set now [clock seconds]
db eval {
SELECT id, key, value FROM sessionCookies
WHERE domain = $host AND path = $path AND secure <= $secure
AND (NOT originonly OR domain = $fullhost)
AND originonly = $exact
} {
lappend result $key $value
db eval {
UPDATE sessionCookies SET lastuse = $now WHERE id = $id
}
}
}
method getCookies {proto host path} {
set result {}
set paths [splitPath $path]
if {[regexp {[^0-9.]} $host]} {
set domains [splitDomain [string tolower [::tcl::idna encode $host]]]
} else {
# Ugh, it's a numeric domain! Restrict it to just itself...
set domains [list $host]
}
set secure [string equal -nocase $proto "https"]
# Open question: how to move these manipulations into the database
# engine (if that's where they *should* be).
#
# Suggestion from kbk:
#LENGTH(theColumn) <= LENGTH($queryStr) AND
#SUBSTR(theColumn, LENGTH($queryStr) LENGTH(theColumn)+1) = $queryStr
#
# However, we instead do most of the work in Tcl because that lets us
# do the splitting exactly right, and it's far easier to work with
# strings in Tcl than in SQL.
db transaction {
foreach domain $domains {
foreach p $paths {
my GetCookiesForHostAndPath result $secure $domain $p $host
}
}
return $result
}
}
method BadDomain options {
if {![dict exists $options domain]} {
log error "no domain present in options"
return 0
}
dict with options {}
if {$domain ne $origin} {
log debug "cookie domain varies from origin (%s, %s)" \
$domain $origin
if {[string match .* $domain]} {
set dotd $domain
} else {
set dotd .$domain
}
if {![string equal -length [string length $dotd] \
[string reverse $dotd] [string reverse $origin]]} {
log warn "bad cookie: domain not suffix of origin"
return 1
}
}
if {![regexp {[^0-9.]} $domain]} {
if {$domain eq $origin} {
# May set for itself
return 0
}
log warn "bad cookie: for a numeric address"
return 1
}
db eval {
SELECT forbidden FROM domains WHERE domain = $domain
} {
if {$forbidden} {
log warn "bad cookie: for a forbidden address"
}
return $forbidden
}
if {[regexp {^[^.]+\.(.+)$} $domain -> super] && [db exists {
SELECT 1 FROM forbiddenSuper WHERE domain = $super
}]} then {
log warn "bad cookie: for a forbidden address"
return 1
}
return 0
}
# A defined extension point to allow users to easily impose extra policies
# on whether to accept cookies from a particular domain and path.
method policyAllow {operation domain path} {
return true
}
method storeCookie {options} {
db transaction {
if {[my BadDomain $options]} {
return
}
set now [clock seconds]
set persistent [dict exists $options expires]
dict with options {}
if {!$persistent} {
if {![my policyAllow session $domain $path]} {
log warn "bad cookie: $domain prohibited by user policy"
return
}
db eval {
INSERT OR REPLACE INTO sessionCookies (
secure, domain, path, key, value, originonly, creation,
lastuse)
VALUES ($secure, $domain, $path, $key, $value, $hostonly,
$now, $now);
DELETE FROM persistentCookies
WHERE domain = $domain AND path = $path AND key = $key
AND secure <= $secure AND originonly = $hostonly
}
incr deletions [db changes]
log debug "defined session cookie for %s" \
[locn $secure $domain $path $key]
} elseif {$expires < $now} {
if {![my policyAllow delete $domain $path]} {
log warn "bad cookie: $domain prohibited by user policy"
return
}
db eval {
DELETE FROM persistentCookies
WHERE domain = $domain AND path = $path AND key = $key
AND secure <= $secure AND originonly = $hostonly
}
set del [db changes]
db eval {
DELETE FROM sessionCookies
WHERE domain = $domain AND path = $path AND key = $key
AND secure <= $secure AND originonly = $hostonly
}
incr deletions [incr del [db changes]]
log debug "deleted %d cookies for %s" \
$del [locn $secure $domain $path $key]
} else {
if {![my policyAllow set $domain $path]} {
log warn "bad cookie: $domain prohibited by user policy"
return
}
db eval {
INSERT OR REPLACE INTO persistentCookies (
secure, domain, path, key, value, originonly, expiry,
creation, lastuse)
VALUES ($secure, $domain, $path, $key, $value, $hostonly,
$expires, $now, $now);
DELETE FROM sessionCookies
WHERE domain = $domain AND path = $path AND key = $key
AND secure <= $secure AND originonly = $hostonly
}
incr deletions [db changes]
log debug "defined persistent cookie for %s, expires at %s" \
[locn $secure $domain $path $key] \
[clock format $expires]
}
}
}
method PurgeCookies {} {
namespace upvar [info object namespace [self class]] \
vacuumtrigger trigger retainlimit retain
my PostponePurge
set now [clock seconds]
log debug "purging cookies that expired before %s" [clock format $now]
db transaction {
db eval {
DELETE FROM persistentCookies WHERE expiry < $now
}
incr deletions [db changes]
db eval {
DELETE FROM persistentCookies WHERE id IN (
SELECT id FROM persistentCookies ORDER BY lastuse ASC
LIMIT -1 OFFSET $retain)
}
incr deletions [db changes]
db eval {
DELETE FROM sessionCookies WHERE id IN (
SELECT id FROM sessionCookies ORDER BY lastuse
LIMIT -1 OFFSET $retain)
}
incr deletions [db changes]
}
# Once we've deleted a fair bit, vacuum the database. Must be done
# outside a transaction.
if {$deletions > $trigger} {
set deletions 0
log debug "vacuuming cookie database"
catch {
db eval {
VACUUM
}
}
}
}
forward Database db
method lookup {{host ""} {key ""}} {
set host [string tolower [::tcl::idna encode $host]]
db transaction {
if {$host eq ""} {
set result {}
db eval {
SELECT DISTINCT domain FROM cookies
ORDER BY domain
} {
lappend result [::tcl::idna decode [string tolower $domain]]
}
return $result
} elseif {$key eq ""} {
set result {}
db eval {
SELECT DISTINCT key FROM cookies
WHERE domain = $host
ORDER BY key
} {
lappend result $key
}
return $result
} else {
db eval {
SELECT value FROM cookies
WHERE domain = $host AND key = $key
LIMIT 1
} {
return $value
}
return -code error "no such key for that host"
}
}
}
}
# Local variables:
# mode: tcl
# fill-column: 78
# End:
|
Added library/cookiejar/effective_tld_names.txt.gz.
cannot compute difference between binary files
Added library/cookiejar/idna.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 |
# 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 (c) 2014 Donal K. Fellows
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
namespace eval ::tcl::idna {
namespace ensemble create -command puny -map {
encode punyencode
decode punydecode
}
namespace ensemble create -command ::tcl::idna -map {
encode IDNAencode
decode IDNAdecode
puny puny
version {::apply {{} {package present tcl::idna} ::}}
}
proc IDNAencode hostname {
set parts {}
# Split term from RFC 3490, Sec 3.1
foreach part [split $hostname "\u002E\u3002\uFF0E\uFF61"] {
if {[regexp {[^-A-Za-z0-9]} $part]} {
if {[regexp {[^-A-Za-z0-9\u00a1-\uffff]} $part ch]} {
scan $ch %c c
if {$ch < "!" || $ch > "~"} {
set ch [format "\\u%04x" $c]
}
throw [list IDNA INVALID_NAME_CHARACTER $ch] \
"bad character \"$ch\" in DNS name"
}
set part xn--[punyencode $part]
# Length restriction from RFC 5890, Sec 2.3.1
if {[string length $part] > 63} {
throw [list IDNA OVERLONG_PART $part] \
"hostname part too long"
}
}
lappend parts $part
}
return [join $parts .]
}
proc IDNAdecode hostname {
set parts {}
# Split term from RFC 3490, Sec 3.1
foreach part [split $hostname "\u002E\u3002\uFF0E\uFF61"] {
if {[string match -nocase "xn--*" $part]} {
set part [punydecode [string range $part 4 end]]
}
lappend parts $part
}
return [join $parts .]
}
variable digits [split "abcdefghijklmnopqrstuvwxyz0123456789" ""]
# Bootstring parameters for Punycode
variable base 36
variable tmin 1
variable tmax 26
variable skew 38
variable damp 700
variable initial_bias 72
variable initial_n 0x80
variable max_codepoint 0x10FFFF
proc adapt {delta first numchars} {
variable base
variable tmin
variable tmax
variable damp
variable skew
set delta [expr {$delta / ($first ? $damp : 2)}]
incr delta [expr {$delta / $numchars}]
set k 0
while {$delta > ($base - $tmin) * $tmax / 2} {
set delta [expr {$delta / ($base-$tmin)}]
incr k $base
}
return [expr {$k + ($base-$tmin+1) * $delta / ($delta+$skew)}]
}
# Main punycode encoding function
proc punyencode {string {case ""}} {
variable digits
variable tmin
variable tmax
variable base
variable initial_n
variable initial_bias
if {![string is boolean $case]} {
return -code error "\"$case\" must be boolean"
}
set in {}
foreach char [set string [split $string ""]] {
scan $char "%c" ch
lappend in $ch
}
set output {}
# Initialize the state:
set n $initial_n
set delta 0
set bias $initial_bias
# Handle the basic code points:
foreach ch $string {
if {$ch < "\u0080"} {
if {$case eq ""} {
append output $ch
} elseif {[string is true $case]} {
append output [string toupper $ch]
} elseif {[string is false $case]} {
append output [string tolower $ch]
}
}
}
set b [string length $output]
# h is the number of code points that have been handled, b is the
# number of basic code points.
if {$b > 0} {
append output "-"
}
# Main encoding loop:
for {set h $b} {$h < [llength $in]} {incr delta; incr n} {
# All non-basic code points < n have been handled already. Find
# the next larger one:
set m inf
foreach ch $in {
if {$ch >= $n && $ch < $m} {
set m $ch
}
}
# Increase delta enough to advance the decoder's <n,i> state to
# <m,0>, but guard against overflow:
if {$m-$n > (0xFFFFFFFF-$delta)/($h+1)} {
throw {PUNYCODE OVERFLOW} "overflow in delta computation"
}
incr delta [expr {($m-$n) * ($h+1)}]
set n $m
foreach ch $in {
if {$ch < $n && ([incr delta] & 0xFFFFFFFF) == 0} {
throw {PUNYCODE OVERFLOW} "overflow in delta computation"
}
if {$ch != $n} {
continue
}
# Represent delta as a generalized variable-length integer:
for {set q $delta; set k $base} true {incr k $base} {
set t [expr {min(max($k-$bias, $tmin), $tmax)}]
if {$q < $t} {
break
}
append output \
[lindex $digits [expr {$t + ($q-$t)%($base-$t)}]]
set q [expr {($q-$t) / ($base-$t)}]
}
append output [lindex $digits $q]
set bias [adapt $delta [expr {$h==$b}] [expr {$h+1}]]
set delta 0
incr h
}
}
return $output
}
# Main punycode decode function
proc punydecode {string {case ""}} {
variable tmin
variable tmax
variable base
variable initial_n
variable initial_bias
variable max_codepoint
if {![string is boolean $case]} {
return -code error "\"$case\" must be boolean"
}
# Initialize the state:
set n $initial_n
set i 0
set first 1
set bias $initial_bias
# Split the string into the "real" ASCII characters and the ones to
# feed into the main decoder. Note that we don't need to check the
# result of [regexp] because that RE will technically match any string
# at all.
regexp {^(?:(.*)-)?([^-]*)$} $string -> pre post
if {[string is true -strict $case]} {
set pre [string toupper $pre]
} elseif {[string is false -strict $case]} {
set pre [string tolower $pre]
}
set output [split $pre ""]
set out [llength $output]
# Main decoding loop:
for {set in 0} {$in < [string length $post]} {incr in} {
# Decode a generalized variable-length integer into delta, which
# gets added to i. The overflow checking is easier if we increase
# i as we go, then subtract off its starting value at the end to
# obtain delta.
for {set oldi $i; set w 1; set k $base} 1 {incr in} {
if {[set ch [string index $post $in]] eq ""} {
throw {PUNYCODE BAD_INPUT LENGTH} "exceeded input data"
}
if {[string match -nocase {[a-z]} $ch]} {
scan [string toupper $ch] %c digit
incr digit -65
} elseif {[string match {[0-9]} $ch]} {
set digit [expr {$ch + 26}]
} else {
throw {PUNYCODE BAD_INPUT CHAR} \
"bad decode character \"$ch\""
}
incr i [expr {$digit * $w}]
set t [expr {min(max($tmin, $k-$bias), $tmax)}]
if {$digit < $t} {
set bias [adapt [expr {$i-$oldi}] $first [incr out]]
set first 0
break
}
if {[set w [expr {$w * ($base - $t)}]] > 0x7FFFFFFF} {
throw {PUNYCODE OVERFLOW} \
"excessively large integer computed in digit decode"
}
incr k $base
}
# i was supposed to wrap around from out+1 to 0, incrementing n
# each time, so we'll fix that now:
if {[incr n [expr {$i / $out}]] > 0x7FFFFFFF} {
throw {PUNYCODE OVERFLOW} \
"excessively large integer computed in character choice"
} elseif {$n > $max_codepoint} {
if {$n >= 0x00D800 && $n < 0x00E000} {
# Bare surrogate?!
throw {PUNYCODE NON_BMP} \
[format "unsupported character U+%06x" $n]
}
throw {PUNYCODE NON_UNICODE} "bad codepoint $n"
}
set i [expr {$i % $out}]
# Insert n at position i of the output:
set output [linsert $output $i [format "%c" $n]]
incr i
}
return [join $output ""]
}
}
package provide tcl::idna 1.0.1
# Local variables:
# mode: tcl
# fill-column: 78
# End:
|
Added library/cookiejar/pkgIndex.tcl.
> > > | 1 2 3 |
if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
package ifneeded cookiejar 0.2.0 [list source [file join $dir cookiejar.tcl]]
package ifneeded tcl::idna 1.0.1 [list source [file join $dir idna.tcl]]
|
Changes to library/dde/pkgIndex.tcl.
|
| | | | | | 1 2 3 4 5 6 7 |
if {![package vsatisfies [package provide Tcl] 8.5-]} return
if {[info sharedlibextension] != ".dll"} return
if {[::tcl::pkgconfig get debug]} {
package ifneeded dde 1.4.3 [list load [file join $dir tcldde14g.dll] dde]
} else {
package ifneeded dde 1.4.3 [list load [file join $dir tcldde14.dll] dde]
}
|
Changes to library/encoding/tis-620.enc.
| ︙ | ︙ |
Deleted library/http/cookiejar.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted library/http/effective_tld_names.txt.gz.
cannot compute difference between binary files
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.9.2
namespace eval http {
# Allow resourcing to not clobber existing data
variable http
if {![info exists http]} {
array set http {
|
| ︙ | ︙ | |||
1345 1346 1347 1348 1349 1350 1351 |
}
} elseif {$state(-validate)} {
set how HEAD
} elseif {$isQueryChannel} {
set how POST
# The query channel must be blocking for the async Write to
# work properly.
| < | < | 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 |
}
} elseif {$state(-validate)} {
set how HEAD
} elseif {$isQueryChannel} {
set how POST
# The query channel must be blocking for the async Write to
# work properly.
fconfigure $state(-querychannel) -blocking 1 -translation binary
set contDone 0
}
if {[info exists state(-method)] && ($state(-method) ne "")} {
set how $state(-method)
}
# We cannot handle chunked encodings with -handler, so force HTTP/1.0
# until we can manage this.
|
| ︙ | ︙ | |||
3016 3017 3018 3019 3020 3021 3022 |
if {$major eq "text"} {
return false
}
# There's a bunch of XML-as-application-format things about. See RFC 3023
# and so on.
if {$major eq "application"} {
set minor [string trimright $minor]
| | | 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 |
if {$major eq "text"} {
return false
}
# There's a bunch of XML-as-application-format things about. See RFC 3023
# and so on.
if {$major eq "application"} {
set minor [string trimright $minor]
if {$minor in {"json" "xml" "xml-external-parsed-entity" "xml-dtd"}} {
return false
}
}
# Not just application/foobar+xml but also image/svg+xml, so let us not
# restrict things for now...
if {[string match "*+xml" $minor]} {
return false
|
| ︙ | ︙ |
Deleted library/http/idna.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
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.9.2 [list tclPkgSetup $dir http 2.9.2 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
|
Changes to library/init.tcl.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# This test intentionally written in pre-7.5 Tcl
if {[info commands package] == ""} {
error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
}
| | | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# This test intentionally written in pre-7.5 Tcl
if {[info commands package] == ""} {
error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
}
package require -exact Tcl 8.7a4
# Compute the auto path to use in this interpreter.
# The values on the path come from several locations:
#
# The environment variable TCLLIBPATH
#
# tcl_library, which is the directory containing this init.tcl script.
|
| ︙ | ︙ | |||
56 57 58 59 60 61 62 |
}
}
set Dir [file join [file dirname [file dirname \
[info nameofexecutable]]] lib]
if {$Dir ni $::auto_path} {
lappend ::auto_path $Dir
}
| | | | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
}
}
set Dir [file join [file dirname [file dirname \
[info nameofexecutable]]] lib]
if {$Dir ni $::auto_path} {
lappend ::auto_path $Dir
}
if {[info exists ::tcl_pkgPath]} { catch {
foreach Dir $::tcl_pkgPath {
if {$Dir ni $::auto_path} {
lappend ::auto_path $Dir
}
}
}}
if {![interp issafe]} {
variable Path [encoding dirs]
set Dir [file join $::tcl_library encoding]
if {$Dir ni $Path} {
lappend Path $Dir
encoding dirs $Path
|
| ︙ | ︙ | |||
612 613 614 615 616 617 618 |
return [set auto_execs($name) [list $file]]
}
}
return ""
}
set path "[file dirname [info nameof]];.;"
| | > > | 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 |
return [set auto_execs($name) [list $file]]
}
}
return ""
}
set path "[file dirname [info nameof]];.;"
if {[info exists env(SystemRoot)]} {
set windir $env(SystemRoot)
} elseif {[info exists env(WINDIR)]} {
set windir $env(WINDIR)
}
if {[info exists windir]} {
append path "$windir/system32;$windir/system;$windir;"
}
foreach var {PATH Path path} {
|
| ︙ | ︙ |
Changes to library/manifest.txt.
1 2 3 4 5 6 7 |
###
# Package manifest for all Tcl packages included in the /library file system
###
apply {{dir} {
set ::test [info script]
set isafe [interp issafe]
foreach {safe package version file} {
| | | > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
###
# Package manifest for all Tcl packages included in the /library file system
###
apply {{dir} {
set ::test [info script]
set isafe [interp issafe]
foreach {safe package version file} {
0 http 2.9.2 {http http.tcl}
1 msgcat 1.7.1 {msgcat msgcat.tcl}
1 opt 0.4.7 {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
package ifneeded $package $version [list source [file join $dir {*}$file]]
}
}} $dir
|
Changes to library/msgcat/msgcat.tcl.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 | # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # We use oo::define::self, which is new in Tcl 8.7 package require Tcl 8.7- # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
# We use oo::define::self, which is new in Tcl 8.7
package require Tcl 8.7-
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the installation directory in the Makefiles.
package provide msgcat 1.7.1
namespace eval msgcat {
namespace export mc mcn mcexists mcload mclocale mcmax\
mcmset mcpreferences mcset\
mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\
mcpackagenamespaceget mcpackageconfig mcpackagelocale mcutil
|
| ︙ | ︙ | |||
356 357 358 359 360 361 362 |
# Locale.
#
# Results:
# Locale list
proc msgcat::mcutil::getpreferences {locale} {
set locale [string tolower $locale]
| | | | | | > > > > | < < | | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 |
# Locale.
#
# Results:
# Locale list
proc msgcat::mcutil::getpreferences {locale} {
set locale [string tolower $locale]
set result [list {}]
set el {}
foreach e [split $locale _] {
if {$el eq {}} {
set el ${e}
} else {
set el ${el}_${e}
}
if {[string index $el end] != {_}} {
set result [linsert $result 0 $el]
}
}
return $result
}
# msgcat::mcpreferences --
#
# Fetch the list of locales used to look up strings, ordered from
# most preferred to least preferred.
#
|
| ︙ | ︙ |
Changes to library/msgcat/pkgIndex.tcl.
1 |
if {![package vsatisfies [package provide Tcl] 8.7-]} {return}
| | | 1 2 |
if {![package vsatisfies [package provide Tcl] 8.7-]} {return}
package ifneeded msgcat 1.7.1 [list source [file join $dir msgcat.tcl]]
|
Changes to library/reg/pkgIndex.tcl.
|
| | | | | | 1 2 3 4 5 6 7 8 9 |
if {![package vsatisfies [package provide Tcl] 8.5-]} return
if {[info sharedlibextension] != ".dll"} return
if {[::tcl::pkgconfig get debug]} {
package ifneeded registry 1.3.5 \
[list load [file join $dir tclreg13g.dll] registry]
} else {
package ifneeded registry 1.3.5 \
[list load [file join $dir tclreg13.dll] registry]
}
|
Changes to library/safe.tcl.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 | # 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 | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
# 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.7
# Create the safe namespace
namespace eval ::safe {
# Exported API:
namespace export interpCreate interpInit interpConfigure interpDelete \
interpAddToAccessPath interpFindInAccessPath setLogCmd
}
|
| ︙ | ︙ | |||
109 110 111 112 113 114 115 | # -> TODO (the app should share or access easily the program/value stored # by opt) # This is even more complicated by the boolean flags with no values that # we had the bad idea to support for the sake of user simplicity in # create/init but which makes life hard in configure... # So this will be hopefully written and some integrated with opt1.0 | | | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 |
# -> TODO (the app should share or access easily the program/value stored
# by opt)
# This is even more complicated by the boolean flags with no values that
# we had the bad idea to support for the sake of user simplicity in
# create/init but which makes life hard in configure...
# So this will be hopefully written and some integrated with opt1.0
# (hopefully for tcl8.1 ?)
proc ::safe::interpConfigure {args} {
switch [llength $args] {
1 {
# If we have exactly 1 argument the semantic is to return all
# the current configuration. We still call OptKeyParse though
# we know that "slave" is our given argument because it also
# checks for the "-help" option.
|
| ︙ | ︙ |
Changes to library/tcltest/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 |
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 |
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex -direct" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
package ifneeded tcltest 2.5.3 [list source [file join $dir tcltest.tcl]]
|
Changes to library/tcltest/tcltest.tcl.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 |
package require Tcl 8.5- ;# -verbose line uses [info frame]
namespace eval tcltest {
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles. When the minor version
# changes (new feature) be sure to update the man page as well.
| | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
package require Tcl 8.5- ;# -verbose line uses [info frame]
namespace eval tcltest {
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the install directory in the Makefiles. When the minor version
# changes (new feature) be sure to update the man page as well.
variable Version 2.5.3
# Compatibility support for dumb variables defined in tcltest 1
# Do not use these. Call [package provide Tcl] and [info patchlevel]
# yourself. You don't need tcltest to wrap it for you.
variable version [package provide Tcl]
variable patchLevel [info patchlevel]
|
| ︙ | ︙ | |||
966 967 968 969 970 971 972 |
variable testConstraints
variable Option
DebugPuts 3 "entering testConstraint $constraint $value"
if {[llength [info level 0]] == 2} {
return $testConstraints($constraint)
}
# Check for boolean values
| | | 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 |
variable testConstraints
variable Option
DebugPuts 3 "entering testConstraint $constraint $value"
if {[llength [info level 0]] == 2} {
return $testConstraints($constraint)
}
# Check for boolean values
if {[catch {expr {$value && 1}} msg]} {
return -code error $msg
}
if {[limitConstraints] && ($constraint ni $Option(-constraints))} {
set value 0
}
set testConstraints($constraint) $value
}
|
| ︙ | ︙ | |||
1978 1979 1980 1981 1982 1983 1984 |
# Save information about the core file.
if {[preserveCore]} {
if {[file exists [file join [workingDirectory] core]]} {
set coreModTime [file mtime [file join [workingDirectory] core]]
}
}
| | > > > > > > > > | | 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 |
# Save information about the core file.
if {[preserveCore]} {
if {[file exists [file join [workingDirectory] core]]} {
set coreModTime [file mtime [file join [workingDirectory] core]]
}
}
# First, run the setup script (or a hook if it presents):
if {[set cmd [namespace which -command [namespace current]::SetupTest]] ne ""} {
set setup [list $cmd $setup]
}
set processTest 1
set code [catch {uplevel 1 $setup} setupMsg]
if {$code == 1} {
set errorInfo(setup) $::errorInfo
set errorCodeRes(setup) $::errorCode
if {$errorCodeRes(setup) eq "BYPASS-SKIPPED-TEST"} {
_noticeSkipped $name $setupMsg
set processTest [set code 0]
}
}
set setupFailure [expr {$code != 0}]
# Only run the test body if the setup was successful
if {$processTest && !$setupFailure} {
# Register startup time
if {[IsVerbose msec] || [IsVerbose usec]} {
set timeStart [clock microseconds]
}
# Verbose notification of $body start
|
| ︙ | ︙ | |||
2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 |
} else {
set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
}
lassign $testResult actualAnswer returnCode
if {$returnCode == 1} {
set errorInfo(body) $::errorInfo
set errorCodeRes(body) $::errorCode
}
}
# check if the return code matched the expected return code
set codeFailure 0
| > > > > | | | | > > | | > > > | 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 |
} else {
set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
}
lassign $testResult actualAnswer returnCode
if {$returnCode == 1} {
set errorInfo(body) $::errorInfo
set errorCodeRes(body) $::errorCode
if {$errorCodeRes(body) eq "BYPASS-SKIPPED-TEST"} {
_noticeSkipped $name $actualAnswer
set processTest [set returnCode 0]
}
}
}
# check if the return code matched the expected return code
set codeFailure 0
if {$processTest && !$setupFailure && ($returnCode ni $returnCodes)} {
set codeFailure 1
}
set errorCodeFailure 0
if {$processTest && !$setupFailure && !$codeFailure && $returnCode == 1 && \
![string match $errorCode $errorCodeRes(body)]} {
set errorCodeFailure 1
}
# If expected output/error strings exist, we have to compare
# them. If the comparison fails, then so did the test.
set outputFailure 0
variable outData
if {$processTest && [info exists output] && !$codeFailure} {
if {[set outputCompare [catch {
CompareStrings $outData $output $match
} outputMatch]] == 0} {
set outputFailure [expr {!$outputMatch}]
} else {
set outputFailure 1
}
}
set errorFailure 0
variable errData
if {$processTest && [info exists errorOutput] && !$codeFailure} {
if {[set errorCompare [catch {
CompareStrings $errData $errorOutput $match
} errorMatch]] == 0} {
set errorFailure [expr {!$errorMatch}]
} else {
set errorFailure 1
}
}
# check if the answer matched the expected answer
# Only check if we ran the body of the test (no setup failure)
if {!$processTest} {
set scriptFailure 0
} elseif {$setupFailure || $codeFailure} {
set scriptFailure 0
} elseif {[set scriptCompare [catch {
CompareStrings $actualAnswer $result $match
} scriptMatch]] == 0} {
set scriptFailure [expr {!$scriptMatch}]
} else {
set scriptFailure 1
}
# Always run the cleanup script (or a hook if it presents):
if {[set cmd [namespace which -command [namespace current]::CleanupTest]] ne ""} {
set cleanup [list $cmd $cleanup]
}
set code [catch {uplevel 1 $cleanup} cleanupMsg]
if {$code == 1} {
set errorInfo(cleanup) $::errorInfo
set errorCodeRes(cleanup) $::errorCode
}
set cleanupFailure [expr {$code != 0}]
|
| ︙ | ︙ | |||
2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 |
if {[IsVerbose usec]} {
puts [outputChannel] "++++ $name took $t μs"
}
if {[IsVerbose msec]} {
puts [outputChannel] "++++ $name took [expr {round($t/1000.)}] ms"
}
}
# if we didn't experience any failures, then we passed
variable numTests
if {!($setupFailure || $cleanupFailure || $coreFailure
|| $outputFailure || $errorFailure || $codeFailure
|| $errorCodeFailure || $scriptFailure)} {
if {$testLevel == 1} {
| > > > > > > | 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 |
if {[IsVerbose usec]} {
puts [outputChannel] "++++ $name took $t μs"
}
if {[IsVerbose msec]} {
puts [outputChannel] "++++ $name took [expr {round($t/1000.)}] ms"
}
}
# if skipped, it is safe to return here
if {!$processTest} {
incr testLevel -1
return
}
# if we didn't experience any failures, then we passed
variable numTests
if {!($setupFailure || $cleanupFailure || $coreFailure
|| $outputFailure || $errorFailure || $codeFailure
|| $errorCodeFailure || $scriptFailure)} {
if {$testLevel == 1} {
|
| ︙ | ︙ | |||
2173 2174 2175 2176 2177 2178 2179 |
puts [outputChannel] "---- Test setup\
failed:\n$setupMsg"
if {[info exists errorInfo(setup)]} {
puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)"
puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)"
}
}
| | | 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 |
puts [outputChannel] "---- Test setup\
failed:\n$setupMsg"
if {[info exists errorInfo(setup)]} {
puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)"
puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)"
}
}
if {$processTest && $scriptFailure} {
if {$scriptCompare} {
puts [outputChannel] "---- Error testing result: $scriptMatch"
} else {
puts [outputChannel] "---- Result was:\n$actualAnswer"
puts [outputChannel] "---- Result should have been\
($match matching):\n$result"
}
|
| ︙ | ︙ | |||
2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 |
test! $coreMsg"
}
puts [outputChannel] "==== $name FAILED\n"
incr testLevel -1
return
}
# Skipped --
#
# Given a test name and it constraints, returns a boolean indicating
# whether the current configuration says the test should be skipped.
#
# Side Effects: Maintains tally of total tests seen and tests skipped.
| > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
test! $coreMsg"
}
puts [outputChannel] "==== $name FAILED\n"
incr testLevel -1
return
}
# Skip --
#
# Skips a running test and add a reason to skipped "constraints". Can be used
# to conditional intended abort of the test.
#
# Side Effects: Maintains tally of total tests seen and tests skipped.
#
proc tcltest::Skip {reason} {
return -code error -errorcode BYPASS-SKIPPED-TEST $reason
}
proc tcltest::_noticeSkipped {name reason} {
variable testLevel
variable numTests
if {[IsVerbose skip]} {
puts [outputChannel] "++++ $name SKIPPED: $reason"
}
if {$testLevel == 1} {
incr numTests(Skipped)
AddToSkippedBecause $reason
}
}
# Skipped --
#
# Given a test name and it constraints, returns a boolean indicating
# whether the current configuration says the test should be skipped.
#
# Side Effects: Maintains tally of total tests seen and tests skipped.
|
| ︙ | ︙ | |||
2320 2321 2322 2323 2324 2325 2326 |
set constraints $constraint
break
}
}
}
if {!$doTest} {
| < < < | < < < < | 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 |
set constraints $constraint
break
}
}
}
if {!$doTest} {
_noticeSkipped $name $constraints
return 1
}
}
return 0
}
# RunTest --
|
| ︙ | ︙ | |||
2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 |
# If there is no "memory" command (because memory debugging isn't
# enabled), then don't attempt to use the command.
if {[llength [info commands memory]] == 1} {
memory tag $name
}
set code [catch {uplevel 1 $script} actualAnswer]
return [list $actualAnswer $code]
}
#####################################################################
| > > > > | 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 |
# If there is no "memory" command (because memory debugging isn't
# enabled), then don't attempt to use the command.
if {[llength [info commands memory]] == 1} {
memory tag $name
}
# run the test script (or a hook if it presents):
if {[set cmd [namespace which -command [namespace current]::EvalTest]] ne ""} {
set script [list $cmd $script]
}
set code [catch {uplevel 1 $script} actualAnswer]
return [list $actualAnswer $code]
}
#####################################################################
|
| ︙ | ︙ | |||
3057 3058 3059 3060 3061 3062 3063 |
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]
| < > > | > > > > > | 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 |
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 == -1} {
DebugDo 1 {
Warn "removeFile removing \"$fullName\":\n not created by makeFile"
}
} else {
set filesMade [lreplace $filesMade $idx $idx]
}
if {![file isfile $fullName]} {
DebugDo 1 {
Warn "removeFile removing \"$fullName\":\n not a file"
}
}
if {[catch {file delete -- $fullName} msg ]} {
DebugDo 1 {
Warn "removeFile removing \"$fullName\":\n failed: $msg"
}
}
return
}
# tcltest::makeDirectory --
#
# Create a new dir with the name <name>.
#
# If this dir hasn't been created via makeDirectory since the last time
|
| ︙ | ︙ |
Changes to library/tm.tcl.
| ︙ | ︙ | |||
307 308 309 310 311 312 313 |
#
# Sideeffects
# May add paths to the list of defaults.
proc ::tcl::tm::Defaults {} {
global env tcl_platform
| | | 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 |
#
# Sideeffects
# May add paths to the list of defaults.
proc ::tcl::tm::Defaults {} {
global env tcl_platform
regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor
set exe [file normalize [info nameofexecutable]]
# Note that we're using [::list], not [list] because [list] means
# something other than [::list] in this namespace.
roots [::list \
[file dirname [info library]] \
[file join [file dirname [file dirname $exe]] lib] \
|
| ︙ | ︙ | |||
350 351 352 353 354 355 356 |
# Results
# No result.
#
# Sideeffects
# Calls 'path add' to paths to the list of module search paths.
proc ::tcl::tm::roots {paths} {
| | | 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 |
# Results
# No result.
#
# Sideeffects
# Calls 'path add' to paths to the list of module search paths.
proc ::tcl::tm::roots {paths} {
regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor
foreach pa $paths {
set p [file join $pa tcl$major]
for {set n $minor} {$n >= 0} {incr n -1} {
set px [file join $p ${major}.${n}]
if {![interp issafe]} {set px [file normalize $px]}
path add $px
}
|
| ︙ | ︙ |
Changes to library/tzdata/Africa/Casablanca.
| ︙ | ︙ | |||
56 57 58 59 60 61 62 |
{1521943200 3600 1 +00}
{1526176800 0 0 +00}
{1529200800 3600 1 +00}
{1540695600 3600 0 +01}
{1557021600 0 1 +01}
{1560045600 3600 0 +01}
{1587261600 0 1 +01}
| | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 |
{1521943200 3600 1 +00}
{1526176800 0 0 +00}
{1529200800 3600 1 +00}
{1540695600 3600 0 +01}
{1557021600 0 1 +01}
{1560045600 3600 0 +01}
{1587261600 0 1 +01}
{1590890400 3600 0 +01}
{1618106400 0 1 +01}
{1621130400 3600 0 +01}
{1648346400 0 1 +01}
{1651975200 3600 0 +01}
{1679191200 0 1 +01}
{1682215200 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}
{1927159200 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}
{2172103200 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}
{2417047200 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}
{2661991200 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}
{2906935200 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}
{3151879200 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}
{3396823200 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}
{3549837600 3600 0 +01}
{3577658400 0 1 +01}
{3580682400 3600 0 +01}
{3607898400 0 1 +01}
{3611527200 3600 0 +01}
{3638743200 0 1 +01}
{3641767200 3600 0 +01}
{3669588000 0 1 +01}
{3672612000 3600 0 +01}
{3699828000 0 1 +01}
{3703456800 3600 0 +01}
}
|
Changes to library/tzdata/Africa/El_Aaiun.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 |
{1521943200 3600 1 +00}
{1526176800 0 0 +00}
{1529200800 3600 1 +00}
{1540695600 3600 0 +01}
{1557021600 0 1 +01}
{1560045600 3600 0 +01}
{1587261600 0 1 +01}
| | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 |
{1521943200 3600 1 +00}
{1526176800 0 0 +00}
{1529200800 3600 1 +00}
{1540695600 3600 0 +01}
{1557021600 0 1 +01}
{1560045600 3600 0 +01}
{1587261600 0 1 +01}
{1590890400 3600 0 +01}
{1618106400 0 1 +01}
{1621130400 3600 0 +01}
{1648346400 0 1 +01}
{1651975200 3600 0 +01}
{1679191200 0 1 +01}
{1682215200 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}
{1927159200 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}
{2172103200 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}
{2417047200 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}
{2661991200 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}
{2906935200 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}
{3151879200 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}
{3396823200 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}
{3549837600 3600 0 +01}
{3577658400 0 1 +01}
{3580682400 3600 0 +01}
{3607898400 0 1 +01}
{3611527200 3600 0 +01}
{3638743200 0 1 +01}
{3641767200 3600 0 +01}
{3669588000 0 1 +01}
{3672612000 3600 0 +01}
{3699828000 0 1 +01}
{3703456800 3600 0 +01}
}
|
Changes to library/tzdata/America/Campo_Grande.
| ︙ | ︙ | |||
89 90 91 92 93 94 95 |
{1456023600 -14400 0 -04}
{1476590400 -10800 1 -04}
{1487473200 -14400 0 -04}
{1508040000 -10800 1 -04}
{1518922800 -14400 0 -04}
{1541304000 -10800 1 -04}
{1550372400 -14400 0 -04}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 89 90 91 92 93 94 95 96 |
{1456023600 -14400 0 -04}
{1476590400 -10800 1 -04}
{1487473200 -14400 0 -04}
{1508040000 -10800 1 -04}
{1518922800 -14400 0 -04}
{1541304000 -10800 1 -04}
{1550372400 -14400 0 -04}
}
|
Changes to library/tzdata/America/Cuiaba.
| ︙ | ︙ | |||
89 90 91 92 93 94 95 |
{1456023600 -14400 0 -04}
{1476590400 -10800 1 -04}
{1487473200 -14400 0 -04}
{1508040000 -10800 1 -04}
{1518922800 -14400 0 -04}
{1541304000 -10800 1 -04}
{1550372400 -14400 0 -04}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 89 90 91 92 93 94 95 96 |
{1456023600 -14400 0 -04}
{1476590400 -10800 1 -04}
{1487473200 -14400 0 -04}
{1508040000 -10800 1 -04}
{1518922800 -14400 0 -04}
{1541304000 -10800 1 -04}
{1550372400 -14400 0 -04}
}
|
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 |
{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 0 MST}
}
|
Changes to library/tzdata/America/Detroit.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Detroit) {
{-9223372036854775808 -19931 0 LMT}
{-2051202469 -21600 0 CST}
{-1724083200 -18000 0 EST}
{-883594800 -18000 0 EST}
{-880218000 -14400 1 EWT}
{-769395600 -14400 1 EPT}
{-765396000 -18000 0 EST}
{-757364400 -18000 0 EST}
{-684349200 -14400 1 EDT}
{-671047200 -18000 0 EST}
{94712400 -18000 0 EST}
{104914800 -14400 1 EDT}
{120636000 -18000 0 EST}
{126687600 -14400 1 EDT}
{152085600 -18000 0 EST}
{157784400 -18000 0 EST}
{167814000 -14400 0 EDT}
| > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Detroit) {
{-9223372036854775808 -19931 0 LMT}
{-2051202469 -21600 0 CST}
{-1724083200 -18000 0 EST}
{-883594800 -18000 0 EST}
{-880218000 -14400 1 EWT}
{-769395600 -14400 1 EPT}
{-765396000 -18000 0 EST}
{-757364400 -18000 0 EST}
{-684349200 -14400 1 EDT}
{-671047200 -18000 0 EST}
{-80506740 -14400 0 EDT}
{-68666400 -18000 0 EST}
{-52938000 -14400 1 EDT}
{-37216800 -18000 0 EST}
{-31518000 -18000 0 EST}
{94712400 -18000 0 EST}
{104914800 -14400 1 EDT}
{120636000 -18000 0 EST}
{126687600 -14400 1 EDT}
{152085600 -18000 0 EST}
{157784400 -18000 0 EST}
{167814000 -14400 0 EDT}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Edmonton.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 |
{-1473001200 -21600 1 MDT}
{-1459699200 -25200 0 MST}
{-880210800 -21600 1 MWT}
{-769395600 -21600 1 MPT}
{-765388800 -25200 0 MST}
{-715791600 -21600 1 MDT}
{-702489600 -25200 0 MST}
| < < < < | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
{-1473001200 -21600 1 MDT}
{-1459699200 -25200 0 MST}
{-880210800 -21600 1 MWT}
{-769395600 -21600 1 MPT}
{-765388800 -25200 0 MST}
{-715791600 -21600 1 MDT}
{-702489600 -25200 0 MST}
{73472400 -21600 1 MDT}
{89193600 -25200 0 MST}
{104922000 -21600 1 MDT}
{120643200 -25200 0 MST}
{136371600 -21600 1 MDT}
{152092800 -25200 0 MST}
{167821200 -21600 1 MDT}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Godthab.
1 | # created by tools/tclZIC.tcl - do not edit | > > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Nuuk)]} {
LoadTimeZoneFile America/Nuuk
}
set TZData(:America/Godthab) $TZData(:America/Nuuk)
|
Changes to library/tzdata/America/Indiana/Tell_City.
1 2 3 4 5 6 7 8 9 10 11 12 13 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Indiana/Tell_City) {
{-9223372036854775808 -20823 0 LMT}
{-2717647200 -21600 0 CST}
{-1633276800 -18000 1 CDT}
{-1615136400 -21600 0 CST}
{-1601827200 -18000 1 CDT}
{-1583686800 -21600 0 CST}
{-880214400 -18000 1 CWT}
{-769395600 -18000 1 CPT}
{-765392400 -21600 0 CST}
{-757360800 -21600 0 CST}
| < < < < < < | | > | > | | 1 2 3 4 5 6 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 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Indiana/Tell_City) {
{-9223372036854775808 -20823 0 LMT}
{-2717647200 -21600 0 CST}
{-1633276800 -18000 1 CDT}
{-1615136400 -21600 0 CST}
{-1601827200 -18000 1 CDT}
{-1583686800 -21600 0 CST}
{-880214400 -18000 1 CWT}
{-769395600 -18000 1 CPT}
{-765392400 -21600 0 CST}
{-757360800 -21600 0 CST}
{-462996000 -18000 1 CDT}
{-450291600 -21600 0 CST}
{-431539200 -18000 1 CDT}
{-418237200 -21600 0 CST}
{-400089600 -18000 1 CDT}
{-386787600 -21600 0 CST}
{-368640000 -18000 1 CDT}
{-355338000 -21600 0 CST}
{-337190400 -18000 1 CDT}
{-323888400 -21600 0 CST}
{-305740800 -18000 1 CDT}
{-292438800 -21600 0 CST}
{-273686400 -18000 1 CDT}
{-257965200 -21600 0 CST}
{-242236800 -18000 1 CDT}
{-226515600 -21600 0 CST}
{-210787200 -18000 1 CDT}
{-195066000 -21600 0 CST}
{-179337600 -18000 0 EST}
{-68662800 -21600 0 CST}
{-52934400 -18000 1 CDT}
{-37213200 -21600 0 CST}
{-21484800 -14400 0 EDT}
{-5767200 -18000 0 EST}
{9961200 -14400 1 EDT}
{25682400 -18000 0 EST}
{31554000 -18000 0 EST}
{1143961200 -21600 0 CST}
{1143964800 -18000 1 CDT}
{1162105200 -21600 0 CST}
|
| ︙ | ︙ |
Changes to library/tzdata/America/Kentucky/Louisville.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 |
{-905097600 -18000 1 CDT}
{-891795600 -21600 0 CST}
{-883591200 -21600 0 CST}
{-880214400 -18000 1 CWT}
{-769395600 -18000 1 CPT}
{-765392400 -21600 0 CST}
{-757360800 -21600 0 CST}
| | | < < < | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
{-905097600 -18000 1 CDT}
{-891795600 -21600 0 CST}
{-883591200 -21600 0 CST}
{-880214400 -18000 1 CWT}
{-769395600 -18000 1 CPT}
{-765392400 -21600 0 CST}
{-757360800 -21600 0 CST}
{-747251940 -18000 1 CDT}
{-744224400 -21600 0 CST}
{-620841600 -18000 1 CDT}
{-608144400 -21600 0 CST}
{-589392000 -18000 1 CDT}
{-576090000 -21600 0 CST}
{-557942400 -18000 1 CDT}
{-544640400 -21600 0 CST}
{-526492800 -18000 1 CDT}
{-513190800 -21600 0 CST}
|
| ︙ | ︙ | |||
41 42 43 44 45 46 47 |
{-368640000 -18000 1 CDT}
{-352918800 -21600 0 CST}
{-337190400 -18000 1 CDT}
{-321469200 -21600 0 CST}
{-305740800 -18000 1 CDT}
{-289414800 -21600 0 CST}
{-273686400 -18000 1 CDT}
| | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
{-368640000 -18000 1 CDT}
{-352918800 -21600 0 CST}
{-337190400 -18000 1 CDT}
{-321469200 -21600 0 CST}
{-305740800 -18000 1 CDT}
{-289414800 -21600 0 CST}
{-273686400 -18000 1 CDT}
{-266428800 -18000 0 EST}
{-63140400 -18000 0 EST}
{-52938000 -14400 1 EDT}
{-37216800 -18000 0 EST}
{-21488400 -14400 1 EDT}
{-5767200 -18000 0 EST}
{9961200 -14400 1 EDT}
{25682400 -18000 0 EST}
|
| ︙ | ︙ |
Added library/tzdata/America/Nuuk.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Nuuk) {
{-9223372036854775808 -12416 0 LMT}
{-1686083584 -10800 0 -03}
{323845200 -7200 0 -02}
{338950800 -10800 0 -03}
{354675600 -7200 1 -02}
{370400400 -10800 0 -03}
{386125200 -7200 1 -02}
{401850000 -10800 0 -03}
{417574800 -7200 1 -02}
{433299600 -10800 0 -03}
{449024400 -7200 1 -02}
{465354000 -10800 0 -03}
{481078800 -7200 1 -02}
{496803600 -10800 0 -03}
{512528400 -7200 1 -02}
{528253200 -10800 0 -03}
{543978000 -7200 1 -02}
{559702800 -10800 0 -03}
{575427600 -7200 1 -02}
{591152400 -10800 0 -03}
{606877200 -7200 1 -02}
{622602000 -10800 0 -03}
{638326800 -7200 1 -02}
{654656400 -10800 0 -03}
{670381200 -7200 1 -02}
{686106000 -10800 0 -03}
{701830800 -7200 1 -02}
{717555600 -10800 0 -03}
{733280400 -7200 1 -02}
{749005200 -10800 0 -03}
{764730000 -7200 1 -02}
{780454800 -10800 0 -03}
{796179600 -7200 1 -02}
{811904400 -10800 0 -03}
{828234000 -7200 1 -02}
{846378000 -10800 0 -03}
{859683600 -7200 1 -02}
{877827600 -10800 0 -03}
{891133200 -7200 1 -02}
{909277200 -10800 0 -03}
{922582800 -7200 1 -02}
{941331600 -10800 0 -03}
{954032400 -7200 1 -02}
{972781200 -10800 0 -03}
{985482000 -7200 1 -02}
{1004230800 -10800 0 -03}
{1017536400 -7200 1 -02}
{1035680400 -10800 0 -03}
{1048986000 -7200 1 -02}
{1067130000 -10800 0 -03}
{1080435600 -7200 1 -02}
{1099184400 -10800 0 -03}
{1111885200 -7200 1 -02}
{1130634000 -10800 0 -03}
{1143334800 -7200 1 -02}
{1162083600 -10800 0 -03}
{1174784400 -7200 1 -02}
{1193533200 -10800 0 -03}
{1206838800 -7200 1 -02}
{1224982800 -10800 0 -03}
{1238288400 -7200 1 -02}
{1256432400 -10800 0 -03}
{1269738000 -7200 1 -02}
{1288486800 -10800 0 -03}
{1301187600 -7200 1 -02}
{1319936400 -10800 0 -03}
{1332637200 -7200 1 -02}
{1351386000 -10800 0 -03}
{1364691600 -7200 1 -02}
{1382835600 -10800 0 -03}
{1396141200 -7200 1 -02}
{1414285200 -10800 0 -03}
{1427590800 -7200 1 -02}
{1445734800 -10800 0 -03}
{1459040400 -7200 1 -02}
{1477789200 -10800 0 -03}
{1490490000 -7200 1 -02}
{1509238800 -10800 0 -03}
{1521939600 -7200 1 -02}
{1540688400 -10800 0 -03}
{1553994000 -7200 1 -02}
{1572138000 -10800 0 -03}
{1585443600 -7200 1 -02}
{1603587600 -10800 0 -03}
{1616893200 -7200 1 -02}
{1635642000 -10800 0 -03}
{1648342800 -7200 1 -02}
{1667091600 -10800 0 -03}
{1679792400 -7200 1 -02}
{1698541200 -10800 0 -03}
{1711846800 -7200 1 -02}
{1729990800 -10800 0 -03}
{1743296400 -7200 1 -02}
{1761440400 -10800 0 -03}
{1774746000 -7200 1 -02}
{1792890000 -10800 0 -03}
{1806195600 -7200 1 -02}
{1824944400 -10800 0 -03}
{1837645200 -7200 1 -02}
{1856394000 -10800 0 -03}
{1869094800 -7200 1 -02}
{1887843600 -10800 0 -03}
{1901149200 -7200 1 -02}
{1919293200 -10800 0 -03}
{1932598800 -7200 1 -02}
{1950742800 -10800 0 -03}
{1964048400 -7200 1 -02}
{1982797200 -10800 0 -03}
{1995498000 -7200 1 -02}
{2014246800 -10800 0 -03}
{2026947600 -7200 1 -02}
{2045696400 -10800 0 -03}
{2058397200 -7200 1 -02}
{2077146000 -10800 0 -03}
{2090451600 -7200 1 -02}
{2108595600 -10800 0 -03}
{2121901200 -7200 1 -02}
{2140045200 -10800 0 -03}
{2153350800 -7200 1 -02}
{2172099600 -10800 0 -03}
{2184800400 -7200 1 -02}
{2203549200 -10800 0 -03}
{2216250000 -7200 1 -02}
{2234998800 -10800 0 -03}
{2248304400 -7200 1 -02}
{2266448400 -10800 0 -03}
{2279754000 -7200 1 -02}
{2297898000 -10800 0 -03}
{2311203600 -7200 1 -02}
{2329347600 -10800 0 -03}
{2342653200 -7200 1 -02}
{2361402000 -10800 0 -03}
{2374102800 -7200 1 -02}
{2392851600 -10800 0 -03}
{2405552400 -7200 1 -02}
{2424301200 -10800 0 -03}
{2437606800 -7200 1 -02}
{2455750800 -10800 0 -03}
{2469056400 -7200 1 -02}
{2487200400 -10800 0 -03}
{2500506000 -7200 1 -02}
{2519254800 -10800 0 -03}
{2531955600 -7200 1 -02}
{2550704400 -10800 0 -03}
{2563405200 -7200 1 -02}
{2582154000 -10800 0 -03}
{2595459600 -7200 1 -02}
{2613603600 -10800 0 -03}
{2626909200 -7200 1 -02}
{2645053200 -10800 0 -03}
{2658358800 -7200 1 -02}
{2676502800 -10800 0 -03}
{2689808400 -7200 1 -02}
{2708557200 -10800 0 -03}
{2721258000 -7200 1 -02}
{2740006800 -10800 0 -03}
{2752707600 -7200 1 -02}
{2771456400 -10800 0 -03}
{2784762000 -7200 1 -02}
{2802906000 -10800 0 -03}
{2816211600 -7200 1 -02}
{2834355600 -10800 0 -03}
{2847661200 -7200 1 -02}
{2866410000 -10800 0 -03}
{2879110800 -7200 1 -02}
{2897859600 -10800 0 -03}
{2910560400 -7200 1 -02}
{2929309200 -10800 0 -03}
{2942010000 -7200 1 -02}
{2960758800 -10800 0 -03}
{2974064400 -7200 1 -02}
{2992208400 -10800 0 -03}
{3005514000 -7200 1 -02}
{3023658000 -10800 0 -03}
{3036963600 -7200 1 -02}
{3055712400 -10800 0 -03}
{3068413200 -7200 1 -02}
{3087162000 -10800 0 -03}
{3099862800 -7200 1 -02}
{3118611600 -10800 0 -03}
{3131917200 -7200 1 -02}
{3150061200 -10800 0 -03}
{3163366800 -7200 1 -02}
{3181510800 -10800 0 -03}
{3194816400 -7200 1 -02}
{3212960400 -10800 0 -03}
{3226266000 -7200 1 -02}
{3245014800 -10800 0 -03}
{3257715600 -7200 1 -02}
{3276464400 -10800 0 -03}
{3289165200 -7200 1 -02}
{3307914000 -10800 0 -03}
{3321219600 -7200 1 -02}
{3339363600 -10800 0 -03}
{3352669200 -7200 1 -02}
{3370813200 -10800 0 -03}
{3384118800 -7200 1 -02}
{3402867600 -10800 0 -03}
{3415568400 -7200 1 -02}
{3434317200 -10800 0 -03}
{3447018000 -7200 1 -02}
{3465766800 -10800 0 -03}
{3479072400 -7200 1 -02}
{3497216400 -10800 0 -03}
{3510522000 -7200 1 -02}
{3528666000 -10800 0 -03}
{3541971600 -7200 1 -02}
{3560115600 -10800 0 -03}
{3573421200 -7200 1 -02}
{3592170000 -10800 0 -03}
{3604870800 -7200 1 -02}
{3623619600 -10800 0 -03}
{3636320400 -7200 1 -02}
{3655069200 -10800 0 -03}
{3668374800 -7200 1 -02}
{3686518800 -10800 0 -03}
{3699824400 -7200 1 -02}
{3717968400 -10800 0 -03}
{3731274000 -7200 1 -02}
{3750022800 -10800 0 -03}
{3762723600 -7200 1 -02}
{3781472400 -10800 0 -03}
{3794173200 -7200 1 -02}
{3812922000 -10800 0 -03}
{3825622800 -7200 1 -02}
{3844371600 -10800 0 -03}
{3857677200 -7200 1 -02}
{3875821200 -10800 0 -03}
{3889126800 -7200 1 -02}
{3907270800 -10800 0 -03}
{3920576400 -7200 1 -02}
{3939325200 -10800 0 -03}
{3952026000 -7200 1 -02}
{3970774800 -10800 0 -03}
{3983475600 -7200 1 -02}
{4002224400 -10800 0 -03}
{4015530000 -7200 1 -02}
{4033674000 -10800 0 -03}
{4046979600 -7200 1 -02}
{4065123600 -10800 0 -03}
{4078429200 -7200 1 -02}
{4096573200 -10800 0 -03}
}
|
Changes to library/tzdata/America/Sao_Paulo.
| ︙ | ︙ | |||
90 91 92 93 94 95 96 |
{1456020000 -10800 0 -03}
{1476586800 -7200 1 -03}
{1487469600 -10800 0 -03}
{1508036400 -7200 1 -03}
{1518919200 -10800 0 -03}
{1541300400 -7200 1 -03}
{1550368800 -10800 0 -03}
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 90 91 92 93 94 95 96 97 |
{1456020000 -10800 0 -03}
{1476586800 -7200 1 -03}
{1487469600 -10800 0 -03}
{1508036400 -7200 1 -03}
{1518919200 -10800 0 -03}
{1541300400 -7200 1 -03}
{1550368800 -10800 0 -03}
}
|
Changes to library/tzdata/America/Vancouver.
1 2 3 4 5 6 7 8 9 10 11 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Vancouver) {
{-9223372036854775808 -29548 0 LMT}
{-2713880852 -28800 0 PST}
{-1632060000 -25200 1 PDT}
{-1615129200 -28800 0 PST}
{-880207200 -25200 1 PWT}
{-769395600 -25200 1 PPT}
{-765385200 -28800 0 PST}
{-747237600 -25200 1 PDT}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:America/Vancouver) {
{-9223372036854775808 -29548 0 LMT}
{-2713880852 -28800 0 PST}
{-1632060000 -25200 1 PDT}
{-1615129200 -28800 0 PST}
{-880207200 -25200 1 PWT}
{-769395600 -25200 1 PPT}
{-765385200 -28800 0 PST}
{-747237600 -25200 1 PDT}
{-733935600 -28800 0 PST}
{-715788000 -25200 1 PDT}
{-702486000 -28800 0 PST}
{-684338400 -25200 1 PDT}
{-671036400 -28800 0 PST}
{-652888800 -25200 1 PDT}
{-639586800 -28800 0 PST}
{-620834400 -25200 1 PDT}
|
| ︙ | ︙ |
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 |
{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 0 MST}
}
|
Changes to library/tzdata/Asia/Gaza.
| ︙ | ︙ | |||
113 114 115 116 117 118 119 |
{1445547600 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}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
{1445547600 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}
{1572040800 7200 0 EET}
{1585260000 10800 1 EEST}
{1604095200 7200 0 EET}
{1616709600 10800 1 EEST}
{1635544800 7200 0 EET}
{1648159200 10800 1 EEST}
{1666994400 7200 0 EET}
{1680213600 10800 1 EEST}
{1698444000 7200 0 EET}
{1711663200 10800 1 EEST}
{1729893600 7200 0 EET}
{1743112800 10800 1 EEST}
{1761343200 7200 0 EET}
{1774562400 10800 1 EEST}
{1793397600 7200 0 EET}
{1806012000 10800 1 EEST}
{1824847200 7200 0 EET}
{1838066400 10800 1 EEST}
{1856296800 7200 0 EET}
{1869516000 10800 1 EEST}
{1887746400 7200 0 EET}
{1900965600 10800 1 EEST}
{1919196000 7200 0 EET}
{1932415200 10800 1 EEST}
{1950645600 7200 0 EET}
{1963864800 10800 1 EEST}
{1982700000 7200 0 EET}
{1995314400 10800 1 EEST}
{2014149600 7200 0 EET}
{2027368800 10800 1 EEST}
{2045599200 7200 0 EET}
{2058818400 10800 1 EEST}
{2077048800 7200 0 EET}
{2090268000 10800 1 EEST}
{2108498400 7200 0 EET}
{2121717600 10800 1 EEST}
{2140552800 7200 0 EET}
{2153167200 10800 1 EEST}
{2172002400 7200 0 EET}
{2184616800 10800 1 EEST}
{2203452000 7200 0 EET}
{2216671200 10800 1 EEST}
{2234901600 7200 0 EET}
{2248120800 10800 1 EEST}
{2266351200 7200 0 EET}
{2279570400 10800 1 EEST}
{2297800800 7200 0 EET}
{2311020000 10800 1 EEST}
{2329855200 7200 0 EET}
{2342469600 10800 1 EEST}
{2361304800 7200 0 EET}
{2374524000 10800 1 EEST}
{2392754400 7200 0 EET}
{2405973600 10800 1 EEST}
{2424204000 7200 0 EET}
{2437423200 10800 1 EEST}
{2455653600 7200 0 EET}
{2468872800 10800 1 EEST}
{2487708000 7200 0 EET}
{2500322400 10800 1 EEST}
{2519157600 7200 0 EET}
{2531772000 10800 1 EEST}
{2550607200 7200 0 EET}
{2563826400 10800 1 EEST}
{2582056800 7200 0 EET}
{2595276000 10800 1 EEST}
{2613506400 7200 0 EET}
{2626725600 10800 1 EEST}
{2644956000 7200 0 EET}
{2658175200 10800 1 EEST}
{2677010400 7200 0 EET}
{2689624800 10800 1 EEST}
{2708460000 7200 0 EET}
{2721679200 10800 1 EEST}
{2739909600 7200 0 EET}
{2753128800 10800 1 EEST}
{2771359200 7200 0 EET}
{2784578400 10800 1 EEST}
{2802808800 7200 0 EET}
{2816028000 10800 1 EEST}
{2834258400 7200 0 EET}
{2847477600 10800 1 EEST}
{2866312800 7200 0 EET}
{2878927200 10800 1 EEST}
{2897762400 7200 0 EET}
{2910981600 10800 1 EEST}
{2929212000 7200 0 EET}
{2942431200 10800 1 EEST}
{2960661600 7200 0 EET}
{2973880800 10800 1 EEST}
{2992111200 7200 0 EET}
{3005330400 10800 1 EEST}
{3024165600 7200 0 EET}
{3036780000 10800 1 EEST}
{3055615200 7200 0 EET}
{3068229600 10800 1 EEST}
{3087064800 7200 0 EET}
{3100284000 10800 1 EEST}
{3118514400 7200 0 EET}
{3131733600 10800 1 EEST}
{3149964000 7200 0 EET}
{3163183200 10800 1 EEST}
{3181413600 7200 0 EET}
{3194632800 10800 1 EEST}
{3213468000 7200 0 EET}
{3226082400 10800 1 EEST}
{3244917600 7200 0 EET}
{3258136800 10800 1 EEST}
{3276367200 7200 0 EET}
{3289586400 10800 1 EEST}
{3307816800 7200 0 EET}
{3321036000 10800 1 EEST}
{3339266400 7200 0 EET}
{3352485600 10800 1 EEST}
{3371320800 7200 0 EET}
{3383935200 10800 1 EEST}
{3402770400 7200 0 EET}
{3415384800 10800 1 EEST}
{3434220000 7200 0 EET}
{3447439200 10800 1 EEST}
{3465669600 7200 0 EET}
{3478888800 10800 1 EEST}
{3497119200 7200 0 EET}
{3510338400 10800 1 EEST}
{3528568800 7200 0 EET}
{3541788000 10800 1 EEST}
{3560623200 7200 0 EET}
{3573237600 10800 1 EEST}
{3592072800 7200 0 EET}
{3605292000 10800 1 EEST}
{3623522400 7200 0 EET}
{3636741600 10800 1 EEST}
{3654972000 7200 0 EET}
{3668191200 10800 1 EEST}
{3686421600 7200 0 EET}
{3699640800 10800 1 EEST}
{3717871200 7200 0 EET}
{3731090400 10800 1 EEST}
{3749925600 7200 0 EET}
{3762540000 10800 1 EEST}
{3781375200 7200 0 EET}
{3794594400 10800 1 EEST}
{3812824800 7200 0 EET}
{3826044000 10800 1 EEST}
{3844274400 7200 0 EET}
{3857493600 10800 1 EEST}
{3875724000 7200 0 EET}
{3888943200 10800 1 EEST}
{3907778400 7200 0 EET}
{3920392800 10800 1 EEST}
{3939228000 7200 0 EET}
{3951842400 10800 1 EEST}
{3970677600 7200 0 EET}
{3983896800 10800 1 EEST}
{4002127200 7200 0 EET}
{4015346400 10800 1 EEST}
{4033576800 7200 0 EET}
{4046796000 10800 1 EEST}
{4065026400 7200 0 EET}
{4078245600 10800 1 EEST}
{4097080800 7200 0 EET}
}
|
Changes to library/tzdata/Asia/Hebron.
| ︙ | ︙ | |||
112 113 114 115 116 117 118 |
{1445547600 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}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
{1445547600 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}
{1572040800 7200 0 EET}
{1585260000 10800 1 EEST}
{1604095200 7200 0 EET}
{1616709600 10800 1 EEST}
{1635544800 7200 0 EET}
{1648159200 10800 1 EEST}
{1666994400 7200 0 EET}
{1680213600 10800 1 EEST}
{1698444000 7200 0 EET}
{1711663200 10800 1 EEST}
{1729893600 7200 0 EET}
{1743112800 10800 1 EEST}
{1761343200 7200 0 EET}
{1774562400 10800 1 EEST}
{1793397600 7200 0 EET}
{1806012000 10800 1 EEST}
{1824847200 7200 0 EET}
{1838066400 10800 1 EEST}
{1856296800 7200 0 EET}
{1869516000 10800 1 EEST}
{1887746400 7200 0 EET}
{1900965600 10800 1 EEST}
{1919196000 7200 0 EET}
{1932415200 10800 1 EEST}
{1950645600 7200 0 EET}
{1963864800 10800 1 EEST}
{1982700000 7200 0 EET}
{1995314400 10800 1 EEST}
{2014149600 7200 0 EET}
{2027368800 10800 1 EEST}
{2045599200 7200 0 EET}
{2058818400 10800 1 EEST}
{2077048800 7200 0 EET}
{2090268000 10800 1 EEST}
{2108498400 7200 0 EET}
{2121717600 10800 1 EEST}
{2140552800 7200 0 EET}
{2153167200 10800 1 EEST}
{2172002400 7200 0 EET}
{2184616800 10800 1 EEST}
{2203452000 7200 0 EET}
{2216671200 10800 1 EEST}
{2234901600 7200 0 EET}
{2248120800 10800 1 EEST}
{2266351200 7200 0 EET}
{2279570400 10800 1 EEST}
{2297800800 7200 0 EET}
{2311020000 10800 1 EEST}
{2329855200 7200 0 EET}
{2342469600 10800 1 EEST}
{2361304800 7200 0 EET}
{2374524000 10800 1 EEST}
{2392754400 7200 0 EET}
{2405973600 10800 1 EEST}
{2424204000 7200 0 EET}
{2437423200 10800 1 EEST}
{2455653600 7200 0 EET}
{2468872800 10800 1 EEST}
{2487708000 7200 0 EET}
{2500322400 10800 1 EEST}
{2519157600 7200 0 EET}
{2531772000 10800 1 EEST}
{2550607200 7200 0 EET}
{2563826400 10800 1 EEST}
{2582056800 7200 0 EET}
{2595276000 10800 1 EEST}
{2613506400 7200 0 EET}
{2626725600 10800 1 EEST}
{2644956000 7200 0 EET}
{2658175200 10800 1 EEST}
{2677010400 7200 0 EET}
{2689624800 10800 1 EEST}
{2708460000 7200 0 EET}
{2721679200 10800 1 EEST}
{2739909600 7200 0 EET}
{2753128800 10800 1 EEST}
{2771359200 7200 0 EET}
{2784578400 10800 1 EEST}
{2802808800 7200 0 EET}
{2816028000 10800 1 EEST}
{2834258400 7200 0 EET}
{2847477600 10800 1 EEST}
{2866312800 7200 0 EET}
{2878927200 10800 1 EEST}
{2897762400 7200 0 EET}
{2910981600 10800 1 EEST}
{2929212000 7200 0 EET}
{2942431200 10800 1 EEST}
{2960661600 7200 0 EET}
{2973880800 10800 1 EEST}
{2992111200 7200 0 EET}
{3005330400 10800 1 EEST}
{3024165600 7200 0 EET}
{3036780000 10800 1 EEST}
{3055615200 7200 0 EET}
{3068229600 10800 1 EEST}
{3087064800 7200 0 EET}
{3100284000 10800 1 EEST}
{3118514400 7200 0 EET}
{3131733600 10800 1 EEST}
{3149964000 7200 0 EET}
{3163183200 10800 1 EEST}
{3181413600 7200 0 EET}
{3194632800 10800 1 EEST}
{3213468000 7200 0 EET}
{3226082400 10800 1 EEST}
{3244917600 7200 0 EET}
{3258136800 10800 1 EEST}
{3276367200 7200 0 EET}
{3289586400 10800 1 EEST}
{3307816800 7200 0 EET}
{3321036000 10800 1 EEST}
{3339266400 7200 0 EET}
{3352485600 10800 1 EEST}
{3371320800 7200 0 EET}
{3383935200 10800 1 EEST}
{3402770400 7200 0 EET}
{3415384800 10800 1 EEST}
{3434220000 7200 0 EET}
{3447439200 10800 1 EEST}
{3465669600 7200 0 EET}
{3478888800 10800 1 EEST}
{3497119200 7200 0 EET}
{3510338400 10800 1 EEST}
{3528568800 7200 0 EET}
{3541788000 10800 1 EEST}
{3560623200 7200 0 EET}
{3573237600 10800 1 EEST}
{3592072800 7200 0 EET}
{3605292000 10800 1 EEST}
{3623522400 7200 0 EET}
{3636741600 10800 1 EEST}
{3654972000 7200 0 EET}
{3668191200 10800 1 EEST}
{3686421600 7200 0 EET}
{3699640800 10800 1 EEST}
{3717871200 7200 0 EET}
{3731090400 10800 1 EEST}
{3749925600 7200 0 EET}
{3762540000 10800 1 EEST}
{3781375200 7200 0 EET}
{3794594400 10800 1 EEST}
{3812824800 7200 0 EET}
{3826044000 10800 1 EEST}
{3844274400 7200 0 EET}
{3857493600 10800 1 EEST}
{3875724000 7200 0 EET}
{3888943200 10800 1 EEST}
{3907778400 7200 0 EET}
{3920392800 10800 1 EEST}
{3939228000 7200 0 EET}
{3951842400 10800 1 EEST}
{3970677600 7200 0 EET}
{3983896800 10800 1 EEST}
{4002127200 7200 0 EET}
{4015346400 10800 1 EEST}
{4033576800 7200 0 EET}
{4046796000 10800 1 EEST}
{4065026400 7200 0 EET}
{4078245600 10800 1 EEST}
{4097080800 7200 0 EET}
}
|
Changes to library/tzdata/Asia/Hong_Kong.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Hong_Kong) {
{-9223372036854775808 27402 0 LMT}
{-2056690800 28800 0 HKT}
| | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Hong_Kong) {
{-9223372036854775808 27402 0 LMT}
{-2056690800 28800 0 HKT}
{-900910800 32400 1 HKST}
{-891579600 30600 1 HKWT}
{-884248200 32400 0 JST}
{-761209200 28800 0 HKT}
{-747907200 32400 1 HKST}
{-728541000 28800 0 HKT}
{-717049800 32400 1 HKST}
{-697091400 28800 0 HKT}
{-683785800 32400 1 HKST}
{-668061000 28800 0 HKT}
{-654755400 32400 1 HKST}
{-636611400 28800 0 HKT}
{-623305800 32400 1 HKST}
{-605161800 28800 0 HKT}
{-591856200 32400 1 HKST}
{-573712200 28800 0 HKT}
{-559801800 32400 1 HKST}
{-541657800 28800 0 HKT}
{-528352200 32400 1 HKST}
{-510211800 28800 0 HKT}
{-498112200 32400 1 HKST}
{-478762200 28800 0 HKT}
{-466662600 32400 1 HKST}
{-446707800 28800 0 HKT}
{-435213000 32400 1 HKST}
|
| ︙ | ︙ |
Changes to library/tzdata/Asia/Seoul.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Seoul) {
{-9223372036854775808 30472 0 LMT}
{-1948782472 30600 0 KST}
{-1830414600 32400 0 JST}
{-767350800 32400 0 KST}
{-498128400 30600 0 KST}
{-462702600 34200 1 KDT}
{-451733400 30600 0 KST}
{-429784200 34200 1 KDT}
{-418296600 30600 0 KST}
{-399544200 34200 1 KDT}
{-387451800 30600 0 KST}
| > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Seoul) {
{-9223372036854775808 30472 0 LMT}
{-1948782472 30600 0 KST}
{-1830414600 32400 0 JST}
{-767350800 32400 0 KST}
{-681210000 36000 1 KDT}
{-672228000 32400 0 KST}
{-654771600 36000 1 KDT}
{-640864800 32400 0 KST}
{-623408400 36000 1 KDT}
{-609415200 32400 0 KST}
{-588848400 36000 1 KDT}
{-577965600 32400 0 KST}
{-498128400 30600 0 KST}
{-462702600 34200 1 KDT}
{-451733400 30600 0 KST}
{-429784200 34200 1 KDT}
{-418296600 30600 0 KST}
{-399544200 34200 1 KDT}
{-387451800 30600 0 KST}
|
| ︙ | ︙ |
Changes to library/tzdata/Asia/Shanghai.
1 2 3 4 5 6 7 8 9 10 11 12 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Shanghai) {
{-9223372036854775808 29143 0 LMT}
{-2177481943 28800 0 CST}
{-933667200 32400 1 CDT}
{-922093200 28800 0 CST}
{-908870400 32400 1 CDT}
{-888829200 28800 0 CST}
{-881049600 32400 1 CDT}
{-767869200 28800 0 CST}
{-745833600 32400 1 CDT}
| > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Asia/Shanghai) {
{-9223372036854775808 29143 0 LMT}
{-2177481943 28800 0 CST}
{-1600675200 32400 1 CDT}
{-1585904400 28800 0 CST}
{-933667200 32400 1 CDT}
{-922093200 28800 0 CST}
{-908870400 32400 1 CDT}
{-888829200 28800 0 CST}
{-881049600 32400 1 CDT}
{-767869200 28800 0 CST}
{-745833600 32400 1 CDT}
|
| ︙ | ︙ |
Changes to library/tzdata/Europe/Brussels.
1 2 3 4 5 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Brussels) {
{-9223372036854775808 1050 0 LMT}
{-2840141850 1050 0 BMT}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Brussels) {
{-9223372036854775808 1050 0 LMT}
{-2840141850 1050 0 BMT}
{-2450995200 0 0 WET}
{-1740355200 3600 0 CET}
{-1693702800 7200 0 CEST}
{-1680483600 3600 0 CET}
{-1663455600 7200 1 CEST}
{-1650150000 3600 0 CET}
{-1632006000 7200 1 CEST}
{-1618700400 3600 0 CET}
|
| ︙ | ︙ |
Changes to library/tzdata/Europe/Istanbul.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 |
{-1522551600 7200 0 EET}
{-1507514400 10800 1 EEST}
{-1490583600 7200 0 EET}
{-1440208800 10800 1 EEST}
{-1428030000 7200 0 EET}
{-1409709600 10800 1 EEST}
{-1396494000 7200 0 EET}
| | | < < | | | < < < < < < | | | | | | | | | < < | < | | | < < < < | | | | 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 |
{-1522551600 7200 0 EET}
{-1507514400 10800 1 EEST}
{-1490583600 7200 0 EET}
{-1440208800 10800 1 EEST}
{-1428030000 7200 0 EET}
{-1409709600 10800 1 EEST}
{-1396494000 7200 0 EET}
{-931053600 10800 1 EEST}
{-922676400 7200 0 EET}
{-917834400 10800 1 EEST}
{-892436400 7200 0 EET}
{-875844000 10800 1 EEST}
{-764737200 7200 0 EET}
{-744343200 10800 1 EEST}
{-733806000 7200 0 EET}
{-716436000 10800 1 EEST}
{-701924400 7200 0 EET}
{-684986400 10800 1 EEST}
{-670474800 7200 0 EET}
{-654141600 10800 1 EEST}
{-639025200 7200 0 EET}
{-622087200 10800 1 EEST}
{-606970800 7200 0 EET}
{-590032800 10800 1 EEST}
{-575521200 7200 0 EET}
{-235620000 10800 1 EEST}
{-194842800 7200 0 EET}
{-177732000 10800 1 EEST}
{-165726000 7200 0 EET}
{107910000 10800 1 EEST}
{121215600 7200 0 EET}
{133920000 10800 1 EEST}
{152665200 7200 0 EET}
{164678400 10800 1 EEST}
{184114800 7200 0 EET}
{196214400 10800 1 EEST}
{215564400 7200 0 EET}
{228873600 10800 1 EEST}
{245804400 7200 0 EET}
{260323200 10800 1 EEST}
{267919200 10800 0 +03}
{277254000 10800 0 +03}
{428454000 14400 1 +04}
{433893600 10800 0 +03}
{468111600 7200 0 EET}
{482799600 10800 1 EEST}
{496710000 7200 0 EET}
{512521200 10800 1 EEST}
{528246000 7200 0 EET}
{543970800 10800 1 EEST}
{559695600 7200 0 EET}
{575420400 10800 1 EEST}
{591145200 7200 0 EET}
{606870000 10800 1 EEST}
|
| ︙ | ︙ |
Changes to library/tzdata/Europe/Kaliningrad.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 |
{-1618700400 3600 0 CET}
{-938905200 7200 1 CEST}
{-857257200 3600 0 CET}
{-844556400 7200 1 CEST}
{-828226800 3600 0 CET}
{-812502000 7200 1 CEST}
{-796777200 3600 0 CET}
| > | | | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
{-1618700400 3600 0 CET}
{-938905200 7200 1 CEST}
{-857257200 3600 0 CET}
{-844556400 7200 1 CEST}
{-828226800 3600 0 CET}
{-812502000 7200 1 CEST}
{-796777200 3600 0 CET}
{-781052400 7200 1 CEST}
{-780368400 7200 0 EET}
{-778730400 10800 1 EEST}
{-762663600 7200 0 EET}
{-749095200 10800 0 MSD}
{354920400 14400 1 MSD}
{370728000 10800 0 MSK}
{386456400 14400 1 MSD}
{402264000 10800 0 MSK}
{417992400 14400 1 MSD}
{433800000 10800 0 MSK}
{449614800 14400 1 MSD}
|
| ︙ | ︙ |
Changes to library/tzdata/Europe/Rome.
1 2 3 4 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Rome) {
{-9223372036854775808 2996 0 LMT}
| | | 1 2 3 4 5 6 7 8 9 10 11 12 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Europe/Rome) {
{-9223372036854775808 2996 0 LMT}
{-3252098996 2996 0 RMT}
{-2403565200 3600 0 CET}
{-1690765200 7200 1 CEST}
{-1680487200 3600 0 CET}
{-1664758800 7200 1 CEST}
{-1648951200 3600 0 CET}
{-1635123600 7200 1 CEST}
{-1616896800 3600 0 CET}
|
| ︙ | ︙ |
Changes to library/tzdata/Europe/Vienna.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 |
{-828226800 3600 0 CET}
{-812502000 7200 1 CEST}
{-796777200 3600 0 CET}
{-781052400 7200 1 CEST}
{-780188400 3600 0 CET}
{-757386000 3600 0 CET}
{-748479600 7200 1 CEST}
| | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
{-828226800 3600 0 CET}
{-812502000 7200 1 CEST}
{-796777200 3600 0 CET}
{-781052400 7200 1 CEST}
{-780188400 3600 0 CET}
{-757386000 3600 0 CET}
{-748479600 7200 1 CEST}
{-733273200 3600 0 CET}
{-717634800 7200 1 CEST}
{-701910000 3600 0 CET}
{-684975600 7200 1 CEST}
{-670460400 3600 0 CET}
{323823600 7200 1 CEST}
{338940000 3600 0 CET}
{347151600 3600 0 CET}
|
| ︙ | ︙ |
Changes to library/tzdata/Pacific/Fiji.
| ︙ | ︙ | |||
23 24 25 26 27 28 29 |
{1452952800 43200 0 +12}
{1478354400 46800 1 +12}
{1484402400 43200 0 +12}
{1509804000 46800 1 +12}
{1515852000 43200 0 +12}
{1541253600 46800 1 +12}
{1547301600 43200 0 +12}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 |
{1452952800 43200 0 +12}
{1478354400 46800 1 +12}
{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}
{1604757600 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}
{1731160800 46800 1 +12}
{1736604000 43200 0 +12}
{1762610400 46800 1 +12}
{1768658400 43200 0 +12}
{1794060000 46800 1 +12}
{1800108000 43200 0 +12}
{1826114400 46800 1 +12}
{1831557600 43200 0 +12}
{1857564000 46800 1 +12}
{1863007200 43200 0 +12}
{1889013600 46800 1 +12}
{1894456800 43200 0 +12}
{1920463200 46800 1 +12}
{1925906400 43200 0 +12}
{1951912800 46800 1 +12}
{1957960800 43200 0 +12}
{1983967200 46800 1 +12}
{1989410400 43200 0 +12}
{2015416800 46800 1 +12}
{2020860000 43200 0 +12}
{2046866400 46800 1 +12}
{2052309600 43200 0 +12}
{2078316000 46800 1 +12}
{2083759200 43200 0 +12}
{2109765600 46800 1 +12}
{2115813600 43200 0 +12}
{2141215200 46800 1 +12}
{2147263200 43200 0 +12}
{2173269600 46800 1 +12}
{2178712800 43200 0 +12}
{2204719200 46800 1 +12}
{2210162400 43200 0 +12}
{2236168800 46800 1 +12}
{2241612000 43200 0 +12}
{2267618400 46800 1 +12}
{2273061600 43200 0 +12}
{2299068000 46800 1 +12}
{2305116000 43200 0 +12}
{2330517600 46800 1 +12}
{2336565600 43200 0 +12}
{2362572000 46800 1 +12}
{2368015200 43200 0 +12}
{2394021600 46800 1 +12}
{2399464800 43200 0 +12}
{2425471200 46800 1 +12}
{2430914400 43200 0 +12}
{2456920800 46800 1 +12}
{2462364000 43200 0 +12}
{2488370400 46800 1 +12}
{2494418400 43200 0 +12}
{2520424800 46800 1 +12}
{2525868000 43200 0 +12}
{2551874400 46800 1 +12}
{2557317600 43200 0 +12}
{2583324000 46800 1 +12}
{2588767200 43200 0 +12}
{2614773600 46800 1 +12}
{2620216800 43200 0 +12}
{2646223200 46800 1 +12}
{2652271200 43200 0 +12}
{2677672800 46800 1 +12}
{2683720800 43200 0 +12}
{2709727200 46800 1 +12}
{2715170400 43200 0 +12}
{2741176800 46800 1 +12}
{2746620000 43200 0 +12}
{2772626400 46800 1 +12}
{2778069600 43200 0 +12}
{2804076000 46800 1 +12}
{2809519200 43200 0 +12}
{2835525600 46800 1 +12}
{2841573600 43200 0 +12}
{2867580000 46800 1 +12}
{2873023200 43200 0 +12}
{2899029600 46800 1 +12}
{2904472800 43200 0 +12}
{2930479200 46800 1 +12}
{2935922400 43200 0 +12}
{2961928800 46800 1 +12}
{2967372000 43200 0 +12}
{2993378400 46800 1 +12}
{2999426400 43200 0 +12}
{3024828000 46800 1 +12}
{3030876000 43200 0 +12}
{3056882400 46800 1 +12}
{3062325600 43200 0 +12}
{3088332000 46800 1 +12}
{3093775200 43200 0 +12}
{3119781600 46800 1 +12}
{3125224800 43200 0 +12}
{3151231200 46800 1 +12}
{3156674400 43200 0 +12}
{3182680800 46800 1 +12}
{3188728800 43200 0 +12}
{3214130400 46800 1 +12}
{3220178400 43200 0 +12}
{3246184800 46800 1 +12}
{3251628000 43200 0 +12}
{3277634400 46800 1 +12}
{3283077600 43200 0 +12}
{3309084000 46800 1 +12}
{3314527200 43200 0 +12}
{3340533600 46800 1 +12}
{3345976800 43200 0 +12}
{3371983200 46800 1 +12}
{3378031200 43200 0 +12}
{3404037600 46800 1 +12}
{3409480800 43200 0 +12}
{3435487200 46800 1 +12}
{3440930400 43200 0 +12}
{3466936800 46800 1 +12}
{3472380000 43200 0 +12}
{3498386400 46800 1 +12}
{3503829600 43200 0 +12}
{3529836000 46800 1 +12}
{3535884000 43200 0 +12}
{3561285600 46800 1 +12}
{3567333600 43200 0 +12}
{3593340000 46800 1 +12}
{3598783200 43200 0 +12}
{3624789600 46800 1 +12}
{3630232800 43200 0 +12}
{3656239200 46800 1 +12}
{3661682400 43200 0 +12}
{3687688800 46800 1 +12}
{3693132000 43200 0 +12}
{3719138400 46800 1 +12}
{3725186400 43200 0 +12}
{3751192800 46800 1 +12}
{3756636000 43200 0 +12}
{3782642400 46800 1 +12}
{3788085600 43200 0 +12}
{3814092000 46800 1 +12}
{3819535200 43200 0 +12}
{3845541600 46800 1 +12}
{3850984800 43200 0 +12}
{3876991200 46800 1 +12}
{3883039200 43200 0 +12}
{3908440800 46800 1 +12}
{3914488800 43200 0 +12}
{3940495200 46800 1 +12}
{3945938400 43200 0 +12}
{3971944800 46800 1 +12}
{3977388000 43200 0 +12}
{4003394400 46800 1 +12}
{4008837600 43200 0 +12}
{4034844000 46800 1 +12}
{4040287200 43200 0 +12}
{4066293600 46800 1 +12}
{4072341600 43200 0 +12}
{4097743200 46800 1 +12}
}
|
Changes to library/tzdata/Pacific/Norfolk.
1 2 3 4 5 6 7 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Norfolk) {
{-9223372036854775808 40312 0 LMT}
{-2177493112 40320 0 +1112}
{-599656320 41400 0 +1130}
{152029800 45000 1 +1230}
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 |
# created by tools/tclZIC.tcl - do not edit
set TZData(:Pacific/Norfolk) {
{-9223372036854775808 40312 0 LMT}
{-2177493112 40320 0 +1112}
{-599656320 41400 0 +1130}
{152029800 45000 1 +1230}
{162916200 41400 0 +1130}
{1443882600 39600 0 +11}
{1561899600 39600 0 +12}
{1570287600 43200 1 +12}
{1586012400 39600 0 +12}
{1601737200 43200 1 +12}
{1617462000 39600 0 +12}
{1633186800 43200 1 +12}
{1648911600 39600 0 +12}
{1664636400 43200 1 +12}
{1680361200 39600 0 +12}
{1696086000 43200 1 +12}
{1712415600 39600 0 +12}
{1728140400 43200 1 +12}
{1743865200 39600 0 +12}
{1759590000 43200 1 +12}
{1775314800 39600 0 +12}
{1791039600 43200 1 +12}
{1806764400 39600 0 +12}
{1822489200 43200 1 +12}
{1838214000 39600 0 +12}
{1853938800 43200 1 +12}
{1869663600 39600 0 +12}
{1885993200 43200 1 +12}
{1901718000 39600 0 +12}
{1917442800 43200 1 +12}
{1933167600 39600 0 +12}
{1948892400 43200 1 +12}
{1964617200 39600 0 +12}
{1980342000 43200 1 +12}
{1996066800 39600 0 +12}
{2011791600 43200 1 +12}
{2027516400 39600 0 +12}
{2043241200 43200 1 +12}
{2058966000 39600 0 +12}
{2075295600 43200 1 +12}
{2091020400 39600 0 +12}
{2106745200 43200 1 +12}
{2122470000 39600 0 +12}
{2138194800 43200 1 +12}
{2153919600 39600 0 +12}
{2169644400 43200 1 +12}
{2185369200 39600 0 +12}
{2201094000 43200 1 +12}
{2216818800 39600 0 +12}
{2233148400 43200 1 +12}
{2248873200 39600 0 +12}
{2264598000 43200 1 +12}
{2280322800 39600 0 +12}
{2296047600 43200 1 +12}
{2311772400 39600 0 +12}
{2327497200 43200 1 +12}
{2343222000 39600 0 +12}
{2358946800 43200 1 +12}
{2374671600 39600 0 +12}
{2390396400 43200 1 +12}
{2406121200 39600 0 +12}
{2422450800 43200 1 +12}
{2438175600 39600 0 +12}
{2453900400 43200 1 +12}
{2469625200 39600 0 +12}
{2485350000 43200 1 +12}
{2501074800 39600 0 +12}
{2516799600 43200 1 +12}
{2532524400 39600 0 +12}
{2548249200 43200 1 +12}
{2563974000 39600 0 +12}
{2579698800 43200 1 +12}
{2596028400 39600 0 +12}
{2611753200 43200 1 +12}
{2627478000 39600 0 +12}
{2643202800 43200 1 +12}
{2658927600 39600 0 +12}
{2674652400 43200 1 +12}
{2690377200 39600 0 +12}
{2706102000 43200 1 +12}
{2721826800 39600 0 +12}
{2737551600 43200 1 +12}
{2753276400 39600 0 +12}
{2769606000 43200 1 +12}
{2785330800 39600 0 +12}
{2801055600 43200 1 +12}
{2816780400 39600 0 +12}
{2832505200 43200 1 +12}
{2848230000 39600 0 +12}
{2863954800 43200 1 +12}
{2879679600 39600 0 +12}
{2895404400 43200 1 +12}
{2911129200 39600 0 +12}
{2926854000 43200 1 +12}
{2942578800 39600 0 +12}
{2958908400 43200 1 +12}
{2974633200 39600 0 +12}
{2990358000 43200 1 +12}
{3006082800 39600 0 +12}
{3021807600 43200 1 +12}
{3037532400 39600 0 +12}
{3053257200 43200 1 +12}
{3068982000 39600 0 +12}
{3084706800 43200 1 +12}
{3100431600 39600 0 +12}
{3116761200 43200 1 +12}
{3132486000 39600 0 +12}
{3148210800 43200 1 +12}
{3163935600 39600 0 +12}
{3179660400 43200 1 +12}
{3195385200 39600 0 +12}
{3211110000 43200 1 +12}
{3226834800 39600 0 +12}
{3242559600 43200 1 +12}
{3258284400 39600 0 +12}
{3274009200 43200 1 +12}
{3289734000 39600 0 +12}
{3306063600 43200 1 +12}
{3321788400 39600 0 +12}
{3337513200 43200 1 +12}
{3353238000 39600 0 +12}
{3368962800 43200 1 +12}
{3384687600 39600 0 +12}
{3400412400 43200 1 +12}
{3416137200 39600 0 +12}
{3431862000 43200 1 +12}
{3447586800 39600 0 +12}
{3463311600 43200 1 +12}
{3479641200 39600 0 +12}
{3495366000 43200 1 +12}
{3511090800 39600 0 +12}
{3526815600 43200 1 +12}
{3542540400 39600 0 +12}
{3558265200 43200 1 +12}
{3573990000 39600 0 +12}
{3589714800 43200 1 +12}
{3605439600 39600 0 +12}
{3621164400 43200 1 +12}
{3636889200 39600 0 +12}
{3653218800 43200 1 +12}
{3668943600 39600 0 +12}
{3684668400 43200 1 +12}
{3700393200 39600 0 +12}
{3716118000 43200 1 +12}
{3731842800 39600 0 +12}
{3747567600 43200 1 +12}
{3763292400 39600 0 +12}
{3779017200 43200 1 +12}
{3794742000 39600 0 +12}
{3810466800 43200 1 +12}
{3826191600 39600 0 +12}
{3842521200 43200 1 +12}
{3858246000 39600 0 +12}
{3873970800 43200 1 +12}
{3889695600 39600 0 +12}
{3905420400 43200 1 +12}
{3921145200 39600 0 +12}
{3936870000 43200 1 +12}
{3952594800 39600 0 +12}
{3968319600 43200 1 +12}
{3984044400 39600 0 +12}
{4000374000 43200 1 +12}
{4016098800 39600 0 +12}
{4031823600 43200 1 +12}
{4047548400 39600 0 +12}
{4063273200 43200 1 +12}
{4078998000 39600 0 +12}
{4094722800 43200 1 +12}
}
|
Added library/tzdata/SystemV/AST4.
> > > > > | 1 2 3 4 5 |
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Puerto_Rico)]} {
LoadTimeZoneFile America/Puerto_Rico
}
set TZData(:SystemV/AST4) $TZData(:America/Puerto_Rico)
|
Added library/tzdata/SystemV/AST4ADT.
> > > > > | 1 2 3 4 5 |
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Halifax)]} {
LoadTimeZoneFile America/Halifax
}
set TZData(:SystemV/AST4ADT) $TZData(:America/Halifax)
|
Added library/tzdata/SystemV/CST6.
> > > > > | 1 2 3 4 5 |
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Regina)]} {
LoadTimeZoneFile America/Regina
}
set TZData(:SystemV/CST6) $TZData(:America/Regina)
|
Added library/tzdata/SystemV/CST6CDT.
> > > > > | 1 2 3 4 5 |
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Chicago)]} {
LoadTimeZoneFile America/Chicago
}
set TZData(:SystemV/CST6CDT) $TZData(:America/Chicago)
|
Added library/tzdata/SystemV/EST5.
> > > > > | 1 2 3 4 5 |
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Indianapolis)]} {
LoadTimeZoneFile America/Indianapolis
}
set TZData(:SystemV/EST5) $TZData(:America/Indianapolis)
|
Added library/tzdata/SystemV/EST5EDT.
> > > > > | 1 2 3 4 5 |
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/New_York)]} {
LoadTimeZoneFile America/New_York
}
set TZData(:SystemV/EST5EDT) $TZData(:America/New_York)
|
Added library/tzdata/SystemV/HST10.
> > > > > | 1 2 3 4 5 |
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(Pacific/Honolulu)]} {
LoadTimeZoneFile Pacific/Honolulu
}
set TZData(:SystemV/HST10) $TZData(:Pacific/Honolulu)
|
Added library/tzdata/SystemV/MST7.
> > > > > | 1 2 3 4 5 |
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Phoenix)]} {
LoadTimeZoneFile America/Phoenix
}
set TZData(:SystemV/MST7) $TZData(:America/Phoenix)
|
Added library/tzdata/SystemV/MST7MDT.
> > > > > | 1 2 3 4 5 |
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Denver)]} {
LoadTimeZoneFile America/Denver
}
set TZData(:SystemV/MST7MDT) $TZData(:America/Denver)
|
Added library/tzdata/SystemV/PST8.
> > > > > | 1 2 3 4 5 |
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(Pacific/Pitcairn)]} {
LoadTimeZoneFile Pacific/Pitcairn
}
set TZData(:SystemV/PST8) $TZData(:Pacific/Pitcairn)
|
Added library/tzdata/SystemV/PST8PDT.
> > > > > | 1 2 3 4 5 |
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Los_Angeles)]} {
LoadTimeZoneFile America/Los_Angeles
}
set TZData(:SystemV/PST8PDT) $TZData(:America/Los_Angeles)
|
Added library/tzdata/SystemV/YST9.
> > > > > | 1 2 3 4 5 |
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(Pacific/Gambier)]} {
LoadTimeZoneFile Pacific/Gambier
}
set TZData(:SystemV/YST9) $TZData(:Pacific/Gambier)
|
Added library/tzdata/SystemV/YST9YDT.
> > > > > | 1 2 3 4 5 |
# created by ../tools/tclZIC.tcl - do not edit
if {![info exists TZData(America/Anchorage)]} {
LoadTimeZoneFile America/Anchorage
}
set TZData(:SystemV/YST9YDT) $TZData(:America/Anchorage)
|
Changes to libtommath/README.md.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | # libtommath This is the git repository for [LibTomMath](http://www.libtom.net/LibTomMath/), a free open source portable number theoretic multiple-precision integer (MPI) library written entirely in C. ## Build Status master: [](https://travis-ci.org/libtom/libtommath) develop: [](https://travis-ci.org/libtom/libtommath) API/ABI changes: [check here](https://abi-laboratory.pro/tracker/timeline/libtommath/) ## Summary The `develop` branch contains the in-development version. Stable releases are tagged. | > > > > > > > > > > | > | > > > > | > | > > > | 1 2 3 4 5 6 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 | # libtommath This is the git repository for [LibTomMath](http://www.libtom.net/LibTomMath/), a free open source portable number theoretic multiple-precision integer (MPI) library written entirely in C. ## Build Status ### Travis CI master: [](https://travis-ci.org/libtom/libtommath) develop: [](https://travis-ci.org/libtom/libtommath) ### AppVeyor master: [](https://ci.appveyor.com/project/libtom/libtommath/branch/master) develop: [](https://ci.appveyor.com/project/libtom/libtommath/branch/develop) ### ABI Laboratory API/ABI changes: [check here](https://abi-laboratory.pro/tracker/timeline/libtommath/) ## Summary The `develop` branch contains the in-development version. Stable releases are tagged. Documentation is built from the LaTeX file `bn.tex`. There is also limited documentation in `tommath.h`. There is also a document, `tommath.pdf`, which describes the goals of the project and many of the algorithms used. The project can be build by using `make`. Along with the usual `make`, `make clean` and `make install`, there are several other build targets, see the makefile for details. There are also makefiles for certain specific platforms. ## Testing Tests are located in `demo/` and can be built in two flavors. * `make test` creates a stand-alone test binary that executes several test routines. * `make mtest_opponent` creates a test binary that is intended to be run against `mtest`. `mtest` can be built with `make mtest` and test execution is done like `./mtest/mtest | ./mtest_opponent`. `mtest` is creating test vectors using an alternative MPI library and `test` is consuming these vectors to verify correct behavior of ltm ## Building and Installing Building is straightforward for GNU Linux only, the section "Building LibTomMath" in the documentation in `doc/bn.pdf` has the details. |
Added libtommath/appveyor.yml.
> > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
version: 1.2.0-{build}
branches:
only:
- master
- develop
- /^release/
- /^support/
- /^travis/
image:
- Visual Studio 2019
- Visual Studio 2017
- Visual Studio 2015
build_script:
- cmd: >-
if "Visual Studio 2019"=="%APPVEYOR_BUILD_WORKER_IMAGE%" call "C:\Program Files (x86)\Microsoft Visual Studio\2019\Community\VC\Auxiliary\Build\vcvars64.bat"
if "Visual Studio 2017"=="%APPVEYOR_BUILD_WORKER_IMAGE%" call "C:\Program Files (x86)\Microsoft Visual Studio\2017\Community\VC\Auxiliary\Build\vcvars64.bat"
if "Visual Studio 2015"=="%APPVEYOR_BUILD_WORKER_IMAGE%" call "C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin\SetEnv.cmd" /x64
if "Visual Studio 2015"=="%APPVEYOR_BUILD_WORKER_IMAGE%" call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\vcvarsall.bat" x86_amd64
nmake -f makefile.msvc all
test_script:
- cmd: test.exe
|
Changes to libtommath/astylerc.
1 2 3 4 5 6 7 8 9 10 11 12 | # Artistic Style, see http://astyle.sourceforge.net/ # full documentation, see: http://astyle.sourceforge.net/astyle.html # # usage: # astyle --options=astylerc *.[ch] ## Bracket Style Options style=kr ## Tab Options indent=spaces=3 | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | # Artistic Style, see http://astyle.sourceforge.net/ # full documentation, see: http://astyle.sourceforge.net/astyle.html # # usage: # astyle --options=astylerc *.[ch] # Do not create backup, annonying in the times of git suffix=none ## Bracket Style Options style=kr ## Tab Options indent=spaces=3 |
| ︙ | ︙ |
Added libtommath/bn_cutoffs.c.
> > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
#include "tommath_private.h"
#ifdef BN_CUTOFFS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
#ifndef MP_FIXED_CUTOFFS
#include "tommath_cutoffs.h"
int KARATSUBA_MUL_CUTOFF = MP_DEFAULT_KARATSUBA_MUL_CUTOFF,
KARATSUBA_SQR_CUTOFF = MP_DEFAULT_KARATSUBA_SQR_CUTOFF,
TOOM_MUL_CUTOFF = MP_DEFAULT_TOOM_MUL_CUTOFF,
TOOM_SQR_CUTOFF = MP_DEFAULT_TOOM_SQR_CUTOFF;
#endif
#endif
|
Added libtommath/bn_deprecated.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 |
#include "tommath_private.h"
#ifdef BN_DEPRECATED_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
#ifdef BN_MP_GET_BIT_C
int mp_get_bit(const mp_int *a, int b)
{
if (b < 0) {
return MP_VAL;
}
return (s_mp_get_bit(a, (unsigned int)b) == MP_YES) ? MP_YES : MP_NO;
}
#endif
#ifdef BN_MP_JACOBI_C
mp_err mp_jacobi(const mp_int *a, const mp_int *n, int *c)
{
if (a->sign == MP_NEG) {
return MP_VAL;
}
if (mp_cmp_d(n, 0uL) != MP_GT) {
return MP_VAL;
}
return mp_kronecker(a, n, c);
}
#endif
#ifdef BN_MP_PRIME_RANDOM_EX_C
mp_err mp_prime_random_ex(mp_int *a, int t, int size, int flags, private_mp_prime_callback cb, void *dat)
{
return s_mp_prime_random_ex(a, t, size, flags, cb, dat);
}
#endif
#ifdef BN_MP_RAND_DIGIT_C
mp_err mp_rand_digit(mp_digit *r)
{
mp_err err = s_mp_rand_source(r, sizeof(mp_digit));
*r &= MP_MASK;
return err;
}
#endif
#ifdef BN_FAST_MP_INVMOD_C
mp_err fast_mp_invmod(const mp_int *a, const mp_int *b, mp_int *c)
{
return s_mp_invmod_fast(a, b, c);
}
#endif
#ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C
mp_err fast_mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho)
{
return s_mp_montgomery_reduce_fast(x, n, rho);
}
#endif
#ifdef BN_FAST_S_MP_MUL_DIGS_C
mp_err fast_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs)
{
return s_mp_mul_digs_fast(a, b, c, digs);
}
#endif
#ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C
mp_err fast_s_mp_mul_high_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs)
{
return s_mp_mul_high_digs_fast(a, b, c, digs);
}
#endif
#ifdef BN_FAST_S_MP_SQR_C
mp_err fast_s_mp_sqr(const mp_int *a, mp_int *b)
{
return s_mp_sqr_fast(a, b);
}
#endif
#ifdef BN_MP_BALANCE_MUL_C
mp_err mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c)
{
return s_mp_balance_mul(a, b, c);
}
#endif
#ifdef BN_MP_EXPTMOD_FAST_C
mp_err mp_exptmod_fast(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode)
{
return s_mp_exptmod_fast(G, X, P, Y, redmode);
}
#endif
#ifdef BN_MP_INVMOD_SLOW_C
mp_err mp_invmod_slow(const mp_int *a, const mp_int *b, mp_int *c)
{
return s_mp_invmod_slow(a, b, c);
}
#endif
#ifdef BN_MP_KARATSUBA_MUL_C
mp_err mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c)
{
return s_mp_karatsuba_mul(a, b, c);
}
#endif
#ifdef BN_MP_KARATSUBA_SQR_C
mp_err mp_karatsuba_sqr(const mp_int *a, mp_int *b)
{
return s_mp_karatsuba_sqr(a, b);
}
#endif
#ifdef BN_MP_TOOM_MUL_C
mp_err mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c)
{
return s_mp_toom_mul(a, b, c);
}
#endif
#ifdef BN_MP_TOOM_SQR_C
mp_err mp_toom_sqr(const mp_int *a, mp_int *b)
{
return s_mp_toom_sqr(a, b);
}
#endif
#ifdef S_MP_REVERSE_C
void bn_reverse(unsigned char *s, int len)
{
if (len > 0) {
s_mp_reverse(s, (size_t)len);
}
}
#endif
#ifdef BN_MP_TC_AND_C
mp_err mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c)
{
return mp_and(a, b, c);
}
#endif
#ifdef BN_MP_TC_OR_C
mp_err mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c)
{
return mp_or(a, b, c);
}
#endif
#ifdef BN_MP_TC_XOR_C
mp_err mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c)
{
return mp_xor(a, b, c);
}
#endif
#ifdef BN_MP_TC_DIV_2D_C
mp_err mp_tc_div_2d(const mp_int *a, int b, mp_int *c)
{
return mp_signed_rsh(a, b, c);
}
#endif
#ifdef BN_MP_INIT_SET_INT_C
mp_err mp_init_set_int(mp_int *a, unsigned long b)
{
return mp_init_u32(a, (uint32_t)b);
}
#endif
#ifdef BN_MP_SET_INT_C
mp_err mp_set_int(mp_int *a, unsigned long b)
{
mp_set_u32(a, (uint32_t)b);
return MP_OKAY;
}
#endif
#ifdef BN_MP_SET_LONG_C
mp_err mp_set_long(mp_int *a, unsigned long b)
{
mp_set_u64(a, b);
return MP_OKAY;
}
#endif
#ifdef BN_MP_SET_LONG_LONG_C
mp_err mp_set_long_long(mp_int *a, unsigned long long b)
{
mp_set_u64(a, b);
return MP_OKAY;
}
#endif
#ifdef BN_MP_GET_INT_C
unsigned long mp_get_int(const mp_int *a)
{
return (unsigned long)mp_get_mag_u32(a);
}
#endif
#ifdef BN_MP_GET_LONG_C
unsigned long mp_get_long(const mp_int *a)
{
return (unsigned long)mp_get_mag_ul(a);
}
#endif
#ifdef BN_MP_GET_LONG_LONG_C
unsigned long long mp_get_long_long(const mp_int *a)
{
return mp_get_mag_ull(a);
}
#endif
#ifdef BN_MP_PRIME_IS_DIVISIBLE_C
mp_err mp_prime_is_divisible(const mp_int *a, mp_bool *result)
{
return s_mp_prime_is_divisible(a, result);
}
#endif
#ifdef BN_MP_EXPT_D_EX_C
mp_err mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast)
{
(void)fast;
if (b > MP_MIN(MP_DIGIT_MAX, UINT32_MAX)) {
return MP_VAL;
}
return mp_expt_u32(a, (uint32_t)b, c);
}
#endif
#ifdef BN_MP_EXPT_D_C
mp_err mp_expt_d(const mp_int *a, mp_digit b, mp_int *c)
{
if (b > MP_MIN(MP_DIGIT_MAX, UINT32_MAX)) {
return MP_VAL;
}
return mp_expt_u32(a, (uint32_t)b, c);
}
#endif
#ifdef BN_MP_N_ROOT_EX_C
mp_err mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast)
{
(void)fast;
if (b > MP_MIN(MP_DIGIT_MAX, UINT32_MAX)) {
return MP_VAL;
}
return mp_root_u32(a, (uint32_t)b, c);
}
#endif
#ifdef BN_MP_N_ROOT_C
mp_err mp_n_root(const mp_int *a, mp_digit b, mp_int *c)
{
if (b > MP_MIN(MP_DIGIT_MAX, UINT32_MAX)) {
return MP_VAL;
}
return mp_root_u32(a, (uint32_t)b, c);
}
#endif
#ifdef BN_MP_UNSIGNED_BIN_SIZE_C
int mp_unsigned_bin_size(const mp_int *a)
{
return (int)mp_ubin_size(a);
}
#endif
#ifdef BN_MP_READ_UNSIGNED_BIN_C
mp_err mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c)
{
return mp_from_ubin(a, b, (size_t) c);
}
#endif
#ifdef BN_MP_TO_UNSIGNED_BIN_C
mp_err mp_to_unsigned_bin(const mp_int *a, unsigned char *b)
{
return mp_to_ubin(a, b, SIZE_MAX, NULL);
}
#endif
#ifdef BN_MP_TO_UNSIGNED_BIN_N_C
mp_err mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen)
{
size_t n = mp_ubin_size(a);
if (*outlen < (unsigned long)n) {
return MP_VAL;
}
*outlen = (unsigned long)n;
return mp_to_ubin(a, b, n, NULL);
}
#endif
#ifdef BN_MP_SIGNED_BIN_SIZE_C
int mp_signed_bin_size(const mp_int *a)
{
return (int)mp_sbin_size(a);
}
#endif
#ifdef BN_MP_READ_SIGNED_BIN_C
mp_err mp_read_signed_bin(mp_int *a, const unsigned char *b, int c)
{
return mp_from_sbin(a, b, (size_t) c);
}
#endif
#ifdef BN_MP_TO_SIGNED_BIN_C
mp_err mp_to_signed_bin(const mp_int *a, unsigned char *b)
{
return mp_to_sbin(a, b, SIZE_MAX, NULL);
}
#endif
#ifdef BN_MP_TO_SIGNED_BIN_N_C
mp_err mp_to_signed_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen)
{
size_t n = mp_sbin_size(a);
if (*outlen < (unsigned long)n) {
return MP_VAL;
}
*outlen = (unsigned long)n;
return mp_to_sbin(a, b, n, NULL);
}
#endif
#ifdef BN_MP_TORADIX_N_C
mp_err mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen)
{
if (maxlen < 0) {
return MP_VAL;
}
return mp_to_radix(a, str, (size_t)maxlen, NULL, radix);
}
#endif
#ifdef BN_MP_TORADIX_C
mp_err mp_toradix(const mp_int *a, char *str, int radix)
{
return mp_to_radix(a, str, SIZE_MAX, NULL, radix);
}
#endif
#ifdef BN_MP_IMPORT_C
mp_err mp_import(mp_int *rop, size_t count, int order, size_t size, int endian, size_t nails,
const void *op)
{
return mp_unpack(rop, count, order, size, endian, nails, op);
}
#endif
#ifdef BN_MP_EXPORT_C
mp_err mp_export(void *rop, size_t *countp, int order, size_t size,
int endian, size_t nails, const mp_int *op)
{
return mp_pack(rop, SIZE_MAX, countp, order, size, endian, nails, op);
}
#endif
#endif
|
Deleted libtommath/bn_error.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/bn_fast_mp_invmod.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/bn_fast_mp_montgomery_reduce.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/bn_fast_s_mp_mul_digs.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/bn_fast_s_mp_mul_high_digs.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/bn_fast_s_mp_sqr.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to libtommath/bn_mp_2expt.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_2EXPT_C | | < < < < < < < < | < | | | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
#include "tommath_private.h"
#ifdef BN_MP_2EXPT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* computes a = 2**b
*
* Simple algorithm which zeroes the int, grows it then just sets one bit
* as required.
*/
mp_err mp_2expt(mp_int *a, int b)
{
mp_err err;
/* zero a as per default */
mp_zero(a);
/* grow a to accomodate the single bit */
if ((err = mp_grow(a, (b / MP_DIGIT_BIT) + 1)) != MP_OKAY) {
return err;
}
/* set the used count of where the bit will go */
a->used = (b / MP_DIGIT_BIT) + 1;
/* put the single bit in its place */
a->dp[b / MP_DIGIT_BIT] = (mp_digit)1 << (mp_digit)(b % MP_DIGIT_BIT);
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_abs.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_ABS_C | | < < < < < < < < | < | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
#include "tommath_private.h"
#ifdef BN_MP_ABS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* b = |a|
*
* Simple function copies the input and fixes the sign to positive
*/
mp_err mp_abs(const mp_int *a, mp_int *b)
{
mp_err err;
/* copy a to b */
if (a != b) {
if ((err = mp_copy(a, b)) != MP_OKAY) {
return err;
}
}
/* force the sign of b to positive */
b->sign = MP_ZPOS;
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_add.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_ADD_C | | < < < < < < < < | < | | > | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
#include "tommath_private.h"
#ifdef BN_MP_ADD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* high level addition (handles signs) */
mp_err mp_add(const mp_int *a, const mp_int *b, mp_int *c)
{
mp_sign sa, sb;
mp_err err;
/* get sign of both inputs */
sa = a->sign;
sb = b->sign;
/* handle two cases, not four */
if (sa == sb) {
/* both positive or both negative */
/* add their magnitudes, copy the sign */
c->sign = sa;
err = s_mp_add(a, b, c);
} else {
/* one positive, the other negative */
/* subtract the one with the greater magnitude from */
/* the one of the lesser magnitude. The result gets */
/* the sign of the one with the greater magnitude. */
if (mp_cmp_mag(a, b) == MP_LT) {
c->sign = sb;
err = s_mp_sub(b, a, c);
} else {
c->sign = sa;
err = s_mp_sub(a, b, c);
}
}
return err;
}
#endif
|
Changes to libtommath/bn_mp_add_d.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_ADD_D_C | | < < < < < < < < | < | > | | | | | | | < < < < < | < | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
#include "tommath_private.h"
#ifdef BN_MP_ADD_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* single digit addition */
mp_err mp_add_d(const mp_int *a, mp_digit b, mp_int *c)
{
mp_err err;
int ix, oldused;
mp_digit *tmpa, *tmpc;
/* grow c as required */
if (c->alloc < (a->used + 1)) {
if ((err = mp_grow(c, a->used + 1)) != MP_OKAY) {
return err;
}
}
/* if a is negative and |a| >= b, call c = |a| - b */
if ((a->sign == MP_NEG) && ((a->used > 1) || (a->dp[0] >= b))) {
mp_int a_ = *a;
/* temporarily fix sign of a */
a_.sign = MP_ZPOS;
/* c = |a| - b */
err = mp_sub_d(&a_, b, c);
/* fix sign */
c->sign = MP_NEG;
/* clamp */
mp_clamp(c);
return err;
}
/* old number of used digits in c */
oldused = c->used;
/* source alias */
tmpa = a->dp;
/* destination alias */
tmpc = c->dp;
/* if a is positive */
if (a->sign == MP_ZPOS) {
/* add digits, mu is carry */
mp_digit mu = b;
for (ix = 0; ix < a->used; ix++) {
*tmpc = *tmpa++ + mu;
mu = *tmpc >> MP_DIGIT_BIT;
*tmpc++ &= MP_MASK;
}
/* set final carry */
ix++;
*tmpc++ = mu;
/* setup size */
|
| ︙ | ︙ | |||
90 91 92 93 94 95 96 |
ix = 1;
}
/* sign always positive */
c->sign = MP_ZPOS;
/* now zero to oldused */
| | < < < < < < | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
ix = 1;
}
/* sign always positive */
c->sign = MP_ZPOS;
/* now zero to oldused */
MP_ZERO_DIGITS(tmpc, oldused - ix);
mp_clamp(c);
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_addmod.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_ADDMOD_C | | < < < < < < < < | < | | | | | < < > | > > | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
#include "tommath_private.h"
#ifdef BN_MP_ADDMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* d = a + b (mod c) */
mp_err mp_addmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d)
{
mp_err err;
mp_int t;
if ((err = mp_init(&t)) != MP_OKAY) {
return err;
}
if ((err = mp_add(a, b, &t)) != MP_OKAY) {
goto LBL_ERR;
}
err = mp_mod(&t, c, d);
LBL_ERR:
mp_clear(&t);
return err;
}
#endif
|
Changes to libtommath/bn_mp_and.c.
1 2 3 4 5 6 7 8 |
#include "tommath_private.h"
#ifdef BN_MP_AND_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* two complement and */
mp_err mp_and(const mp_int *a, const mp_int *b, mp_int *c)
{
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 |
#include "tommath_private.h"
#ifdef BN_MP_AND_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* two complement and */
mp_err mp_and(const mp_int *a, const mp_int *b, mp_int *c)
{
int used = MP_MAX(a->used, b->used) + 1, i;
mp_err err;
mp_digit ac = 1, bc = 1, cc = 1;
mp_sign csign = ((a->sign == MP_NEG) && (b->sign == MP_NEG)) ? MP_NEG : MP_ZPOS;
if (c->alloc < used) {
if ((err = mp_grow(c, used)) != MP_OKAY) {
return err;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_clamp.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_CLAMP_C | | < < < < < < < < | < | 1 2 3 4 5 6 7 8 9 10 11 | #include "tommath_private.h" #ifdef BN_MP_CLAMP_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ /* trim unused digits * * This is used to ensure that leading zero digits are * trimed and the leading "used" digit will be non-zero * Typically very fast. Also fixes the sign if there * are no more leading digits |
| ︙ | ︙ | |||
30 31 32 33 34 35 36 |
/* reset the sign flag if used == 0 */
if (a->used == 0) {
a->sign = MP_ZPOS;
}
}
#endif
| < < < < | 21 22 23 24 25 26 27 |
/* reset the sign flag if used == 0 */
if (a->used == 0) {
a->sign = MP_ZPOS;
}
}
#endif
|
Changes to libtommath/bn_mp_clear.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_CLEAR_C | | < < < < < < < < | < < < < < < < < | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 |
#include "tommath_private.h"
#ifdef BN_MP_CLEAR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* clear one (frees) */
void mp_clear(mp_int *a)
{
/* only do anything if a hasn't been freed previously */
if (a->dp != NULL) {
/* free ram */
MP_FREE_DIGITS(a->dp, a->alloc);
/* reset members to make debugging easier */
a->dp = NULL;
a->alloc = a->used = 0;
a->sign = MP_ZPOS;
}
}
#endif
|
Changes to libtommath/bn_mp_clear_multi.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_CLEAR_MULTI_C | | < < < < < < < < | < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 |
#include "tommath_private.h"
#ifdef BN_MP_CLEAR_MULTI_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
#include <stdarg.h>
void mp_clear_multi(mp_int *mp, ...)
{
mp_int *next_mp = mp;
va_list args;
va_start(args, mp);
while (next_mp != NULL) {
mp_clear(next_mp);
next_mp = va_arg(args, mp_int *);
}
va_end(args);
}
#endif
|
Changes to libtommath/bn_mp_cnt_lsb.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_CNT_LSB_C | | < < < < < < < < | < | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 |
#include "tommath_private.h"
#ifdef BN_MP_CNT_LSB_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
static const int lnz[16] = {
4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0
};
/* Counts the number of lsbs which are zero before the first zero bit */
int mp_cnt_lsb(const mp_int *a)
{
int x;
mp_digit q, qq;
/* easy out */
if (MP_IS_ZERO(a)) {
return 0;
}
/* scan lower digits until non-zero */
for (x = 0; (x < a->used) && (a->dp[x] == 0u); x++) {}
q = a->dp[x];
x *= MP_DIGIT_BIT;
/* now scan this digit until a 1 is found */
if ((q & 1u) == 0u) {
do {
qq = q & 15u;
x += lnz[qq];
q >>= 4;
} while (qq == 0u);
}
return x;
}
#endif
|
Changes to libtommath/bn_mp_complement.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_COMPLEMENT_C | | < < < < < < < < | < | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 |
#include "tommath_private.h"
#ifdef BN_MP_COMPLEMENT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* b = ~a */
mp_err mp_complement(const mp_int *a, mp_int *b)
{
mp_err err = mp_neg(a, b);
return (err == MP_OKAY) ? mp_sub_d(b, 1uL, b) : err;
}
#endif
|
Changes to libtommath/bn_mp_copy.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_COPY_C | | < < < < < < < < | < | | > > | | < < < | | | | | | | | | | | < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
#include "tommath_private.h"
#ifdef BN_MP_COPY_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* copy, b = a */
mp_err mp_copy(const mp_int *a, mp_int *b)
{
int n;
mp_digit *tmpa, *tmpb;
mp_err err;
/* if dst == src do nothing */
if (a == b) {
return MP_OKAY;
}
/* grow dest */
if (b->alloc < a->used) {
if ((err = mp_grow(b, a->used)) != MP_OKAY) {
return err;
}
}
/* zero b and copy the parameters over */
/* pointer aliases */
/* source */
tmpa = a->dp;
/* destination */
tmpb = b->dp;
/* copy all the digits */
for (n = 0; n < a->used; n++) {
*tmpb++ = *tmpa++;
}
/* clear high digits */
MP_ZERO_DIGITS(tmpb, b->used - n);
/* copy used count and sign */
b->used = a->used;
b->sign = a->sign;
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_count_bits.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_COUNT_BITS_C | | < < < < < < < < | < | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
#include "tommath_private.h"
#ifdef BN_MP_COUNT_BITS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* returns the number of bits in an int */
int mp_count_bits(const mp_int *a)
{
int r;
mp_digit q;
/* shortcut */
if (MP_IS_ZERO(a)) {
return 0;
}
/* get number of digits and add that */
r = (a->used - 1) * MP_DIGIT_BIT;
/* take the last digit and count the bits in it */
q = a->dp[a->used - 1];
while (q > 0u) {
++r;
q >>= 1u;
}
return r;
}
#endif
|
Added libtommath/bn_mp_decr.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
#include "tommath_private.h"
#ifdef BN_MP_DECR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* Decrement "a" by one like "a--". Changes input! */
mp_err mp_decr(mp_int *a)
{
if (MP_IS_ZERO(a)) {
mp_set(a,1uL);
a->sign = MP_NEG;
return MP_OKAY;
} else if (a->sign == MP_NEG) {
mp_err err;
a->sign = MP_ZPOS;
if ((err = mp_incr(a)) != MP_OKAY) {
return err;
}
/* There is no -0 in LTM */
if (!MP_IS_ZERO(a)) {
a->sign = MP_NEG;
}
return MP_OKAY;
} else if (a->dp[0] > 1uL) {
a->dp[0]--;
if (a->dp[0] == 0u) {
mp_zero(a);
}
return MP_OKAY;
} else {
return mp_sub_d(a, 1uL,a);
}
}
#endif
|
Changes to libtommath/bn_mp_div.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_DIV_C | | < < < < < < < < | < | | > | | | | | | | | | | < | < | | < | < | | < < | | | | | > > | | | | | | | < | < | < | < | < | < | < < | | | | | < < | < < | | < | < < | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 |
#include "tommath_private.h"
#ifdef BN_MP_DIV_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
#ifdef BN_MP_DIV_SMALL
/* slower bit-bang division... also smaller */
mp_err mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d)
{
mp_int ta, tb, tq, q;
int n, n2;
mp_err err;
/* is divisor zero ? */
if (MP_IS_ZERO(b)) {
return MP_VAL;
}
/* if a < b then q=0, r = a */
if (mp_cmp_mag(a, b) == MP_LT) {
if (d != NULL) {
err = mp_copy(a, d);
} else {
err = MP_OKAY;
}
if (c != NULL) {
mp_zero(c);
}
return err;
}
/* init our temps */
if ((err = mp_init_multi(&ta, &tb, &tq, &q, NULL)) != MP_OKAY) {
return err;
}
mp_set(&tq, 1uL);
n = mp_count_bits(a) - mp_count_bits(b);
if ((err = mp_abs(a, &ta)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_abs(b, &tb)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_mul_2d(&tb, n, &tb)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_mul_2d(&tq, n, &tq)) != MP_OKAY) goto LBL_ERR;
while (n-- >= 0) {
if (mp_cmp(&tb, &ta) != MP_GT) {
if ((err = mp_sub(&ta, &tb, &ta)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_add(&q, &tq, &q)) != MP_OKAY) goto LBL_ERR;
}
if ((err = mp_div_2d(&tb, 1, &tb, NULL)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_div_2d(&tq, 1, &tq, NULL)) != MP_OKAY) goto LBL_ERR;
}
/* now q == quotient and ta == remainder */
n = a->sign;
n2 = (a->sign == b->sign) ? MP_ZPOS : MP_NEG;
if (c != NULL) {
mp_exch(c, &q);
c->sign = MP_IS_ZERO(c) ? MP_ZPOS : n2;
}
if (d != NULL) {
mp_exch(d, &ta);
d->sign = MP_IS_ZERO(d) ? MP_ZPOS : n;
}
LBL_ERR:
mp_clear_multi(&ta, &tb, &tq, &q, NULL);
return err;
}
#else
/* integer signed division.
* c*b + d == a [e.g. a/b, c=quotient, d=remainder]
* HAC pp.598 Algorithm 14.20
*
* Note that the description in HAC is horribly
* incomplete. For example, it doesn't consider
* the case where digits are removed from 'x' in
* the inner loop. It also doesn't consider the
* case that y has fewer than three digits, etc..
*
* The overall algorithm is as described as
* 14.20 from HAC but fixed to treat these cases.
*/
mp_err mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d)
{
mp_int q, x, y, t1, t2;
int n, t, i, norm;
mp_sign neg;
mp_err err;
/* is divisor zero ? */
if (MP_IS_ZERO(b)) {
return MP_VAL;
}
/* if a < b then q=0, r = a */
if (mp_cmp_mag(a, b) == MP_LT) {
if (d != NULL) {
err = mp_copy(a, d);
} else {
err = MP_OKAY;
}
if (c != NULL) {
mp_zero(c);
}
return err;
}
if ((err = mp_init_size(&q, a->used + 2)) != MP_OKAY) {
return err;
}
q.used = a->used + 2;
if ((err = mp_init(&t1)) != MP_OKAY) goto LBL_Q;
if ((err = mp_init(&t2)) != MP_OKAY) goto LBL_T1;
if ((err = mp_init_copy(&x, a)) != MP_OKAY) goto LBL_T2;
if ((err = mp_init_copy(&y, b)) != MP_OKAY) goto LBL_X;
/* fix the sign */
neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG;
x.sign = y.sign = MP_ZPOS;
/* normalize both x and y, ensure that y >= b/2, [b == 2**MP_DIGIT_BIT] */
norm = mp_count_bits(&y) % MP_DIGIT_BIT;
if (norm < (MP_DIGIT_BIT - 1)) {
norm = (MP_DIGIT_BIT - 1) - norm;
if ((err = mp_mul_2d(&x, norm, &x)) != MP_OKAY) goto LBL_Y;
if ((err = mp_mul_2d(&y, norm, &y)) != MP_OKAY) goto LBL_Y;
} else {
norm = 0;
}
/* note hac does 0 based, so if used==5 then its 0,1,2,3,4, e.g. use 4 */
n = x.used - 1;
t = y.used - 1;
/* while (x >= y*b**n-t) do { q[n-t] += 1; x -= y*b**{n-t} } */
/* y = y*b**{n-t} */
if ((err = mp_lshd(&y, n - t)) != MP_OKAY) goto LBL_Y;
while (mp_cmp(&x, &y) != MP_LT) {
++(q.dp[n - t]);
if ((err = mp_sub(&x, &y, &x)) != MP_OKAY) goto LBL_Y;
}
/* reset y by shifting it back down */
mp_rshd(&y, n - t);
/* step 3. for i from n down to (t + 1) */
for (i = n; i >= (t + 1); i--) {
if (i > x.used) {
continue;
}
/* step 3.1 if xi == yt then set q{i-t-1} to b-1,
* otherwise set q{i-t-1} to (xi*b + x{i-1})/yt */
if (x.dp[i] == y.dp[t]) {
q.dp[(i - t) - 1] = ((mp_digit)1 << (mp_digit)MP_DIGIT_BIT) - (mp_digit)1;
} else {
mp_word tmp;
tmp = (mp_word)x.dp[i] << (mp_word)MP_DIGIT_BIT;
tmp |= (mp_word)x.dp[i - 1];
tmp /= (mp_word)y.dp[t];
if (tmp > (mp_word)MP_MASK) {
tmp = MP_MASK;
}
q.dp[(i - t) - 1] = (mp_digit)(tmp & (mp_word)MP_MASK);
}
|
| ︙ | ︙ | |||
209 210 211 212 213 214 215 |
q.dp[(i - t) - 1] = (q.dp[(i - t) - 1] - 1uL) & (mp_digit)MP_MASK;
/* find left hand */
mp_zero(&t1);
t1.dp[0] = ((t - 1) < 0) ? 0u : y.dp[t - 1];
t1.dp[1] = y.dp[t];
t1.used = 2;
| | < < | | < | < | < | < | < | < | < < | < < | < < | < < | | < < < < | 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 |
q.dp[(i - t) - 1] = (q.dp[(i - t) - 1] - 1uL) & (mp_digit)MP_MASK;
/* find left hand */
mp_zero(&t1);
t1.dp[0] = ((t - 1) < 0) ? 0u : y.dp[t - 1];
t1.dp[1] = y.dp[t];
t1.used = 2;
if ((err = mp_mul_d(&t1, q.dp[(i - t) - 1], &t1)) != MP_OKAY) goto LBL_Y;
/* find right hand */
t2.dp[0] = ((i - 2) < 0) ? 0u : x.dp[i - 2];
t2.dp[1] = x.dp[i - 1]; /* i >= 1 always holds */
t2.dp[2] = x.dp[i];
t2.used = 3;
} while (mp_cmp_mag(&t1, &t2) == MP_GT);
/* step 3.3 x = x - q{i-t-1} * y * b**{i-t-1} */
if ((err = mp_mul_d(&y, q.dp[(i - t) - 1], &t1)) != MP_OKAY) goto LBL_Y;
if ((err = mp_lshd(&t1, (i - t) - 1)) != MP_OKAY) goto LBL_Y;
if ((err = mp_sub(&x, &t1, &x)) != MP_OKAY) goto LBL_Y;
/* if x < 0 then { x = x + y*b**{i-t-1}; q{i-t-1} -= 1; } */
if (x.sign == MP_NEG) {
if ((err = mp_copy(&y, &t1)) != MP_OKAY) goto LBL_Y;
if ((err = mp_lshd(&t1, (i - t) - 1)) != MP_OKAY) goto LBL_Y;
if ((err = mp_add(&x, &t1, &x)) != MP_OKAY) goto LBL_Y;
q.dp[(i - t) - 1] = (q.dp[(i - t) - 1] - 1uL) & MP_MASK;
}
}
/* now q is the quotient and x is the remainder
* [which we have to normalize]
*/
/* get sign before writing to c */
x.sign = (x.used == 0) ? MP_ZPOS : a->sign;
if (c != NULL) {
mp_clamp(&q);
mp_exch(&q, c);
c->sign = neg;
}
if (d != NULL) {
if ((err = mp_div_2d(&x, norm, &x, NULL)) != MP_OKAY) goto LBL_Y;
mp_exch(&x, d);
}
err = MP_OKAY;
LBL_Y:
mp_clear(&y);
LBL_X:
mp_clear(&x);
LBL_T2:
mp_clear(&t2);
LBL_T1:
mp_clear(&t1);
LBL_Q:
mp_clear(&q);
return err;
}
#endif
#endif
|
Changes to libtommath/bn_mp_div_2.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_DIV_2_C | | < < < < < < < < | < | | > > | | | < < | | | | | | | | | | | | | | | | < < | < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 |
#include "tommath_private.h"
#ifdef BN_MP_DIV_2_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* b = a/2 */
mp_err mp_div_2(const mp_int *a, mp_int *b)
{
int x, oldused;
mp_digit r, rr, *tmpa, *tmpb;
mp_err err;
/* copy */
if (b->alloc < a->used) {
if ((err = mp_grow(b, a->used)) != MP_OKAY) {
return err;
}
}
oldused = b->used;
b->used = a->used;
/* source alias */
tmpa = a->dp + b->used - 1;
/* dest alias */
tmpb = b->dp + b->used - 1;
/* carry */
r = 0;
for (x = b->used - 1; x >= 0; x--) {
/* get the carry for the next iteration */
rr = *tmpa & 1u;
/* shift the current digit, add in carry and store */
*tmpb-- = (*tmpa-- >> 1) | (r << (MP_DIGIT_BIT - 1));
/* forward carry to next iteration */
r = rr;
}
/* zero excess digits */
MP_ZERO_DIGITS(b->dp + b->used, oldused - b->used);
b->sign = a->sign;
mp_clamp(b);
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_div_2d.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_DIV_2D_C | | < < < < < < < < | < | | > | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 |
#include "tommath_private.h"
#ifdef BN_MP_DIV_2D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* shift right by a certain bit count (store quotient in c, optional remainder in d) */
mp_err mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d)
{
mp_digit D, r, rr;
int x;
mp_err err;
/* if the shift count is <= 0 then we do no work */
if (b <= 0) {
err = mp_copy(a, c);
if (d != NULL) {
mp_zero(d);
}
return err;
}
/* copy */
if ((err = mp_copy(a, c)) != MP_OKAY) {
return err;
}
/* 'a' should not be used after here - it might be the same as d */
/* get the remainder */
if (d != NULL) {
if ((err = mp_mod_2d(a, b, d)) != MP_OKAY) {
return err;
}
}
/* shift by as many digits in the bit count */
if (b >= MP_DIGIT_BIT) {
mp_rshd(c, b / MP_DIGIT_BIT);
}
/* shift any bit count < MP_DIGIT_BIT */
D = (mp_digit)(b % MP_DIGIT_BIT);
if (D != 0u) {
mp_digit *tmpc, mask, shift;
/* mask */
mask = ((mp_digit)1 << D) - 1uL;
/* shift for lsb */
shift = (mp_digit)MP_DIGIT_BIT - D;
/* alias */
tmpc = c->dp + (c->used - 1);
/* carry */
r = 0;
for (x = c->used - 1; x >= 0; x--) {
|
| ︙ | ︙ | |||
73 74 75 76 77 78 79 |
r = rr;
}
}
mp_clamp(c);
return MP_OKAY;
}
#endif
| < < < < | 65 66 67 68 69 70 71 |
r = rr;
}
}
mp_clamp(c);
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_div_3.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_DIV_3_C | | < < < < < < < < | < | > | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 |
#include "tommath_private.h"
#ifdef BN_MP_DIV_3_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* divide by three (based on routine from MPI and the GMP manual) */
mp_err mp_div_3(const mp_int *a, mp_int *c, mp_digit *d)
{
mp_int q;
mp_word w, t;
mp_digit b;
mp_err err;
int ix;
/* b = 2**MP_DIGIT_BIT / 3 */
b = ((mp_word)1 << (mp_word)MP_DIGIT_BIT) / (mp_word)3;
if ((err = mp_init_size(&q, a->used)) != MP_OKAY) {
return err;
}
q.used = a->used;
q.sign = a->sign;
w = 0;
for (ix = a->used - 1; ix >= 0; ix--) {
w = (w << (mp_word)MP_DIGIT_BIT) | (mp_word)a->dp[ix];
if (w >= 3u) {
/* multiply w by [1/3] */
t = (w * (mp_word)b) >> (mp_word)MP_DIGIT_BIT;
/* now subtract 3 * [w/3] from w, to get the remainder */
w -= t+t+t;
/* fixup the remainder as required since
* the optimization is not exact.
*/
|
| ︙ | ︙ | |||
61 62 63 64 65 66 67 |
/* [optional] store the quotient */
if (c != NULL) {
mp_clamp(&q);
mp_exch(&q, c);
}
mp_clear(&q);
| | < < < < | 53 54 55 56 57 58 59 60 61 62 63 |
/* [optional] store the quotient */
if (c != NULL) {
mp_clamp(&q);
mp_exch(&q, c);
}
mp_clear(&q);
return err;
}
#endif
|
Changes to libtommath/bn_mp_div_d.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_DIV_D_C | | < < < < < < < < | < | > | | | | | < < > < | < | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 |
#include "tommath_private.h"
#ifdef BN_MP_DIV_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* single digit division (based on routine from MPI) */
mp_err mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d)
{
mp_int q;
mp_word w;
mp_digit t;
mp_err err;
int ix;
/* cannot divide by zero */
if (b == 0u) {
return MP_VAL;
}
/* quick outs */
if ((b == 1u) || MP_IS_ZERO(a)) {
if (d != NULL) {
*d = 0;
}
if (c != NULL) {
return mp_copy(a, c);
}
return MP_OKAY;
}
/* power of two ? */
if ((b & (b - 1u)) == 0u) {
ix = 1;
while ((ix < MP_DIGIT_BIT) && (b != (((mp_digit)1)<<ix))) {
ix++;
}
if (d != NULL) {
*d = a->dp[0] & (((mp_digit)1<<(mp_digit)ix) - 1uL);
}
if (c != NULL) {
return mp_div_2d(a, ix, c, NULL);
}
return MP_OKAY;
}
/* three? */
if (MP_HAS(MP_DIV_3) && (b == 3u)) {
return mp_div_3(a, c, d);
}
/* no easy answer [c'est la vie]. Just division */
if ((err = mp_init_size(&q, a->used)) != MP_OKAY) {
return err;
}
q.used = a->used;
q.sign = a->sign;
w = 0;
for (ix = a->used - 1; ix >= 0; ix--) {
w = (w << (mp_word)MP_DIGIT_BIT) | (mp_word)a->dp[ix];
if (w >= b) {
t = (mp_digit)(w / b);
w -= (mp_word)t * (mp_word)b;
} else {
t = 0;
}
q.dp[ix] = t;
}
if (d != NULL) {
*d = (mp_digit)w;
}
if (c != NULL) {
mp_clamp(&q);
mp_exch(&q, c);
}
mp_clear(&q);
return err;
}
#endif
|
Changes to libtommath/bn_mp_dr_is_modulus.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_DR_IS_MODULUS_C | | < < < < < < < < | < | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
#include "tommath_private.h"
#ifdef BN_MP_DR_IS_MODULUS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* determines if a number is a valid DR modulus */
mp_bool mp_dr_is_modulus(const mp_int *a)
{
int ix;
/* must be at least two digits */
if (a->used < 2) {
return MP_NO;
}
/* must be of the form b**k - a [a <= b] so all
* but the first digit must be equal to -1 (mod b).
*/
for (ix = 1; ix < a->used; ix++) {
if (a->dp[ix] != MP_MASK) {
return MP_NO;
}
}
return MP_YES;
}
#endif
|
Changes to libtommath/bn_mp_dr_reduce.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_DR_REDUCE_C | | < < < < < < < < | < | | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
#include "tommath_private.h"
#ifdef BN_MP_DR_REDUCE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* reduce "x" in place modulo "n" using the Diminished Radix algorithm.
*
* Based on algorithm from the paper
*
* "Generating Efficient Primes for Discrete Log Cryptosystems"
* Chae Hoon Lim, Pil Joong Lee,
* POSTECH Information Research Laboratories
*
* The modulus must be of a special format [see manual]
*
* Has been modified to use algorithm 7.10 from the LTM book instead
*
* Input x must be in the range 0 <= x <= (n-1)**2
*/
mp_err mp_dr_reduce(mp_int *x, const mp_int *n, mp_digit k)
{
mp_err err;
int i, m;
mp_word r;
mp_digit mu, *tmpx1, *tmpx2;
/* m = digits in modulus */
m = n->used;
/* ensure that "x" has at least 2m digits */
|
| ︙ | ︙ | |||
56 57 58 59 60 61 62 |
/* set carry to zero */
mu = 0;
/* compute (x mod B**m) + k * [x/B**m] inline and inplace */
for (i = 0; i < m; i++) {
r = ((mp_word)*tmpx2++ * (mp_word)k) + *tmpx1 + mu;
*tmpx1++ = (mp_digit)(r & MP_MASK);
| | < | < < < < < | 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 |
/* set carry to zero */
mu = 0;
/* compute (x mod B**m) + k * [x/B**m] inline and inplace */
for (i = 0; i < m; i++) {
r = ((mp_word)*tmpx2++ * (mp_word)k) + *tmpx1 + mu;
*tmpx1++ = (mp_digit)(r & MP_MASK);
mu = (mp_digit)(r >> ((mp_word)MP_DIGIT_BIT));
}
/* set final carry */
*tmpx1++ = mu;
/* zero words above m */
MP_ZERO_DIGITS(tmpx1, (x->used - m) - 1);
/* clamp, sub and return */
mp_clamp(x);
/* if x >= n then subtract and reduce again
* Each successive "recursion" makes the input smaller and smaller.
*/
if (mp_cmp_mag(x, n) != MP_LT) {
if ((err = s_mp_sub(x, n, x)) != MP_OKAY) {
return err;
}
goto top;
}
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_dr_setup.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_DR_SETUP_C | | < < < < < < < < | < | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 |
#include "tommath_private.h"
#ifdef BN_MP_DR_SETUP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* determines the setup value */
void mp_dr_setup(const mp_int *a, mp_digit *d)
{
/* the casts are required if MP_DIGIT_BIT is one less than
* the number of bits in a mp_digit [e.g. MP_DIGIT_BIT==31]
*/
*d = (mp_digit)(((mp_word)1 << (mp_word)MP_DIGIT_BIT) - (mp_word)a->dp[0]);
}
#endif
|
Added libtommath/bn_mp_error_to_string.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
#include "tommath_private.h"
#ifdef BN_MP_ERROR_TO_STRING_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* return a char * string for a given code */
const char *mp_error_to_string(mp_err code)
{
switch (code) {
case MP_OKAY:
return "Successful";
case MP_ERR:
return "Unknown error";
case MP_MEM:
return "Out of heap";
case MP_VAL:
return "Value out of range";
case MP_ITER:
return "Max. iterations reached";
case MP_BUF:
return "Buffer overflow";
default:
return "Invalid error code";
}
}
#endif
|
Changes to libtommath/bn_mp_exch.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_EXCH_C | | < < < < < < < < | < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
#include "tommath_private.h"
#ifdef BN_MP_EXCH_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* swap the elements of two integers, for cases where you can't simply swap the
* mp_int pointers around
*/
void mp_exch(mp_int *a, mp_int *b)
{
mp_int t;
t = *a;
*a = *b;
*b = t;
}
#endif
|
Deleted libtommath/bn_mp_export.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/bn_mp_expt_d.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/bn_mp_expt_d_ex.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added libtommath/bn_mp_expt_u32.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
#include "tommath_private.h"
#ifdef BN_MP_EXPT_U32_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* calculate c = a**b using a square-multiply algorithm */
mp_err mp_expt_u32(const mp_int *a, uint32_t b, mp_int *c)
{
mp_err err;
mp_int g;
if ((err = mp_init_copy(&g, a)) != MP_OKAY) {
return err;
}
/* set initial result */
mp_set(c, 1uL);
while (b > 0u) {
/* if the bit is set multiply */
if ((b & 1u) != 0u) {
if ((err = mp_mul(c, &g, c)) != MP_OKAY) {
goto LBL_ERR;
}
}
/* square */
if (b > 1u) {
if ((err = mp_sqr(&g, &g)) != MP_OKAY) {
goto LBL_ERR;
}
}
/* shift to next bit */
b >>= 1;
}
err = MP_OKAY;
LBL_ERR:
mp_clear(&g);
return err;
}
#endif
|
Changes to libtommath/bn_mp_exptmod.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_EXPTMOD_C | | < < < < < < < < | < < | < | < | | | | | | < < > > > < < > > < < < < | | < < | | < < < < < | | < | < | | < < | < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
#include "tommath_private.h"
#ifdef BN_MP_EXPTMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* this is a shell function that calls either the normal or Montgomery
* exptmod functions. Originally the call to the montgomery code was
* embedded in the normal function but that wasted alot of stack space
* for nothing (since 99% of the time the Montgomery code would be called)
*/
mp_err mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y)
{
int dr;
/* modulus P must be positive */
if (P->sign == MP_NEG) {
return MP_VAL;
}
/* if exponent X is negative we have to recurse */
if (X->sign == MP_NEG) {
mp_int tmpG, tmpX;
mp_err err;
if (!MP_HAS(MP_INVMOD)) {
return MP_VAL;
}
if ((err = mp_init_multi(&tmpG, &tmpX, NULL)) != MP_OKAY) {
return err;
}
/* first compute 1/G mod P */
if ((err = mp_invmod(G, P, &tmpG)) != MP_OKAY) {
goto LBL_ERR;
}
/* now get |X| */
if ((err = mp_abs(X, &tmpX)) != MP_OKAY) {
goto LBL_ERR;
}
/* and now compute (1/G)**|X| instead of G**X [X < 0] */
err = mp_exptmod(&tmpG, &tmpX, P, Y);
LBL_ERR:
mp_clear_multi(&tmpG, &tmpX, NULL);
return err;
}
/* modified diminished radix reduction */
if (MP_HAS(MP_REDUCE_IS_2K_L) && MP_HAS(MP_REDUCE_2K_L) && MP_HAS(S_MP_EXPTMOD) &&
(mp_reduce_is_2k_l(P) == MP_YES)) {
return s_mp_exptmod(G, X, P, Y, 1);
}
/* is it a DR modulus? default to no */
dr = (MP_HAS(MP_DR_IS_MODULUS) && (mp_dr_is_modulus(P) == MP_YES)) ? 1 : 0;
/* if not, is it a unrestricted DR modulus? */
if (MP_HAS(MP_REDUCE_IS_2K) && (dr == 0)) {
dr = (mp_reduce_is_2k(P) == MP_YES) ? 2 : 0;
}
/* if the modulus is odd or dr != 0 use the montgomery method */
if (MP_HAS(S_MP_EXPTMOD_FAST) && (MP_IS_ODD(P) || (dr != 0))) {
return s_mp_exptmod_fast(G, X, P, Y, dr);
} else if (MP_HAS(S_MP_EXPTMOD)) {
/* otherwise use the generic Barrett reduction technique */
return s_mp_exptmod(G, X, P, Y, 0);
} else {
/* no exptmod for evens */
return MP_VAL;
}
}
#endif
|
Deleted libtommath/bn_mp_exptmod_fast.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to libtommath/bn_mp_exteuclid.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_EXTEUCLID_C | | < < < < < < < < | < | | | < < | < | < | | < | < | < < | < < | < < | < < | < < | < | < | < < | < < | < < | < < | < < | < < | < < | < < | < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
#include "tommath_private.h"
#ifdef BN_MP_EXTEUCLID_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* Extended euclidean algorithm of (a, b) produces
a*u1 + b*u2 = u3
*/
mp_err mp_exteuclid(const mp_int *a, const mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3)
{
mp_int u1, u2, u3, v1, v2, v3, t1, t2, t3, q, tmp;
mp_err err;
if ((err = mp_init_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL)) != MP_OKAY) {
return err;
}
/* initialize, (u1,u2,u3) = (1,0,a) */
mp_set(&u1, 1uL);
if ((err = mp_copy(a, &u3)) != MP_OKAY) goto LBL_ERR;
/* initialize, (v1,v2,v3) = (0,1,b) */
mp_set(&v2, 1uL);
if ((err = mp_copy(b, &v3)) != MP_OKAY) goto LBL_ERR;
/* loop while v3 != 0 */
while (!MP_IS_ZERO(&v3)) {
/* q = u3/v3 */
if ((err = mp_div(&u3, &v3, &q, NULL)) != MP_OKAY) goto LBL_ERR;
/* (t1,t2,t3) = (u1,u2,u3) - (v1,v2,v3)q */
if ((err = mp_mul(&v1, &q, &tmp)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_sub(&u1, &tmp, &t1)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_mul(&v2, &q, &tmp)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_sub(&u2, &tmp, &t2)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_mul(&v3, &q, &tmp)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_sub(&u3, &tmp, &t3)) != MP_OKAY) goto LBL_ERR;
/* (u1,u2,u3) = (v1,v2,v3) */
if ((err = mp_copy(&v1, &u1)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_copy(&v2, &u2)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_copy(&v3, &u3)) != MP_OKAY) goto LBL_ERR;
/* (v1,v2,v3) = (t1,t2,t3) */
if ((err = mp_copy(&t1, &v1)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_copy(&t2, &v2)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_copy(&t3, &v3)) != MP_OKAY) goto LBL_ERR;
}
/* make sure U3 >= 0 */
if (u3.sign == MP_NEG) {
if ((err = mp_neg(&u1, &u1)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_neg(&u2, &u2)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_neg(&u3, &u3)) != MP_OKAY) goto LBL_ERR;
}
/* copy result out */
if (U1 != NULL) {
mp_exch(U1, &u1);
}
if (U2 != NULL) {
mp_exch(U2, &u2);
}
if (U3 != NULL) {
mp_exch(U3, &u3);
}
err = MP_OKAY;
LBL_ERR:
mp_clear_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL);
return err;
}
#endif
|
Changes to libtommath/bn_mp_fread.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_FREAD_C | | < < < < < < < < | < | | | | < < < | > > > > | > > > > > | < | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 |
#include "tommath_private.h"
#ifdef BN_MP_FREAD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
#ifndef MP_NO_FILE
/* read a bigint from a file stream in ASCII */
mp_err mp_fread(mp_int *a, int radix, FILE *stream)
{
mp_err err;
mp_sign neg;
/* if first digit is - then set negative */
int ch = fgetc(stream);
if (ch == (int)'-') {
neg = MP_NEG;
ch = fgetc(stream);
} else {
neg = MP_ZPOS;
}
/* no digits, return error */
if (ch == EOF) {
return MP_ERR;
}
/* clear a */
mp_zero(a);
do {
int y;
unsigned pos = (unsigned)(ch - (int)'(');
if (mp_s_rmap_reverse_sz < pos) {
break;
}
y = (int)mp_s_rmap_reverse[pos];
if ((y == 0xff) || (y >= radix)) {
break;
}
/* shift up and add */
if ((err = mp_mul_d(a, (mp_digit)radix, a)) != MP_OKAY) {
return err;
}
if ((err = mp_add_d(a, (mp_digit)y, a)) != MP_OKAY) {
return err;
}
} while ((ch = fgetc(stream)) != EOF);
if (a->used != 0) {
a->sign = neg;
}
return MP_OKAY;
}
#endif
#endif
|
Added libtommath/bn_mp_from_sbin.c.
> > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
#include "tommath_private.h"
#ifdef BN_MP_FROM_SBIN_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* read signed bin, big endian, first byte is 0==positive or 1==negative */
mp_err mp_from_sbin(mp_int *a, const unsigned char *buf, size_t size)
{
mp_err err;
/* read magnitude */
if ((err = mp_from_ubin(a, buf + 1, size - 1u)) != MP_OKAY) {
return err;
}
/* first byte is 0 for positive, non-zero for negative */
if (buf[0] == (unsigned char)0) {
a->sign = MP_ZPOS;
} else {
a->sign = MP_NEG;
}
return MP_OKAY;
}
#endif
|
Added libtommath/bn_mp_from_ubin.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 |
#include "tommath_private.h"
#ifdef BN_MP_FROM_UBIN_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* reads a unsigned char array, assumes the msb is stored first [big endian] */
mp_err mp_from_ubin(mp_int *a, const unsigned char *buf, size_t size)
{
mp_err err;
/* make sure there are at least two digits */
if (a->alloc < 2) {
if ((err = mp_grow(a, 2)) != MP_OKAY) {
return err;
}
}
/* zero the int */
mp_zero(a);
/* read the bytes in */
while (size-- > 0u) {
if ((err = mp_mul_2d(a, 8, a)) != MP_OKAY) {
return err;
}
#ifndef MP_8BIT
a->dp[0] |= *buf++;
a->used += 1;
#else
a->dp[0] = (*buf & MP_MASK);
a->dp[1] |= ((*buf++ >> 7) & 1u);
a->used += 2;
#endif
}
mp_clamp(a);
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_fwrite.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_FWRITE_C | | < < < < < < < < | < | | > | > > > > > | | | | > | | | < < < | | > | > | > | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 |
#include "tommath_private.h"
#ifdef BN_MP_FWRITE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
#ifndef MP_NO_FILE
mp_err mp_fwrite(const mp_int *a, int radix, FILE *stream)
{
char *buf;
mp_err err;
int len;
size_t written;
/* TODO: this function is not in this PR */
if (MP_HAS(MP_RADIX_SIZE_OVERESTIMATE)) {
/* if ((err = mp_radix_size_overestimate(&t, base, &len)) != MP_OKAY) goto LBL_ERR; */
} else {
if ((err = mp_radix_size(a, radix, &len)) != MP_OKAY) {
return err;
}
}
buf = (char *) MP_MALLOC((size_t)len);
if (buf == NULL) {
return MP_MEM;
}
if ((err = mp_to_radix(a, buf, (size_t)len, &written, radix)) != MP_OKAY) {
goto LBL_ERR;
}
if (fwrite(buf, written, 1uL, stream) != 1uL) {
err = MP_ERR;
goto LBL_ERR;
}
err = MP_OKAY;
LBL_ERR:
MP_FREE_BUFFER(buf, (size_t)len);
return err;
}
#endif
#endif
|
Changes to libtommath/bn_mp_gcd.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_GCD_C | | < < < < < < < < | < | | > | | | | | | | | | | | | | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 |
#include "tommath_private.h"
#ifdef BN_MP_GCD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* Greatest Common Divisor using the binary method */
mp_err mp_gcd(const mp_int *a, const mp_int *b, mp_int *c)
{
mp_int u, v;
int k, u_lsb, v_lsb;
mp_err err;
/* either zero than gcd is the largest */
if (MP_IS_ZERO(a)) {
return mp_abs(b, c);
}
if (MP_IS_ZERO(b)) {
return mp_abs(a, c);
}
/* get copies of a and b we can modify */
if ((err = mp_init_copy(&u, a)) != MP_OKAY) {
return err;
}
if ((err = mp_init_copy(&v, b)) != MP_OKAY) {
goto LBL_U;
}
/* must be positive for the remainder of the algorithm */
u.sign = v.sign = MP_ZPOS;
/* B1. Find the common power of two for u and v */
u_lsb = mp_cnt_lsb(&u);
v_lsb = mp_cnt_lsb(&v);
k = MP_MIN(u_lsb, v_lsb);
if (k > 0) {
/* divide the power of two out */
if ((err = mp_div_2d(&u, k, &u, NULL)) != MP_OKAY) {
goto LBL_V;
}
if ((err = mp_div_2d(&v, k, &v, NULL)) != MP_OKAY) {
goto LBL_V;
}
}
/* divide any remaining factors of two out */
if (u_lsb != k) {
if ((err = mp_div_2d(&u, u_lsb - k, &u, NULL)) != MP_OKAY) {
goto LBL_V;
}
}
if (v_lsb != k) {
if ((err = mp_div_2d(&v, v_lsb - k, &v, NULL)) != MP_OKAY) {
goto LBL_V;
}
}
while (!MP_IS_ZERO(&v)) {
/* make sure v is the largest */
if (mp_cmp_mag(&u, &v) == MP_GT) {
/* swap u and v to make sure v is >= u */
mp_exch(&u, &v);
}
/* subtract smallest from largest */
if ((err = s_mp_sub(&v, &u, &v)) != MP_OKAY) {
goto LBL_V;
}
/* Divide out all factors of two */
if ((err = mp_div_2d(&v, mp_cnt_lsb(&v), &v, NULL)) != MP_OKAY) {
goto LBL_V;
}
}
/* multiply by 2**k which we divided out at the beginning */
if ((err = mp_mul_2d(&u, k, c)) != MP_OKAY) {
goto LBL_V;
}
c->sign = MP_ZPOS;
err = MP_OKAY;
LBL_V:
mp_clear(&u);
LBL_U:
mp_clear(&v);
return err;
}
#endif
|
Changes to libtommath/bn_mp_get_double.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_GET_DOUBLE_C | | < < < < < < < < | < | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 |
#include "tommath_private.h"
#ifdef BN_MP_GET_DOUBLE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
double mp_get_double(const mp_int *a)
{
int i;
double d = 0.0, fac = 1.0;
for (i = 0; i < MP_DIGIT_BIT; ++i) {
fac *= 2.0;
}
for (i = a->used; i --> 0;) {
d = (d * fac) + (double)a->dp[i];
}
return (a->sign == MP_NEG) ? -d : d;
}
#endif
|
Added libtommath/bn_mp_get_i32.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_GET_I32_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_GET_SIGNED(mp_get_i32, mp_get_mag_u32, int32_t, uint32_t) #endif |
Added libtommath/bn_mp_get_i64.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_GET_I64_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_GET_SIGNED(mp_get_i64, mp_get_mag_u64, int64_t, uint64_t) #endif |
Deleted libtommath/bn_mp_get_int.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < |
Added libtommath/bn_mp_get_l.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_GET_L_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_GET_SIGNED(mp_get_l, mp_get_mag_ul, long, unsigned long) #endif |
Added libtommath/bn_mp_get_ll.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_GET_LL_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_GET_SIGNED(mp_get_ll, mp_get_mag_ull, long long, unsigned long long) #endif |
Deleted libtommath/bn_mp_get_long.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/bn_mp_get_long_long.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added libtommath/bn_mp_get_mag_u32.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_GET_MAG_U32_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_GET_MAG(mp_get_mag_u32, uint32_t) #endif |
Added libtommath/bn_mp_get_mag_u64.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_GET_MAG_U64_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_GET_MAG(mp_get_mag_u64, uint64_t) #endif |
Added libtommath/bn_mp_get_mag_ul.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_GET_MAG_UL_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_GET_MAG(mp_get_mag_ul, unsigned long) #endif |
Added libtommath/bn_mp_get_mag_ull.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_GET_MAG_ULL_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_GET_MAG(mp_get_mag_ull, unsigned long long) #endif |
Changes to libtommath/bn_mp_grow.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_GROW_C | | < < < < < < < < | < | < < < | | | | < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
#include "tommath_private.h"
#ifdef BN_MP_GROW_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* grow as required */
mp_err mp_grow(mp_int *a, int size)
{
int i;
mp_digit *tmp;
/* if the alloc size is smaller alloc more ram */
if (a->alloc < size) {
/* reallocate the array a->dp
*
* We store the return in a temporary variable
* in case the operation failed we don't want
* to overwrite the dp member of a.
*/
tmp = (mp_digit *) MP_REALLOC(a->dp,
(size_t)a->alloc * sizeof(mp_digit),
(size_t)size * sizeof(mp_digit));
if (tmp == NULL) {
/* reallocation failed but "a" is still valid [can be freed] */
return MP_MEM;
}
/* reallocation succeeded so set a->dp */
a->dp = tmp;
/* zero excess digits */
i = a->alloc;
a->alloc = size;
MP_ZERO_DIGITS(a->dp + i, a->alloc - i);
}
return MP_OKAY;
}
#endif
|
Deleted libtommath/bn_mp_import.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added libtommath/bn_mp_incr.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
#include "tommath_private.h"
#ifdef BN_MP_INCR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* Increment "a" by one like "a++". Changes input! */
mp_err mp_incr(mp_int *a)
{
if (MP_IS_ZERO(a)) {
mp_set(a,1uL);
return MP_OKAY;
} else if (a->sign == MP_NEG) {
mp_err err;
a->sign = MP_ZPOS;
if ((err = mp_decr(a)) != MP_OKAY) {
return err;
}
/* There is no -0 in LTM */
if (!MP_IS_ZERO(a)) {
a->sign = MP_NEG;
}
return MP_OKAY;
} else if (a->dp[0] < MP_DIGIT_MAX) {
a->dp[0]++;
return MP_OKAY;
} else {
return mp_add_d(a, 1uL,a);
}
}
#endif
|
Changes to libtommath/bn_mp_init.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_INIT_C | | < < < < < < < < | < | < < | < < < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
#include "tommath_private.h"
#ifdef BN_MP_INIT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* init a new mp_int */
mp_err mp_init(mp_int *a)
{
/* allocate memory required and clear it */
a->dp = (mp_digit *) MP_CALLOC((size_t)MP_PREC, sizeof(mp_digit));
if (a->dp == NULL) {
return MP_MEM;
}
/* set the used to zero, allocated digits to the default precision
* and sign to positive */
a->used = 0;
a->alloc = MP_PREC;
a->sign = MP_ZPOS;
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_init_copy.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_INIT_COPY_C | | < < < < < < < < | < | | | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
#include "tommath_private.h"
#ifdef BN_MP_INIT_COPY_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* creates "a" then copies b into it */
mp_err mp_init_copy(mp_int *a, const mp_int *b)
{
mp_err err;
if ((err = mp_init_size(a, b->used)) != MP_OKAY) {
return err;
}
if ((err = mp_copy(b, a)) != MP_OKAY) {
mp_clear(a);
}
return err;
}
#endif
|
Added libtommath/bn_mp_init_i32.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_INIT_I32_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_INIT_INT(mp_init_i32, mp_set_i32, int32_t) #endif |
Added libtommath/bn_mp_init_i64.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_INIT_I64_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_INIT_INT(mp_init_i64, mp_set_i64, int64_t) #endif |
Added libtommath/bn_mp_init_l.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_INIT_L_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_INIT_INT(mp_init_l, mp_set_l, long) #endif |
Added libtommath/bn_mp_init_ll.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_INIT_LL_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_INIT_INT(mp_init_ll, mp_set_ll, long long) #endif |
Changes to libtommath/bn_mp_init_multi.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_INIT_MULTI_C | | < < < < < < < < | < | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 |
#include "tommath_private.h"
#ifdef BN_MP_INIT_MULTI_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
#include <stdarg.h>
mp_err mp_init_multi(mp_int *mp, ...)
{
mp_err err = MP_OKAY; /* Assume ok until proven otherwise */
int n = 0; /* Number of ok inits */
mp_int *cur_arg = mp;
va_list args;
va_start(args, mp); /* init args to next argument from caller */
while (cur_arg != NULL) {
if (mp_init(cur_arg) != MP_OKAY) {
/* Oops - error! Back-track and mp_clear what we already
succeeded in init-ing, then return error.
*/
va_list clean_args;
/* now start cleaning up */
cur_arg = mp;
va_start(clean_args, mp);
while (n-- != 0) {
mp_clear(cur_arg);
cur_arg = va_arg(clean_args, mp_int *);
}
va_end(clean_args);
err = MP_MEM;
break;
}
n++;
cur_arg = va_arg(args, mp_int *);
}
va_end(args);
return err; /* Assumed ok, if error flagged above. */
}
#endif
|
Changes to libtommath/bn_mp_init_set.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_INIT_SET_C | | < < < < < < < < | < | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 |
#include "tommath_private.h"
#ifdef BN_MP_INIT_SET_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* initialize and set a digit */
mp_err mp_init_set(mp_int *a, mp_digit b)
{
mp_err err;
if ((err = mp_init(a)) != MP_OKAY) {
return err;
}
mp_set(a, b);
return err;
}
#endif
|
Deleted libtommath/bn_mp_init_set_int.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to libtommath/bn_mp_init_size.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_INIT_SIZE_C | | < < < < < < < < | < | < | < < | < < < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
#include "tommath_private.h"
#ifdef BN_MP_INIT_SIZE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* init an mp_init for a given size */
mp_err mp_init_size(mp_int *a, int size)
{
size = MP_MAX(MP_MIN_PREC, size);
/* alloc mem */
a->dp = (mp_digit *) MP_CALLOC((size_t)size, sizeof(mp_digit));
if (a->dp == NULL) {
return MP_MEM;
}
/* set the members */
a->used = 0;
a->alloc = size;
a->sign = MP_ZPOS;
return MP_OKAY;
}
#endif
|
Added libtommath/bn_mp_init_u32.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_INIT_U32_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_INIT_INT(mp_init_u32, mp_set_u32, uint32_t) #endif |
Added libtommath/bn_mp_init_u64.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_INIT_U64_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_INIT_INT(mp_init_u64, mp_set_u64, uint64_t) #endif |
Added libtommath/bn_mp_init_ul.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_INIT_UL_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_INIT_INT(mp_init_ul, mp_set_ul, unsigned long) #endif |
Added libtommath/bn_mp_init_ull.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_INIT_ULL_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_INIT_INT(mp_init_ull, mp_set_ull, unsigned long long) #endif |
Changes to libtommath/bn_mp_invmod.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_INVMOD_C | | < < < < < < < < | < | < | | < | | < | < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
#include "tommath_private.h"
#ifdef BN_MP_INVMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* hac 14.61, pp608 */
mp_err mp_invmod(const mp_int *a, const mp_int *b, mp_int *c)
{
/* b cannot be negative and has to be >1 */
if ((b->sign == MP_NEG) || (mp_cmp_d(b, 1uL) != MP_GT)) {
return MP_VAL;
}
/* if the modulus is odd we can use a faster routine instead */
if (MP_HAS(S_MP_INVMOD_FAST) && MP_IS_ODD(b)) {
return s_mp_invmod_fast(a, b, c);
}
return MP_HAS(S_MP_INVMOD_SLOW)
? s_mp_invmod_slow(a, b, c)
: MP_VAL;
}
#endif
|
Deleted libtommath/bn_mp_invmod_slow.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to libtommath/bn_mp_is_square.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_IS_SQUARE_C | | < < < < < < < < | < | 1 2 3 4 5 6 7 8 9 10 11 |
#include "tommath_private.h"
#ifdef BN_MP_IS_SQUARE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* Check if remainders are possible squares - fast exclude non-squares */
static const char rem_128[128] = {
0, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
0, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
1, 0, 1, 1, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1,
|
| ︙ | ︙ | |||
31 32 33 34 35 36 37 | 1, 0, 1, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 0, 1, 1, 0, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1 }; /* Store non-zero to ret if arg is square, and zero if not */ | | | | | | | | | | | | | | | < < < < | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 |
1, 0, 1, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1, 1,
0, 1, 1, 1, 0, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1,
1, 1, 1, 1, 0, 1, 0, 1, 1, 0, 0, 1, 1, 1, 1,
1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1
};
/* Store non-zero to ret if arg is square, and zero if not */
mp_err mp_is_square(const mp_int *arg, mp_bool *ret)
{
mp_err err;
mp_digit c;
mp_int t;
unsigned long r;
/* Default to Non-square :) */
*ret = MP_NO;
if (arg->sign == MP_NEG) {
return MP_VAL;
}
if (MP_IS_ZERO(arg)) {
return MP_OKAY;
}
/* First check mod 128 (suppose that MP_DIGIT_BIT is at least 7) */
if (rem_128[127u & arg->dp[0]] == (char)1) {
return MP_OKAY;
}
/* Next check mod 105 (3*5*7) */
if ((err = mp_mod_d(arg, 105uL, &c)) != MP_OKAY) {
return err;
}
if (rem_105[c] == (char)1) {
return MP_OKAY;
}
if ((err = mp_init_u32(&t, 11u*13u*17u*19u*23u*29u*31u)) != MP_OKAY) {
return err;
}
if ((err = mp_mod(arg, &t, &t)) != MP_OKAY) {
goto LBL_ERR;
}
r = mp_get_u32(&t);
/* Check for other prime modules, note it's not an ERROR but we must
* free "t" so the easiest way is to goto LBL_ERR. We know that err
* is already equal to MP_OKAY from the mp_mod call
*/
if (((1uL<<(r%11uL)) & 0x5C4uL) != 0uL) goto LBL_ERR;
if (((1uL<<(r%13uL)) & 0x9E4uL) != 0uL) goto LBL_ERR;
if (((1uL<<(r%17uL)) & 0x5CE8uL) != 0uL) goto LBL_ERR;
if (((1uL<<(r%19uL)) & 0x4F50CuL) != 0uL) goto LBL_ERR;
if (((1uL<<(r%23uL)) & 0x7ACCA0uL) != 0uL) goto LBL_ERR;
if (((1uL<<(r%29uL)) & 0xC2EDD0CuL) != 0uL) goto LBL_ERR;
if (((1uL<<(r%31uL)) & 0x6DE2B848uL) != 0uL) goto LBL_ERR;
/* Final check - is sqr(sqrt(arg)) == arg ? */
if ((err = mp_sqrt(arg, &t)) != MP_OKAY) {
goto LBL_ERR;
}
if ((err = mp_sqr(&t, &t)) != MP_OKAY) {
goto LBL_ERR;
}
*ret = (mp_cmp_mag(&t, arg) == MP_EQ) ? MP_YES : MP_NO;
LBL_ERR:
mp_clear(&t);
return err;
}
#endif
|
Added libtommath/bn_mp_iseven.c.
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 |
#include "tommath_private.h"
#ifdef BN_MP_ISEVEN_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
mp_bool mp_iseven(const mp_int *a)
{
return MP_IS_EVEN(a) ? MP_YES : MP_NO;
}
#endif
|
Added libtommath/bn_mp_isodd.c.
> > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 |
#include "tommath_private.h"
#ifdef BN_MP_ISODD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
mp_bool mp_isodd(const mp_int *a)
{
return MP_IS_ODD(a) ? MP_YES : MP_NO;
}
#endif
|
Deleted libtommath/bn_mp_jacobi.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/bn_mp_karatsuba_mul.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/bn_mp_karatsuba_sqr.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to libtommath/bn_mp_kronecker.c.
1 2 3 | #include "tommath_private.h" #ifdef BN_MP_KRONECKER_C | | < < < < < < < < | < | | < | < > | | | | < | | | | | | | | | | | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 |
#include "tommath_private.h"
#ifdef BN_MP_KRONECKER_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/*
Kronecker symbol (a|p)
Straightforward implementation of algorithm 1.4.10 in
Henri Cohen: "A Course in Computational Algebraic Number Theory"
@book{cohen2013course,
title={A course in computational algebraic number theory},
author={Cohen, Henri},
volume={138},
year={2013},
publisher={Springer Science \& Business Media}
}
*/
mp_err mp_kronecker(const mp_int *a, const mp_int *p, int *c)
{
mp_int a1, p1, r;
mp_err err;
int v, k;
static const int table[8] = {0, 1, 0, -1, 0, -1, 0, 1};
if (MP_IS_ZERO(p)) {
if ((a->used == 1) && (a->dp[0] == 1u)) {
*c = 1;
} else {
*c = 0;
}
return MP_OKAY;
}
if (MP_IS_EVEN(a) && MP_IS_EVEN(p)) {
*c = 0;
return MP_OKAY;
}
if ((err = mp_init_copy(&a1, a)) != MP_OKAY) {
return err;
}
if ((err = mp_init_copy(&p1, p)) != MP_OKAY) {
goto LBL_KRON_0;
}
v = mp_cnt_lsb(&p1);
if ((err = mp_div_2d(&p1, v, &p1, NULL)) != MP_OKAY) {
goto LBL_KRON_1;
}
if ((v & 1) == 0) {
k = 1;
} else {
k = table[a->dp[0] & 7u];
}
if (p1.sign == MP_NEG) {
p1.sign = MP_ZPOS;
if (a1.sign == MP_NEG) {
k = -k;
}
}
if ((err = mp_init(&r)) != MP_OKAY) {
goto LBL_KRON_1;
}
for (;;) {
if (MP_IS_ZERO(&a1)) {
if (mp_cmp_d(&p1, 1uL) == MP_EQ) {
*c = k;
goto LBL_KRON;
} else {
*c = 0;
goto LBL_KRON;
}
}
v = mp_cnt_lsb(&a1);
if ((err = mp_div_2d(&a1, v, &a1, NULL)) != MP_OKAY) {
goto LBL_KRON;
}
if ((v & 1) == 1) {
k = k * table[p1.dp[0] & 7u];
}
if (a1.sign == MP_NEG) {
/*
* Compute k = (-1)^((a1)*(p1-1)/4) * k
* a1.dp[0] + 1 cannot overflow because the MSB
* of the type mp_digit is not set by definition
*/
if (((a1.dp[0] + 1u) & p1.dp[0] & 2u) != 0u) {
k = -k;
}
} else {
/* compute k = (-1)^((a1-1)*(p1-1)/4) * k */
if ((a1.dp[0] & p1.dp[0] & 2u) != 0u) {
k = -k;
}
}
if ((err = mp_copy(&a1, &r)) != MP_OKAY) {
goto LBL_KRON;
}
r.sign = MP_ZPOS;
if ((err = mp_mod(&p1, &r, &a1)) != MP_OKAY) {
goto LBL_KRON;
}
if ((err = mp_copy(&r, &p1)) != MP_OKAY) {
goto LBL_KRON;
}
}
LBL_KRON:
mp_clear(&r);
LBL_KRON_1:
mp_clear(&p1);
LBL_KRON_0:
mp_clear(&a1);
return err;
}
#endif
|
Changes to libtommath/bn_mp_lcm.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_LCM_C | | < < < < < < < < | < | | | | | | | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
#include "tommath_private.h"
#ifdef BN_MP_LCM_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* computes least common multiple as |a*b|/(a, b) */
mp_err mp_lcm(const mp_int *a, const mp_int *b, mp_int *c)
{
mp_err err;
mp_int t1, t2;
if ((err = mp_init_multi(&t1, &t2, NULL)) != MP_OKAY) {
return err;
}
/* t1 = get the GCD of the two inputs */
if ((err = mp_gcd(a, b, &t1)) != MP_OKAY) {
goto LBL_T;
}
/* divide the smallest by the GCD */
if (mp_cmp_mag(a, b) == MP_LT) {
/* store quotient in t2 such that t2 * b is the LCM */
if ((err = mp_div(a, &t1, &t2, NULL)) != MP_OKAY) {
goto LBL_T;
}
err = mp_mul(b, &t2, c);
} else {
/* store quotient in t2 such that t2 * a is the LCM */
if ((err = mp_div(b, &t1, &t2, NULL)) != MP_OKAY) {
goto LBL_T;
}
err = mp_mul(a, &t2, c);
}
/* fix the sign to positive */
c->sign = MP_ZPOS;
LBL_T:
mp_clear_multi(&t1, &t2, NULL);
return err;
}
#endif
|
Added libtommath/bn_mp_log_u32.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 |
#include "tommath_private.h"
#ifdef BN_MP_LOG_U32_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* Compute log_{base}(a) */
static mp_word s_pow(mp_word base, mp_word exponent)
{
mp_word result = 1u;
while (exponent != 0u) {
if ((exponent & 1u) == 1u) {
result *= base;
}
exponent >>= 1;
base *= base;
}
return result;
}
static mp_digit s_digit_ilogb(mp_digit base, mp_digit n)
{
mp_word bracket_low = 1u, bracket_mid, bracket_high, N;
mp_digit ret, high = 1u, low = 0uL, mid;
if (n < base) {
return 0uL;
}
if (n == base) {
return 1uL;
}
bracket_high = (mp_word) base ;
N = (mp_word) n;
while (bracket_high < N) {
low = high;
bracket_low = bracket_high;
high <<= 1;
bracket_high *= bracket_high;
}
while (((mp_digit)(high - low)) > 1u) {
mid = (low + high) >> 1;
bracket_mid = bracket_low * s_pow(base, (mp_word)(mid - low));
if (N < bracket_mid) {
high = mid ;
bracket_high = bracket_mid ;
}
if (N > bracket_mid) {
low = mid ;
bracket_low = bracket_mid ;
}
if (N == bracket_mid) {
return (mp_digit) mid;
}
}
if (bracket_high == N) {
ret = high;
} else {
ret = low;
}
return ret;
}
/* TODO: output could be "int" because the output of mp_radix_size is int, too,
as is the output of mp_bitcount.
With the same problem: max size is INT_MAX * MP_DIGIT not INT_MAX only!
*/
mp_err mp_log_u32(const mp_int *a, uint32_t base, uint32_t *c)
{
mp_err err;
mp_ord cmp;
uint32_t high, low, mid;
mp_int bracket_low, bracket_high, bracket_mid, t, bi_base;
err = MP_OKAY;
if (a->sign == MP_NEG) {
return MP_VAL;
}
if (MP_IS_ZERO(a)) {
return MP_VAL;
}
if (base < 2u) {
return MP_VAL;
}
/* A small shortcut for bases that are powers of two. */
if ((base & (base - 1u)) == 0u) {
int y, bit_count;
for (y=0; (y < 7) && ((base & 1u) == 0u); y++) {
base >>= 1;
}
bit_count = mp_count_bits(a) - 1;
*c = (uint32_t)(bit_count/y);
return MP_OKAY;
}
if (a->used == 1) {
*c = (uint32_t)s_digit_ilogb(base, a->dp[0]);
return err;
}
cmp = mp_cmp_d(a, base);
if ((cmp == MP_LT) || (cmp == MP_EQ)) {
*c = cmp == MP_EQ;
return err;
}
if ((err =
mp_init_multi(&bracket_low, &bracket_high,
&bracket_mid, &t, &bi_base, NULL)) != MP_OKAY) {
return err;
}
low = 0u;
mp_set(&bracket_low, 1uL);
high = 1u;
mp_set(&bracket_high, base);
/*
A kind of Giant-step/baby-step algorithm.
Idea shamelessly stolen from https://programmingpraxis.com/2010/05/07/integer-logarithms/2/
The effect is asymptotic, hence needs benchmarks to test if the Giant-step should be skipped
for small n.
*/
while (mp_cmp(&bracket_high, a) == MP_LT) {
low = high;
if ((err = mp_copy(&bracket_high, &bracket_low)) != MP_OKAY) {
goto LBL_ERR;
}
high <<= 1;
if ((err = mp_sqr(&bracket_high, &bracket_high)) != MP_OKAY) {
goto LBL_ERR;
}
}
mp_set(&bi_base, base);
while ((high - low) > 1u) {
mid = (high + low) >> 1;
if ((err = mp_expt_u32(&bi_base, (uint32_t)(mid - low), &t)) != MP_OKAY) {
goto LBL_ERR;
}
if ((err = mp_mul(&bracket_low, &t, &bracket_mid)) != MP_OKAY) {
goto LBL_ERR;
}
cmp = mp_cmp(a, &bracket_mid);
if (cmp == MP_LT) {
high = mid;
mp_exch(&bracket_mid, &bracket_high);
}
if (cmp == MP_GT) {
low = mid;
mp_exch(&bracket_mid, &bracket_low);
}
if (cmp == MP_EQ) {
*c = mid;
goto LBL_END;
}
}
*c = (mp_cmp(&bracket_high, a) == MP_EQ) ? high : low;
LBL_END:
LBL_ERR:
mp_clear_multi(&bracket_low, &bracket_high, &bracket_mid,
&t, &bi_base, NULL);
return err;
}
#endif
|
Changes to libtommath/bn_mp_lshd.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_LSHD_C | | < < < < < < < < | < | | > > | | | < < < | | | | | | | | | | | | | | | < < | < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 |
#include "tommath_private.h"
#ifdef BN_MP_LSHD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* shift left a certain amount of digits */
mp_err mp_lshd(mp_int *a, int b)
{
int x;
mp_err err;
mp_digit *top, *bottom;
/* if its less than zero return */
if (b <= 0) {
return MP_OKAY;
}
/* no need to shift 0 around */
if (MP_IS_ZERO(a)) {
return MP_OKAY;
}
/* grow to fit the new digits */
if (a->alloc < (a->used + b)) {
if ((err = mp_grow(a, a->used + b)) != MP_OKAY) {
return err;
}
}
/* increment the used by the shift amount then copy upwards */
a->used += b;
/* top */
top = a->dp + a->used - 1;
/* base */
bottom = (a->dp + a->used - 1) - b;
/* much like mp_rshd this is implemented using a sliding window
* except the window goes the otherway around. Copying from
* the bottom to the top. see bn_mp_rshd.c for more info.
*/
for (x = a->used - 1; x >= b; x--) {
*top-- = *bottom--;
}
/* zero the lower digits */
MP_ZERO_DIGITS(a->dp, b);
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_mod.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_MOD_C | | < < < < < < < < | < | | | | | < < > | | | > | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
#include "tommath_private.h"
#ifdef BN_MP_MOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* c = a mod b, 0 <= c < b if b > 0, b < c <= 0 if b < 0 */
mp_err mp_mod(const mp_int *a, const mp_int *b, mp_int *c)
{
mp_int t;
mp_err err;
if ((err = mp_init_size(&t, b->used)) != MP_OKAY) {
return err;
}
if ((err = mp_div(a, b, NULL, &t)) != MP_OKAY) {
goto LBL_ERR;
}
if (MP_IS_ZERO(&t) || (t.sign == b->sign)) {
err = MP_OKAY;
mp_exch(&t, c);
} else {
err = mp_add(b, &t, c);
}
LBL_ERR:
mp_clear(&t);
return err;
}
#endif
|
Changes to libtommath/bn_mp_mod_2d.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_MOD_2D_C | | < < < < < < < < | < | | > | | < | | | | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
#include "tommath_private.h"
#ifdef BN_MP_MOD_2D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* calc a value mod 2**b */
mp_err mp_mod_2d(const mp_int *a, int b, mp_int *c)
{
int x;
mp_err err;
/* if b is <= 0 then zero the int */
if (b <= 0) {
mp_zero(c);
return MP_OKAY;
}
/* if the modulus is larger than the value than return */
if (b >= (a->used * MP_DIGIT_BIT)) {
return mp_copy(a, c);
}
/* copy */
if ((err = mp_copy(a, c)) != MP_OKAY) {
return err;
}
/* zero digits above the last digit of the modulus */
x = (b / MP_DIGIT_BIT) + (((b % MP_DIGIT_BIT) == 0) ? 0 : 1);
MP_ZERO_DIGITS(c->dp + x, c->used - x);
/* clear the digit that is not completely outside/inside the modulus */
c->dp[b / MP_DIGIT_BIT] &=
((mp_digit)1 << (mp_digit)(b % MP_DIGIT_BIT)) - (mp_digit)1;
mp_clamp(c);
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_mod_d.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_MOD_D_C | | < < < < < < < < | < | < < < < | 1 2 3 4 5 6 7 8 9 10 |
#include "tommath_private.h"
#ifdef BN_MP_MOD_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
mp_err mp_mod_d(const mp_int *a, mp_digit b, mp_digit *c)
{
return mp_div_d(a, b, NULL, c);
}
#endif
|
Changes to libtommath/bn_mp_montgomery_calc_normalization.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_MONTGOMERY_CALC_NORMALIZATION_C | | < < < < < < < < | < | | > | | | | | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
#include "tommath_private.h"
#ifdef BN_MP_MONTGOMERY_CALC_NORMALIZATION_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/*
* shifts with subtractions when the result is greater than b.
*
* The method is slightly modified to shift B unconditionally upto just under
* the leading bit of b. This saves alot of multiple precision shifting.
*/
mp_err mp_montgomery_calc_normalization(mp_int *a, const mp_int *b)
{
int x, bits;
mp_err err;
/* how many bits of last digit does b use */
bits = mp_count_bits(b) % MP_DIGIT_BIT;
if (b->used > 1) {
if ((err = mp_2expt(a, ((b->used - 1) * MP_DIGIT_BIT) + bits - 1)) != MP_OKAY) {
return err;
}
} else {
mp_set(a, 1uL);
bits = 1;
}
/* now compute C = A * B mod b */
for (x = bits - 1; x < (int)MP_DIGIT_BIT; x++) {
if ((err = mp_mul_2(a, a)) != MP_OKAY) {
return err;
}
if (mp_cmp_mag(a, b) != MP_LT) {
if ((err = s_mp_sub(a, b, a)) != MP_OKAY) {
return err;
}
}
}
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_montgomery_reduce.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_MONTGOMERY_REDUCE_C | | < < < < < < < < | < | | > | | | < | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
#include "tommath_private.h"
#ifdef BN_MP_MONTGOMERY_REDUCE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* computes xR**-1 == x (mod N) via Montgomery Reduction */
mp_err mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho)
{
int ix, digs;
mp_err err;
mp_digit mu;
/* can the fast reduction [comba] method be used?
*
* Note that unlike in mul you're safely allowed *less*
* than the available columns [255 per default] since carries
* are fixed up in the inner loop.
*/
digs = (n->used * 2) + 1;
if ((digs < MP_WARRAY) &&
(x->used <= MP_WARRAY) &&
(n->used < MP_MAXFAST)) {
return s_mp_montgomery_reduce_fast(x, n, rho);
}
/* grow the input as required */
if (x->alloc < digs) {
if ((err = mp_grow(x, digs)) != MP_OKAY) {
return err;
}
}
x->used = digs;
for (ix = 0; ix < n->used; ix++) {
/* mu = ai * rho mod b
*
|
| ︙ | ︙ | |||
69 70 71 72 73 74 75 |
/* Multiply and add in place */
for (iy = 0; iy < n->used; iy++) {
/* compute product and sum */
r = ((mp_word)mu * (mp_word)*tmpn++) +
(mp_word)u + (mp_word)*tmpx;
/* get carry */
| | | | 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 |
/* Multiply and add in place */
for (iy = 0; iy < n->used; iy++) {
/* compute product and sum */
r = ((mp_word)mu * (mp_word)*tmpn++) +
(mp_word)u + (mp_word)*tmpx;
/* get carry */
u = (mp_digit)(r >> (mp_word)MP_DIGIT_BIT);
/* fix digit */
*tmpx++ = (mp_digit)(r & (mp_word)MP_MASK);
}
/* At this point the ix'th digit of x should be zero */
/* propagate carries upwards as required*/
while (u != 0u) {
*tmpx += u;
u = *tmpx >> MP_DIGIT_BIT;
*tmpx++ &= MP_MASK;
}
}
}
/* at this point the n.used'th least
* significant digits of x are all zero
|
| ︙ | ︙ | |||
105 106 107 108 109 110 111 |
if (mp_cmp_mag(x, n) != MP_LT) {
return s_mp_sub(x, n, x);
}
return MP_OKAY;
}
#endif
| < < < < | 96 97 98 99 100 101 102 |
if (mp_cmp_mag(x, n) != MP_LT) {
return s_mp_sub(x, n, x);
}
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_montgomery_setup.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_MONTGOMERY_SETUP_C | | < < < < < < < < | < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
#include "tommath_private.h"
#ifdef BN_MP_MONTGOMERY_SETUP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* setups the montgomery reduction stuff */
mp_err mp_montgomery_setup(const mp_int *n, mp_digit *rho)
{
mp_digit x, b;
/* fast inversion mod 2**k
*
* Based on the fact that
*
|
| ︙ | ︙ | |||
40 41 42 43 44 45 46 | x *= 2u - (b * x); /* here x*a==1 mod 2**32 */ #endif #ifdef MP_64BIT x *= 2u - (b * x); /* here x*a==1 mod 2**64 */ #endif /* rho = -1/m mod b */ | | < < < < | 31 32 33 34 35 36 37 38 39 40 41 42 | x *= 2u - (b * x); /* here x*a==1 mod 2**32 */ #endif #ifdef MP_64BIT x *= 2u - (b * x); /* here x*a==1 mod 2**64 */ #endif /* rho = -1/m mod b */ *rho = (mp_digit)(((mp_word)1 << (mp_word)MP_DIGIT_BIT) - x) & MP_MASK; return MP_OKAY; } #endif |
Changes to libtommath/bn_mp_mul.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_MUL_C | | < < < < < < < < | < | > | > > | > > | > > > > > > > > > > > > | | | | < | < < | | < < | | | | | | | | > | < < < | | < < < < < | < | < | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 |
#include "tommath_private.h"
#ifdef BN_MP_MUL_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* high level multiplication (handles sign) */
mp_err mp_mul(const mp_int *a, const mp_int *b, mp_int *c)
{
mp_err err;
int min_len = MP_MIN(a->used, b->used),
max_len = MP_MAX(a->used, b->used),
digs = a->used + b->used + 1;
mp_sign neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG;
if (a == b) {
return mp_sqr(a,c);
} else if (MP_HAS(S_MP_BALANCE_MUL) &&
/* Check sizes. The smaller one needs to be larger than the Karatsuba cut-off.
* The bigger one needs to be at least about one MP_KARATSUBA_MUL_CUTOFF bigger
* to make some sense, but it depends on architecture, OS, position of the
* stars... so YMMV.
* Using it to cut the input into slices small enough for fast_s_mp_mul_digs
* was actually slower on the author's machine, but YMMV.
*/
(min_len >= MP_KARATSUBA_MUL_CUTOFF) &&
((max_len / 2) >= MP_KARATSUBA_MUL_CUTOFF) &&
/* Not much effect was observed below a ratio of 1:2, but again: YMMV. */
(max_len >= (2 * min_len))) {
err = s_mp_balance_mul(a,b,c);
} else if (MP_HAS(S_MP_TOOM_MUL) &&
(min_len >= MP_TOOM_MUL_CUTOFF)) {
err = s_mp_toom_mul(a, b, c);
} else if (MP_HAS(S_MP_KARATSUBA_MUL) &&
(min_len >= MP_KARATSUBA_MUL_CUTOFF)) {
err = s_mp_karatsuba_mul(a, b, c);
} else if (MP_HAS(S_MP_MUL_DIGS_FAST) &&
/* can we use the fast multiplier?
*
* The fast multiplier can be used if the output will
* have less than MP_WARRAY digits and the number of
* digits won't affect carry propagation
*/
(digs < MP_WARRAY) &&
(min_len <= MP_MAXFAST)) {
err = s_mp_mul_digs_fast(a, b, c, digs);
} else if (MP_HAS(S_MP_MUL_DIGS)) {
err = s_mp_mul_digs(a, b, c, digs);
} else {
err = MP_VAL;
}
c->sign = (c->used > 0) ? neg : MP_ZPOS;
return err;
}
#endif
|
Changes to libtommath/bn_mp_mul_2.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_MUL_2_C | | < < < < < < < < | < | | > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
#include "tommath_private.h"
#ifdef BN_MP_MUL_2_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* b = a*2 */
mp_err mp_mul_2(const mp_int *a, mp_int *b)
{
int x, oldused;
mp_err err;
/* grow to accomodate result */
if (b->alloc < (a->used + 1)) {
if ((err = mp_grow(b, a->used + 1)) != MP_OKAY) {
return err;
}
}
oldused = b->used;
b->used = a->used;
{
|
| ︙ | ︙ | |||
39 40 41 42 43 44 45 |
/* carry */
r = 0;
for (x = 0; x < a->used; x++) {
/* get what will be the *next* carry bit from the
* MSB of the current digit
*/
| | | < < < < < < < | 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 |
/* carry */
r = 0;
for (x = 0; x < a->used; x++) {
/* get what will be the *next* carry bit from the
* MSB of the current digit
*/
rr = *tmpa >> (mp_digit)(MP_DIGIT_BIT - 1);
/* now shift up this digit, add in the carry [from the previous] */
*tmpb++ = ((*tmpa++ << 1uL) | r) & MP_MASK;
/* copy the carry that would be from the source
* digit into the next iteration
*/
r = rr;
}
/* new leading digit? */
if (r != 0u) {
/* add a MSB which is always 1 at this point */
*tmpb = 1;
++(b->used);
}
/* now zero any excess digits on the destination
* that we didn't write to
*/
MP_ZERO_DIGITS(b->dp + b->used, oldused - b->used);
}
b->sign = a->sign;
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_mul_2d.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_MUL_2D_C | | < < < < < < < < | < | | | | | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 |
#include "tommath_private.h"
#ifdef BN_MP_MUL_2D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* shift left by a certain bit count */
mp_err mp_mul_2d(const mp_int *a, int b, mp_int *c)
{
mp_digit d;
mp_err err;
/* copy */
if (a != c) {
if ((err = mp_copy(a, c)) != MP_OKAY) {
return err;
}
}
if (c->alloc < (c->used + (b / MP_DIGIT_BIT) + 1)) {
if ((err = mp_grow(c, c->used + (b / MP_DIGIT_BIT) + 1)) != MP_OKAY) {
return err;
}
}
/* shift by as many digits in the bit count */
if (b >= MP_DIGIT_BIT) {
if ((err = mp_lshd(c, b / MP_DIGIT_BIT)) != MP_OKAY) {
return err;
}
}
/* shift any bit count < MP_DIGIT_BIT */
d = (mp_digit)(b % MP_DIGIT_BIT);
if (d != 0u) {
mp_digit *tmpc, shift, mask, r, rr;
int x;
/* bitmask for carries */
mask = ((mp_digit)1 << d) - (mp_digit)1;
/* shift for msbs */
shift = (mp_digit)MP_DIGIT_BIT - d;
/* alias */
tmpc = c->dp;
/* carry */
r = 0;
for (x = 0; x < c->used; x++) {
|
| ︙ | ︙ | |||
72 73 74 75 76 77 78 |
c->dp[(c->used)++] = r;
}
}
mp_clamp(c);
return MP_OKAY;
}
#endif
| < < < < | 63 64 65 66 67 68 69 |
c->dp[(c->used)++] = r;
}
}
mp_clamp(c);
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_mul_d.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_MUL_D_C | | < < < < < < < < | < | > | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
#include "tommath_private.h"
#ifdef BN_MP_MUL_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* multiply by a digit */
mp_err mp_mul_d(const mp_int *a, mp_digit b, mp_int *c)
{
mp_digit u, *tmpa, *tmpc;
mp_word r;
mp_err err;
int ix, olduse;
/* make sure c is big enough to hold a*b */
if (c->alloc < (a->used + 1)) {
if ((err = mp_grow(c, a->used + 1)) != MP_OKAY) {
return err;
}
}
/* get the original destinations used count */
olduse = c->used;
/* set the sign */
|
| ︙ | ︙ | |||
46 47 48 49 50 51 52 |
/* compute product and carry sum for this term */
r = (mp_word)u + ((mp_word)*tmpa++ * (mp_word)b);
/* mask off higher bits to get a single digit */
*tmpc++ = (mp_digit)(r & (mp_word)MP_MASK);
/* send carry into next iteration */
| | | < < < < < < | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
/* compute product and carry sum for this term */
r = (mp_word)u + ((mp_word)*tmpa++ * (mp_word)b);
/* mask off higher bits to get a single digit */
*tmpc++ = (mp_digit)(r & (mp_word)MP_MASK);
/* send carry into next iteration */
u = (mp_digit)(r >> (mp_word)MP_DIGIT_BIT);
}
/* store final carry [if any] and increment ix offset */
*tmpc++ = u;
++ix;
/* now zero digits above the top */
MP_ZERO_DIGITS(tmpc, olduse - ix);
/* set used count */
c->used = a->used + 1;
mp_clamp(c);
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_mulmod.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_MULMOD_C | | < < < < < < < < | < | < > | | | | < < > | > > | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
#include "tommath_private.h"
#ifdef BN_MP_MULMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* d = a * b (mod c) */
mp_err mp_mulmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d)
{
mp_err err;
mp_int t;
if ((err = mp_init_size(&t, c->used)) != MP_OKAY) {
return err;
}
if ((err = mp_mul(a, b, &t)) != MP_OKAY) {
goto LBL_ERR;
}
err = mp_mod(&t, c, d);
LBL_ERR:
mp_clear(&t);
return err;
}
#endif
|
Deleted libtommath/bn_mp_n_root.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/bn_mp_n_root_ex.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to libtommath/bn_mp_neg.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_NEG_C | | < < < < < < < < | < | < > | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
#include "tommath_private.h"
#ifdef BN_MP_NEG_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* b = -a */
mp_err mp_neg(const mp_int *a, mp_int *b)
{
mp_err err;
if (a != b) {
if ((err = mp_copy(a, b)) != MP_OKAY) {
return err;
}
}
if (!MP_IS_ZERO(b)) {
b->sign = (a->sign == MP_ZPOS) ? MP_NEG : MP_ZPOS;
} else {
b->sign = MP_ZPOS;
}
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_or.c.
1 2 3 4 5 6 7 8 |
#include "tommath_private.h"
#ifdef BN_MP_OR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* two complement or */
mp_err mp_or(const mp_int *a, const mp_int *b, mp_int *c)
{
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 |
#include "tommath_private.h"
#ifdef BN_MP_OR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* two complement or */
mp_err mp_or(const mp_int *a, const mp_int *b, mp_int *c)
{
int used = MP_MAX(a->used, b->used) + 1, i;
mp_err err;
mp_digit ac = 1, bc = 1, cc = 1;
mp_sign csign = ((a->sign == MP_NEG) || (b->sign == MP_NEG)) ? MP_NEG : MP_ZPOS;
if (c->alloc < used) {
if ((err = mp_grow(c, used)) != MP_OKAY) {
return err;
|
| ︙ | ︙ |
Added libtommath/bn_mp_pack.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 |
#include "tommath_private.h"
#ifdef BN_MP_PACK_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* based on gmp's mpz_export.
* see http://gmplib.org/manual/Integer-Import-and-Export.html
*/
mp_err mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order, size_t size,
mp_endian endian, size_t nails, const mp_int *op)
{
mp_err err;
size_t odd_nails, nail_bytes, i, j, count;
unsigned char odd_nail_mask;
mp_int t;
count = mp_pack_count(op, nails, size);
if (count > maxcount) {
return MP_BUF;
}
if ((err = mp_init_copy(&t, op)) != MP_OKAY) {
return err;
}
if (endian == MP_NATIVE_ENDIAN) {
MP_GET_ENDIANNESS(endian);
}
odd_nails = (nails % 8u);
odd_nail_mask = 0xff;
for (i = 0u; i < odd_nails; ++i) {
odd_nail_mask ^= (unsigned char)(1u << (7u - i));
}
nail_bytes = nails / 8u;
for (i = 0u; i < count; ++i) {
for (j = 0u; j < size; ++j) {
unsigned char *byte = (unsigned char *)rop +
(((order == MP_LSB_FIRST) ? i : ((count - 1u) - i)) * size) +
((endian == MP_LITTLE_ENDIAN) ? j : ((size - 1u) - j));
if (j >= (size - nail_bytes)) {
*byte = 0;
continue;
}
*byte = (unsigned char)((j == ((size - nail_bytes) - 1u)) ? (t.dp[0] & odd_nail_mask) : (t.dp[0] & 0xFFuL));
if ((err = mp_div_2d(&t, (j == ((size - nail_bytes) - 1u)) ? (int)(8u - odd_nails) : 8, &t, NULL)) != MP_OKAY) {
goto LBL_ERR;
}
}
}
if (written != NULL) {
*written = count;
}
err = MP_OKAY;
LBL_ERR:
mp_clear(&t);
return err;
}
#endif
|
Added libtommath/bn_mp_pack_count.c.
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 |
#include "tommath_private.h"
#ifdef BN_MP_PACK_COUNT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
size_t mp_pack_count(const mp_int *a, size_t nails, size_t size)
{
size_t bits = (size_t)mp_count_bits(a);
return ((bits / ((size * 8u) - nails)) + (((bits % ((size * 8u) - nails)) != 0u) ? 1u : 0u));
}
#endif
|
Changes to libtommath/bn_mp_prime_fermat.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_PRIME_FERMAT_C | | < < < < < < < < | < | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
#include "tommath_private.h"
#ifdef BN_MP_PRIME_FERMAT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* performs one Fermat test.
*
* If "a" were prime then b**a == b (mod a) since the order of
* the multiplicative sub-group would be phi(a) = a-1. That means
* it would be the same as b**(a mod (a-1)) == b**1 == b (mod a).
*
* Sets result to 1 if the congruence holds, or zero otherwise.
*/
mp_err mp_prime_fermat(const mp_int *a, const mp_int *b, mp_bool *result)
{
mp_int t;
mp_err err;
/* default to composite */
*result = MP_NO;
/* ensure b > 1 */
if (mp_cmp_d(b, 1uL) != MP_GT) {
return MP_VAL;
|
| ︙ | ︙ | |||
50 51 52 53 54 55 56 | err = MP_OKAY; LBL_T: mp_clear(&t); return err; } #endif | < < < < | 41 42 43 44 45 46 47 | err = MP_OKAY; LBL_T: mp_clear(&t); return err; } #endif |
Changes to libtommath/bn_mp_prime_frobenius_underwood.c.
1 2 3 | #include "tommath_private.h" #ifdef BN_MP_PRIME_FROBENIUS_UNDERWOOD_C | | < < < < < < < < | < | | | | | | | < | < | < | < | < | < | < < | | < | < | < | < | < | < | < < | < | < | < < | < | | < | < < | < < | < < | < < | < < | < < | < < < < | < < | < | < | < < | < < | < < | < < | < < | < | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 |
#include "tommath_private.h"
#ifdef BN_MP_PRIME_FROBENIUS_UNDERWOOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/*
* See file bn_mp_prime_is_prime.c or the documentation in doc/bn.tex for the details
*/
#ifndef LTM_USE_ONLY_MR
#ifdef MP_8BIT
/*
* floor of positive solution of
* (2^16)-1 = (a+4)*(2*a+5)
* TODO: Both values are smaller than N^(1/4), would have to use a bigint
* for a instead but any a biger than about 120 are already so rare that
* it is possible to ignore them and still get enough pseudoprimes.
* But it is still a restriction of the set of available pseudoprimes
* which makes this implementation less secure if used stand-alone.
*/
#define LTM_FROBENIUS_UNDERWOOD_A 177
#else
#define LTM_FROBENIUS_UNDERWOOD_A 32764
#endif
mp_err mp_prime_frobenius_underwood(const mp_int *N, mp_bool *result)
{
mp_int T1z, T2z, Np1z, sz, tz;
int a, ap2, length, i, j;
mp_err err;
*result = MP_NO;
if ((err = mp_init_multi(&T1z, &T2z, &Np1z, &sz, &tz, NULL)) != MP_OKAY) {
return err;
}
for (a = 0; a < LTM_FROBENIUS_UNDERWOOD_A; a++) {
/* TODO: That's ugly! No, really, it is! */
if ((a==2) || (a==4) || (a==7) || (a==8) || (a==10) ||
(a==14) || (a==18) || (a==23) || (a==26) || (a==28)) {
continue;
}
/* (32764^2 - 4) < 2^31, no bigint for >MP_8BIT needed) */
mp_set_u32(&T1z, (uint32_t)a);
if ((err = mp_sqr(&T1z, &T1z)) != MP_OKAY) goto LBL_FU_ERR;
if ((err = mp_sub_d(&T1z, 4uL, &T1z)) != MP_OKAY) goto LBL_FU_ERR;
if ((err = mp_kronecker(&T1z, N, &j)) != MP_OKAY) goto LBL_FU_ERR;
if (j == -1) {
break;
}
if (j == 0) {
/* composite */
goto LBL_FU_ERR;
}
}
/* Tell it a composite and set return value accordingly */
if (a >= LTM_FROBENIUS_UNDERWOOD_A) {
err = MP_ITER;
goto LBL_FU_ERR;
}
/* Composite if N and (a+4)*(2*a+5) are not coprime */
mp_set_u32(&T1z, (uint32_t)((a+4)*((2*a)+5)));
if ((err = mp_gcd(N, &T1z, &T1z)) != MP_OKAY) goto LBL_FU_ERR;
if (!((T1z.used == 1) && (T1z.dp[0] == 1u))) goto LBL_FU_ERR;
ap2 = a + 2;
if ((err = mp_add_d(N, 1uL, &Np1z)) != MP_OKAY) goto LBL_FU_ERR;
mp_set(&sz, 1uL);
mp_set(&tz, 2uL);
length = mp_count_bits(&Np1z);
for (i = length - 2; i >= 0; i--) {
/*
* temp = (sz*(a*sz+2*tz))%N;
* tz = ((tz-sz)*(tz+sz))%N;
* sz = temp;
*/
if ((err = mp_mul_2(&tz, &T2z)) != MP_OKAY) goto LBL_FU_ERR;
/* a = 0 at about 50% of the cases (non-square and odd input) */
if (a != 0) {
if ((err = mp_mul_d(&sz, (mp_digit)a, &T1z)) != MP_OKAY) goto LBL_FU_ERR;
if ((err = mp_add(&T1z, &T2z, &T2z)) != MP_OKAY) goto LBL_FU_ERR;
}
if ((err = mp_mul(&T2z, &sz, &T1z)) != MP_OKAY) goto LBL_FU_ERR;
if ((err = mp_sub(&tz, &sz, &T2z)) != MP_OKAY) goto LBL_FU_ERR;
if ((err = mp_add(&sz, &tz, &sz)) != MP_OKAY) goto LBL_FU_ERR;
if ((err = mp_mul(&sz, &T2z, &tz)) != MP_OKAY) goto LBL_FU_ERR;
if ((err = mp_mod(&tz, N, &tz)) != MP_OKAY) goto LBL_FU_ERR;
if ((err = mp_mod(&T1z, N, &sz)) != MP_OKAY) goto LBL_FU_ERR;
if (s_mp_get_bit(&Np1z, (unsigned int)i) == MP_YES) {
/*
* temp = (a+2) * sz + tz
* tz = 2 * tz - sz
* sz = temp
*/
if (a == 0) {
if ((err = mp_mul_2(&sz, &T1z)) != MP_OKAY) goto LBL_FU_ERR;
} else {
if ((err = mp_mul_d(&sz, (mp_digit)ap2, &T1z)) != MP_OKAY) goto LBL_FU_ERR;
}
if ((err = mp_add(&T1z, &tz, &T1z)) != MP_OKAY) goto LBL_FU_ERR;
if ((err = mp_mul_2(&tz, &T2z)) != MP_OKAY) goto LBL_FU_ERR;
if ((err = mp_sub(&T2z, &sz, &tz)) != MP_OKAY) goto LBL_FU_ERR;
mp_exch(&sz, &T1z);
}
}
mp_set_u32(&T1z, (uint32_t)((2 * a) + 5));
if ((err = mp_mod(&T1z, N, &T1z)) != MP_OKAY) goto LBL_FU_ERR;
if (MP_IS_ZERO(&sz) && (mp_cmp(&tz, &T1z) == MP_EQ)) {
*result = MP_YES;
}
LBL_FU_ERR:
mp_clear_multi(&tz, &sz, &Np1z, &T2z, &T1z, NULL);
return err;
}
#endif
#endif
|
Deleted libtommath/bn_mp_prime_is_divisible.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to libtommath/bn_mp_prime_is_prime.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_PRIME_IS_PRIME_C | | < < < < < < < < | < | | > > < < < < < | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 |
#include "tommath_private.h"
#ifdef BN_MP_PRIME_IS_PRIME_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* portable integer log of two with small footprint */
static unsigned int s_floor_ilog2(int value)
{
unsigned int r = 0;
while ((value >>= 1) != 0) {
r++;
}
return r;
}
mp_err mp_prime_is_prime(const mp_int *a, int t, mp_bool *result)
{
mp_int b;
int ix, p_max = 0, size_a, len;
mp_bool res;
mp_err err;
unsigned int fips_rand, mask;
/* default to no */
*result = MP_NO;
/* Some shortcuts */
/* N > 3 */
if (a->used == 1) {
if ((a->dp[0] == 0u) || (a->dp[0] == 1u)) {
*result = MP_NO;
return MP_OKAY;
}
if (a->dp[0] == 2u) {
*result = MP_YES;
return MP_OKAY;
}
}
/* N must be odd */
if (MP_IS_EVEN(a)) {
return MP_OKAY;
}
/* N is not a perfect square: floor(sqrt(N))^2 != N */
if ((err = mp_is_square(a, &res)) != MP_OKAY) {
return err;
}
if (res != MP_NO) {
return MP_OKAY;
}
/* is the input equal to one of the primes in the table? */
for (ix = 0; ix < PRIVATE_MP_PRIME_TAB_SIZE; ix++) {
if (mp_cmp_d(a, s_mp_prime_tab[ix]) == MP_EQ) {
*result = MP_YES;
return MP_OKAY;
}
}
#ifdef MP_8BIT
/* The search in the loop above was exhaustive in this case */
if ((a->used == 1) && (PRIVATE_MP_PRIME_TAB_SIZE >= 31)) {
return MP_OKAY;
}
#endif
/* first perform trial division */
if ((err = s_mp_prime_is_divisible(a, &res)) != MP_OKAY) {
return err;
}
/* return if it was trivially divisible */
if (res == MP_YES) {
return MP_OKAY;
}
|
| ︙ | ︙ | |||
110 111 112 113 114 115 116 |
}
if (res == MP_NO) {
goto LBL_B;
}
/*
* Both, the Frobenius-Underwood test and the the Lucas-Selfridge test are quite
| | | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 |
}
if (res == MP_NO) {
goto LBL_B;
}
/*
* Both, the Frobenius-Underwood test and the the Lucas-Selfridge test are quite
* slow so if speed is an issue, define LTM_USE_ONLY_MR to use M-R tests with
* bases 2, 3 and t random bases.
*/
#ifndef LTM_USE_ONLY_MR
if (t >= 0) {
/*
* Use a Frobenius-Underwood test instead of the Lucas-Selfridge test for
* MP_8BIT (It is unknown if the Lucas-Selfridge test works with 16-bit
* integers but the necesssary analysis is on the todo-list).
*/
#if defined (MP_8BIT) || defined (LTM_USE_FROBENIUS_TEST)
|
| ︙ | ︙ | |||
145 146 147 148 149 150 151 |
/* run at least one Miller-Rabin test with a random base */
if (t == 0) {
t = 1;
}
/*
| < | > | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 |
/* run at least one Miller-Rabin test with a random base */
if (t == 0) {
t = 1;
}
/*
Only recommended if the input range is known to be < 3317044064679887385961981
It uses the bases necessary for a deterministic M-R test if the input is
smaller than 3317044064679887385961981
The caller has to check the size.
TODO: can be made a bit finer grained but comparing is not free.
*/
if (t < 0) {
/*
Sorenson, Jonathan; Webster, Jonathan (2015).
"Strong Pseudoprimes to Twelve Prime Bases".
*/
/* 0x437ae92817f9fc85b7e5 = 318665857834031151167461 */
if ((err = mp_read_radix(&b, "437ae92817f9fc85b7e5", 16)) != MP_OKAY) {
goto LBL_B;
|
| ︙ | ︙ | |||
208 209 210 211 212 213 214 |
p_max = 13;
} else {
err = MP_VAL;
goto LBL_B;
}
}
| < < < < < < < < < | | 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 |
p_max = 13;
} else {
err = MP_VAL;
goto LBL_B;
}
}
/* we did bases 2 and 3 already, skip them */
for (ix = 2; ix < p_max; ix++) {
mp_set(&b, s_mp_prime_tab[ix]);
if ((err = mp_prime_miller_rabin(a, &b, &res)) != MP_OKAY) {
goto LBL_B;
}
if (res == MP_NO) {
goto LBL_B;
}
}
|
| ︙ | ︙ | |||
292 293 294 295 296 297 298 |
*/
fips_rand = (unsigned int)(b.dp[0] & (mp_digit) mask);
#ifdef MP_8BIT
/*
* One 8-bit digit is too small, so concatenate two if the size of
* unsigned int allows for it.
*/
| | | | | | | 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 |
*/
fips_rand = (unsigned int)(b.dp[0] & (mp_digit) mask);
#ifdef MP_8BIT
/*
* One 8-bit digit is too small, so concatenate two if the size of
* unsigned int allows for it.
*/
if ((MP_SIZEOF_BITS(unsigned int)/2) >= MP_SIZEOF_BITS(mp_digit)) {
if ((err = mp_rand(&b, 1)) != MP_OKAY) {
goto LBL_B;
}
fips_rand <<= MP_SIZEOF_BITS(mp_digit);
fips_rand |= (unsigned int) b.dp[0];
fips_rand &= mask;
}
#endif
if (fips_rand > (unsigned int)(INT_MAX - MP_DIGIT_BIT)) {
len = INT_MAX / MP_DIGIT_BIT;
} else {
len = (((int)fips_rand + MP_DIGIT_BIT) / MP_DIGIT_BIT);
}
/* Unlikely. */
if (len < 0) {
ix--;
continue;
}
/*
|
| ︙ | ︙ | |||
328 329 330 331 332 333 334 |
}
#endif
if ((err = mp_rand(&b, len)) != MP_OKAY) {
goto LBL_B;
}
/*
* That number might got too big and the witness has to be
| | | | < | 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 |
}
#endif
if ((err = mp_rand(&b, len)) != MP_OKAY) {
goto LBL_B;
}
/*
* That number might got too big and the witness has to be
* smaller than "a"
*/
len = mp_count_bits(&b);
if (len >= size_a) {
len = (len - size_a) + 1;
if ((err = mp_div_2d(&b, len, &b, NULL)) != MP_OKAY) {
goto LBL_B;
}
}
/* Although the chance for b <= 3 is miniscule, try again. */
if (mp_cmp_d(&b, 3uL) != MP_GT) {
ix--;
continue;
}
if ((err = mp_prime_miller_rabin(a, &b, &res)) != MP_OKAY) {
goto LBL_B;
|
| ︙ | ︙ | |||
360 361 362 363 364 365 366 | *result = MP_YES; LBL_B: mp_clear(&b); return err; } #endif | < < < < | 308 309 310 311 312 313 314 | *result = MP_YES; LBL_B: mp_clear(&b); return err; } #endif |
Changes to libtommath/bn_mp_prime_miller_rabin.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_PRIME_MILLER_RABIN_C | | < < < < < < < < | < | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
#include "tommath_private.h"
#ifdef BN_MP_PRIME_MILLER_RABIN_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* Miller-Rabin test of "a" to the base of "b" as described in
* HAC pp. 139 Algorithm 4.24
*
* Sets result to 0 if definitely composite or 1 if probably prime.
* Randomly the chance of error is no more than 1/4 and often
* very much lower.
*/
mp_err mp_prime_miller_rabin(const mp_int *a, const mp_int *b, mp_bool *result)
{
mp_int n1, y, r;
mp_err err;
int s, j;
/* default */
*result = MP_NO;
/* ensure b > 1 */
if (mp_cmp_d(b, 1uL) != MP_GT) {
return MP_VAL;
|
| ︙ | ︙ | |||
93 94 95 96 97 98 99 | LBL_R: mp_clear(&r); LBL_N1: mp_clear(&n1); return err; } #endif | < < < < | 85 86 87 88 89 90 91 | LBL_R: mp_clear(&r); LBL_N1: mp_clear(&n1); return err; } #endif |
Changes to libtommath/bn_mp_prime_next_prime.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_PRIME_NEXT_PRIME_C | | < < < < < < < < | < | | > > > | | | | | | < < < < | < < < < < < < | < < > > > > | < < < < < < | > | | | | | | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 |
#include "tommath_private.h"
#ifdef BN_MP_PRIME_NEXT_PRIME_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* finds the next prime after the number "a" using "t" trials
* of Miller-Rabin.
*
* bbs_style = 1 means the prime must be congruent to 3 mod 4
*/
mp_err mp_prime_next_prime(mp_int *a, int t, int bbs_style)
{
int x, y;
mp_ord cmp;
mp_err err;
mp_bool res = MP_NO;
mp_digit res_tab[PRIVATE_MP_PRIME_TAB_SIZE], step, kstep;
mp_int b;
/* force positive */
a->sign = MP_ZPOS;
/* simple algo if a is less than the largest prime in the table */
if (mp_cmp_d(a, s_mp_prime_tab[PRIVATE_MP_PRIME_TAB_SIZE-1]) == MP_LT) {
/* find which prime it is bigger than "a" */
for (x = 0; x < PRIVATE_MP_PRIME_TAB_SIZE; x++) {
cmp = mp_cmp_d(a, s_mp_prime_tab[x]);
if (cmp == MP_EQ) {
continue;
}
if (cmp != MP_GT) {
if ((bbs_style == 1) && ((s_mp_prime_tab[x] & 3u) != 3u)) {
/* try again until we get a prime congruent to 3 mod 4 */
continue;
} else {
mp_set(a, s_mp_prime_tab[x]);
return MP_OKAY;
}
}
}
/* fall through to the sieve */
}
/* generate a prime congruent to 3 mod 4 or 1/3 mod 4? */
if (bbs_style == 1) {
kstep = 4;
} else {
kstep = 2;
}
/* at this point we will use a combination of a sieve and Miller-Rabin */
if (bbs_style == 1) {
/* if a mod 4 != 3 subtract the correct value to make it so */
if ((a->dp[0] & 3u) != 3u) {
if ((err = mp_sub_d(a, (a->dp[0] & 3u) + 1u, a)) != MP_OKAY) {
return err;
}
}
} else {
if (MP_IS_EVEN(a)) {
/* force odd */
if ((err = mp_sub_d(a, 1uL, a)) != MP_OKAY) {
return err;
}
}
}
/* generate the restable */
for (x = 1; x < PRIVATE_MP_PRIME_TAB_SIZE; x++) {
if ((err = mp_mod_d(a, s_mp_prime_tab[x], res_tab + x)) != MP_OKAY) {
return err;
}
}
/* init temp used for Miller-Rabin Testing */
if ((err = mp_init(&b)) != MP_OKAY) {
return err;
}
for (;;) {
/* skip to the next non-trivially divisible candidate */
step = 0;
do {
/* y == 1 if any residue was zero [e.g. cannot be prime] */
y = 0;
/* increase step to next candidate */
step += kstep;
/* compute the new residue without using division */
for (x = 1; x < PRIVATE_MP_PRIME_TAB_SIZE; x++) {
/* add the step to each residue */
res_tab[x] += kstep;
/* subtract the modulus [instead of using division] */
if (res_tab[x] >= s_mp_prime_tab[x]) {
res_tab[x] -= s_mp_prime_tab[x];
}
/* set flag if zero */
if (res_tab[x] == 0u) {
y = 1;
}
}
} while ((y == 1) && (step < (((mp_digit)1 << MP_DIGIT_BIT) - kstep)));
/* add the step */
if ((err = mp_add_d(a, step, a)) != MP_OKAY) {
goto LBL_ERR;
}
/* if didn't pass sieve and step == MP_MAX then skip test */
if ((y == 1) && (step >= (((mp_digit)1 << MP_DIGIT_BIT) - kstep))) {
continue;
}
if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) {
goto LBL_ERR;
}
if (res == MP_YES) {
break;
}
}
err = MP_OKAY;
LBL_ERR:
mp_clear(&b);
return err;
}
#endif
|
Changes to libtommath/bn_mp_prime_rabin_miller_trials.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_PRIME_RABIN_MILLER_TRIALS_C | | < < < < < < < < | < < | | | | | < | | | < | | | > | > | > > > > > | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
#include "tommath_private.h"
#ifdef BN_MP_PRIME_RABIN_MILLER_TRIALS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
static const struct {
int k, t;
} sizes[] = {
{ 80, -1 }, /* Use deterministic algorithm for size <= 80 bits */
{ 81, 37 }, /* max. error = 2^(-96)*/
{ 96, 32 }, /* max. error = 2^(-96)*/
{ 128, 40 }, /* max. error = 2^(-112)*/
{ 160, 35 }, /* max. error = 2^(-112)*/
{ 256, 27 }, /* max. error = 2^(-128)*/
{ 384, 16 }, /* max. error = 2^(-128)*/
{ 512, 18 }, /* max. error = 2^(-160)*/
{ 768, 11 }, /* max. error = 2^(-160)*/
{ 896, 10 }, /* max. error = 2^(-160)*/
{ 1024, 12 }, /* max. error = 2^(-192)*/
{ 1536, 8 }, /* max. error = 2^(-192)*/
{ 2048, 6 }, /* max. error = 2^(-192)*/
{ 3072, 4 }, /* max. error = 2^(-192)*/
{ 4096, 5 }, /* max. error = 2^(-256)*/
{ 5120, 4 }, /* max. error = 2^(-256)*/
{ 6144, 4 }, /* max. error = 2^(-256)*/
{ 8192, 3 }, /* max. error = 2^(-256)*/
{ 9216, 3 }, /* max. error = 2^(-256)*/
{ 10240, 2 } /* For bigger keysizes use always at least 2 Rounds */
};
/* returns # of RM trials required for a given bit size */
int mp_prime_rabin_miller_trials(int size)
{
int x;
for (x = 0; x < (int)(sizeof(sizes)/(sizeof(sizes[0]))); x++) {
if (sizes[x].k == size) {
return sizes[x].t;
} else if (sizes[x].k > size) {
return (x == 0) ? sizes[0].t : sizes[x - 1].t;
}
}
return sizes[x-1].t;
}
#endif
|
Added libtommath/bn_mp_prime_rand.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 |
#include "tommath_private.h"
#ifdef BN_MP_PRIME_RAND_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* makes a truly random prime of a given size (bits),
*
* Flags are as follows:
*
* MP_PRIME_BBS - make prime congruent to 3 mod 4
* MP_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies MP_PRIME_BBS)
* MP_PRIME_2MSB_ON - make the 2nd highest bit one
*
* You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can
* have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself
* so it can be NULL
*
*/
/* This is possibly the mother of all prime generation functions, muahahahahaha! */
mp_err s_mp_prime_random_ex(mp_int *a, int t, int size, int flags, private_mp_prime_callback cb, void *dat)
{
unsigned char *tmp, maskAND, maskOR_msb, maskOR_lsb;
int bsize, maskOR_msb_offset;
mp_bool res;
mp_err err;
/* sanity check the input */
if ((size <= 1) || (t <= 0)) {
return MP_VAL;
}
/* MP_PRIME_SAFE implies MP_PRIME_BBS */
if ((flags & MP_PRIME_SAFE) != 0) {
flags |= MP_PRIME_BBS;
}
/* calc the byte size */
bsize = (size>>3) + ((size&7)?1:0);
/* we need a buffer of bsize bytes */
tmp = (unsigned char *) MP_MALLOC((size_t)bsize);
if (tmp == NULL) {
return MP_MEM;
}
/* calc the maskAND value for the MSbyte*/
maskAND = ((size&7) == 0) ? 0xFFu : (unsigned char)(0xFFu >> (8 - (size & 7)));
/* calc the maskOR_msb */
maskOR_msb = 0;
maskOR_msb_offset = ((size & 7) == 1) ? 1 : 0;
if ((flags & MP_PRIME_2MSB_ON) != 0) {
maskOR_msb |= (unsigned char)(0x80 >> ((9 - size) & 7));
}
/* get the maskOR_lsb */
maskOR_lsb = 1u;
if ((flags & MP_PRIME_BBS) != 0) {
maskOR_lsb |= 3u;
}
do {
/* read the bytes */
if (cb(tmp, bsize, dat) != bsize) {
err = MP_VAL;
goto error;
}
/* work over the MSbyte */
tmp[0] &= maskAND;
tmp[0] |= (unsigned char)(1 << ((size - 1) & 7));
/* mix in the maskORs */
tmp[maskOR_msb_offset] |= maskOR_msb;
tmp[bsize-1] |= maskOR_lsb;
/* read it in */
/* TODO: casting only for now until all lengths have been changed to the type "size_t"*/
if ((err = mp_from_ubin(a, tmp, (size_t)bsize)) != MP_OKAY) {
goto error;
}
/* is it prime? */
if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) {
goto error;
}
if (res == MP_NO) {
continue;
}
if ((flags & MP_PRIME_SAFE) != 0) {
/* see if (a-1)/2 is prime */
if ((err = mp_sub_d(a, 1uL, a)) != MP_OKAY) {
goto error;
}
if ((err = mp_div_2(a, a)) != MP_OKAY) {
goto error;
}
/* is it prime? */
if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) {
goto error;
}
}
} while (res == MP_NO);
if ((flags & MP_PRIME_SAFE) != 0) {
/* restore a to the original value */
if ((err = mp_mul_2(a, a)) != MP_OKAY) {
goto error;
}
if ((err = mp_add_d(a, 1uL, a)) != MP_OKAY) {
goto error;
}
}
err = MP_OKAY;
error:
MP_FREE_BUFFER(tmp, (size_t)bsize);
return err;
}
static int s_mp_rand_cb(unsigned char *dst, int len, void *dat)
{
(void)dat;
if (len <= 0) {
return len;
}
if (s_mp_rand_source(dst, (size_t)len) != MP_OKAY) {
return 0;
}
return len;
}
mp_err mp_prime_rand(mp_int *a, int t, int size, int flags)
{
return s_mp_prime_random_ex(a, t, size, flags, s_mp_rand_cb, NULL);
}
#endif
|
Deleted libtommath/bn_mp_prime_random_ex.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to libtommath/bn_mp_prime_strong_lucas_selfridge.c.
1 2 3 | #include "tommath_private.h" #ifdef BN_MP_PRIME_STRONG_LUCAS_SELFRIDGE_C | | < < < < < < < < | < | | | < < < < | < < | < < < < < < | | | | | | | < < | < | | < < | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 |
#include "tommath_private.h"
#ifdef BN_MP_PRIME_STRONG_LUCAS_SELFRIDGE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/*
* See file bn_mp_prime_is_prime.c or the documentation in doc/bn.tex for the details
*/
#ifndef LTM_USE_ONLY_MR
/*
* 8-bit is just too small. You can try the Frobenius test
* but that frobenius test can fail, too, for the same reason.
*/
#ifndef MP_8BIT
/*
* multiply bigint a with int d and put the result in c
* Like mp_mul_d() but with a signed long as the small input
*/
static mp_err s_mp_mul_si(const mp_int *a, int32_t d, mp_int *c)
{
mp_int t;
mp_err err;
if ((err = mp_init(&t)) != MP_OKAY) {
return err;
}
/*
* mp_digit might be smaller than a long, which excludes
* the use of mp_mul_d() here.
*/
mp_set_i32(&t, d);
err = mp_mul(a, &t, c);
mp_clear(&t);
return err;
}
/*
Strong Lucas-Selfridge test.
returns MP_YES if it is a strong L-S prime, MP_NO if it is composite
Code ported from Thomas Ray Nicely's implementation of the BPSW test
at http://www.trnicely.net/misc/bpsw.html
Freeware copyright (C) 2016 Thomas R. Nicely <http://www.trnicely.net>.
Released into the public domain by the author, who disclaims any legal
liability arising from its use
The multi-line comments are made by Thomas R. Nicely and are copied verbatim.
Additional comments marked "CZ" (without the quotes) are by the code-portist.
(If that name sounds familiar, he is the guy who found the fdiv bug in the
Pentium (P5x, I think) Intel processor)
*/
mp_err mp_prime_strong_lucas_selfridge(const mp_int *a, mp_bool *result)
{
/* CZ TODO: choose better variable names! */
mp_int Dz, gcd, Np1, Uz, Vz, U2mz, V2mz, Qmz, Q2mz, Qkdz, T1z, T2z, T3z, T4z, Q2kdz;
/* CZ TODO: Some of them need the full 32 bit, hence the (temporary) exclusion of MP_8BIT */
int32_t D, Ds, J, sign, P, Q, r, s, u, Nbits;
mp_err err;
mp_bool oddness;
*result = MP_NO;
/*
Find the first element D in the sequence {5, -7, 9, -11, 13, ...}
such that Jacobi(D,N) = -1 (Selfridge's algorithm). Theory
indicates that, if N is not a perfect square, D will "nearly
always" be "small." Just in case, an overflow trap for D is
included.
*/
if ((err = mp_init_multi(&Dz, &gcd, &Np1, &Uz, &Vz, &U2mz, &V2mz, &Qmz, &Q2mz, &Qkdz, &T1z, &T2z, &T3z, &T4z, &Q2kdz,
NULL)) != MP_OKAY) {
return err;
}
D = 5;
sign = 1;
for (;;) {
Ds = sign * D;
sign = -sign;
mp_set_u32(&Dz, (uint32_t)D);
if ((err = mp_gcd(a, &Dz, &gcd)) != MP_OKAY) goto LBL_LS_ERR;
/* if 1 < GCD < N then N is composite with factor "D", and
Jacobi(D,N) is technically undefined (but often returned
as zero). */
if ((mp_cmp_d(&gcd, 1uL) == MP_GT) && (mp_cmp(&gcd, a) == MP_LT)) {
goto LBL_LS_ERR;
}
if (Ds < 0) {
Dz.sign = MP_NEG;
}
if ((err = mp_kronecker(&Dz, a, &J)) != MP_OKAY) goto LBL_LS_ERR;
if (J == -1) {
break;
}
D += 2;
if (D > (INT_MAX - 2)) {
err = MP_VAL;
goto LBL_LS_ERR;
}
}
P = 1; /* Selfridge's choice */
|
| ︙ | ︙ | |||
165 166 167 168 169 170 171 |
only (roughly) 30 % as many pseudoprimes (and every strong
Lucas pseudoprime is also a standard Lucas pseudoprime). Thus
the evidence indicates that the strong Lucas-Selfridge test is
more effective than the standard Lucas-Selfridge test, and a
Baillie-PSW test based on the strong Lucas-Selfridge test
should be more reliable. */
| | < < | < < < < < < < | < < < < < < < < < < < < < < | < < | | < < < | < < | < < | < < | < < | < | | < | | < < | < | | < < < < | < < | < < | < < | | < < < < | < < | | < < | | < < | < | < | < < | | < | < | | < < | < | < | < < | < | | < < | < | | | < | | < | < | < < | < < | < < | | < < | < < | < < | < < < < | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 |
only (roughly) 30 % as many pseudoprimes (and every strong
Lucas pseudoprime is also a standard Lucas pseudoprime). Thus
the evidence indicates that the strong Lucas-Selfridge test is
more effective than the standard Lucas-Selfridge test, and a
Baillie-PSW test based on the strong Lucas-Selfridge test
should be more reliable. */
if ((err = mp_add_d(a, 1uL, &Np1)) != MP_OKAY) goto LBL_LS_ERR;
s = mp_cnt_lsb(&Np1);
/* CZ
* This should round towards zero because
* Thomas R. Nicely used GMP's mpz_tdiv_q_2exp()
* and mp_div_2d() is equivalent. Additionally:
* dividing an even number by two does not produce
* any leftovers.
*/
if ((err = mp_div_2d(&Np1, s, &Dz, NULL)) != MP_OKAY) goto LBL_LS_ERR;
/* We must now compute U_d and V_d. Since d is odd, the accumulated
values U and V are initialized to U_1 and V_1 (if the target
index were even, U and V would be initialized instead to U_0=0
and V_0=2). The values of U_2m and V_2m are also initialized to
U_1 and V_1; the FOR loop calculates in succession U_2 and V_2,
U_4 and V_4, U_8 and V_8, etc. If the corresponding bits
(1, 2, 3, ...) of t are on (the zero bit having been accounted
for in the initialization of U and V), these values are then
combined with the previous totals for U and V, using the
composition formulas for addition of indices. */
mp_set(&Uz, 1uL); /* U=U_1 */
mp_set(&Vz, (mp_digit)P); /* V=V_1 */
mp_set(&U2mz, 1uL); /* U_1 */
mp_set(&V2mz, (mp_digit)P); /* V_1 */
mp_set_i32(&Qmz, Q);
if ((err = mp_mul_2(&Qmz, &Q2mz)) != MP_OKAY) goto LBL_LS_ERR;
/* Initializes calculation of Q^d */
mp_set_i32(&Qkdz, Q);
Nbits = mp_count_bits(&Dz);
for (u = 1; u < Nbits; u++) { /* zero bit off, already accounted for */
/* Formulas for doubling of indices (carried out mod N). Note that
* the indices denoted as "2m" are actually powers of 2, specifically
* 2^(ul-1) beginning each loop and 2^ul ending each loop.
*
* U_2m = U_m*V_m
* V_2m = V_m*V_m - 2*Q^m
*/
if ((err = mp_mul(&U2mz, &V2mz, &U2mz)) != MP_OKAY) goto LBL_LS_ERR;
if ((err = mp_mod(&U2mz, a, &U2mz)) != MP_OKAY) goto LBL_LS_ERR;
if ((err = mp_sqr(&V2mz, &V2mz)) != MP_OKAY) goto LBL_LS_ERR;
if ((err = mp_sub(&V2mz, &Q2mz, &V2mz)) != MP_OKAY) goto LBL_LS_ERR;
if ((err = mp_mod(&V2mz, a, &V2mz)) != MP_OKAY) goto LBL_LS_ERR;
/* Must calculate powers of Q for use in V_2m, also for Q^d later */
if ((err = mp_sqr(&Qmz, &Qmz)) != MP_OKAY) goto LBL_LS_ERR;
/* prevents overflow */ /* CZ still necessary without a fixed prealloc'd mem.? */
if ((err = mp_mod(&Qmz, a, &Qmz)) != MP_OKAY) goto LBL_LS_ERR;
if ((err = mp_mul_2(&Qmz, &Q2mz)) != MP_OKAY) goto LBL_LS_ERR;
if (s_mp_get_bit(&Dz, (unsigned int)u) == MP_YES) {
/* Formulas for addition of indices (carried out mod N);
*
* U_(m+n) = (U_m*V_n + U_n*V_m)/2
* V_(m+n) = (V_m*V_n + D*U_m*U_n)/2
*
* Be careful with division by 2 (mod N)!
*/
if ((err = mp_mul(&U2mz, &Vz, &T1z)) != MP_OKAY) goto LBL_LS_ERR;
if ((err = mp_mul(&Uz, &V2mz, &T2z)) != MP_OKAY) goto LBL_LS_ERR;
if ((err = mp_mul(&V2mz, &Vz, &T3z)) != MP_OKAY) goto LBL_LS_ERR;
if ((err = mp_mul(&U2mz, &Uz, &T4z)) != MP_OKAY) goto LBL_LS_ERR;
if ((err = s_mp_mul_si(&T4z, Ds, &T4z)) != MP_OKAY) goto LBL_LS_ERR;
if ((err = mp_add(&T1z, &T2z, &Uz)) != MP_OKAY) goto LBL_LS_ERR;
if (MP_IS_ODD(&Uz)) {
if ((err = mp_add(&Uz, a, &Uz)) != MP_OKAY) goto LBL_LS_ERR;
}
/* CZ
* This should round towards negative infinity because
* Thomas R. Nicely used GMP's mpz_fdiv_q_2exp().
* But mp_div_2() does not do so, it is truncating instead.
*/
oddness = MP_IS_ODD(&Uz) ? MP_YES : MP_NO;
if ((err = mp_div_2(&Uz, &Uz)) != MP_OKAY) goto LBL_LS_ERR;
if ((Uz.sign == MP_NEG) && (oddness != MP_NO)) {
if ((err = mp_sub_d(&Uz, 1uL, &Uz)) != MP_OKAY) goto LBL_LS_ERR;
}
if ((err = mp_add(&T3z, &T4z, &Vz)) != MP_OKAY) goto LBL_LS_ERR;
if (MP_IS_ODD(&Vz)) {
if ((err = mp_add(&Vz, a, &Vz)) != MP_OKAY) goto LBL_LS_ERR;
}
oddness = MP_IS_ODD(&Vz) ? MP_YES : MP_NO;
if ((err = mp_div_2(&Vz, &Vz)) != MP_OKAY) goto LBL_LS_ERR;
if ((Vz.sign == MP_NEG) && (oddness != MP_NO)) {
if ((err = mp_sub_d(&Vz, 1uL, &Vz)) != MP_OKAY) goto LBL_LS_ERR;
}
if ((err = mp_mod(&Uz, a, &Uz)) != MP_OKAY) goto LBL_LS_ERR;
if ((err = mp_mod(&Vz, a, &Vz)) != MP_OKAY) goto LBL_LS_ERR;
/* Calculating Q^d for later use */
if ((err = mp_mul(&Qkdz, &Qmz, &Qkdz)) != MP_OKAY) goto LBL_LS_ERR;
if ((err = mp_mod(&Qkdz, a, &Qkdz)) != MP_OKAY) goto LBL_LS_ERR;
}
}
/* If U_d or V_d is congruent to 0 mod N, then N is a prime or a
strong Lucas pseudoprime. */
if (MP_IS_ZERO(&Uz) || MP_IS_ZERO(&Vz)) {
*result = MP_YES;
goto LBL_LS_ERR;
}
/* NOTE: Ribenboim ("The new book of prime number records," 3rd ed.,
1995/6) omits the condition V0 on p.142, but includes it on
p. 130. The condition is NECESSARY; otherwise the test will
return false negatives---e.g., the primes 29 and 2000029 will be
returned as composite. */
/* Otherwise, we must compute V_2d, V_4d, V_8d, ..., V_{2^(s-1)*d}
by repeated use of the formula V_2m = V_m*V_m - 2*Q^m. If any of
these are congruent to 0 mod N, then N is a prime or a strong
Lucas pseudoprime. */
/* Initialize 2*Q^(d*2^r) for V_2m */
if ((err = mp_mul_2(&Qkdz, &Q2kdz)) != MP_OKAY) goto LBL_LS_ERR;
for (r = 1; r < s; r++) {
if ((err = mp_sqr(&Vz, &Vz)) != MP_OKAY) goto LBL_LS_ERR;
if ((err = mp_sub(&Vz, &Q2kdz, &Vz)) != MP_OKAY) goto LBL_LS_ERR;
if ((err = mp_mod(&Vz, a, &Vz)) != MP_OKAY) goto LBL_LS_ERR;
if (MP_IS_ZERO(&Vz)) {
*result = MP_YES;
goto LBL_LS_ERR;
}
/* Calculate Q^{d*2^r} for next r (final iteration irrelevant). */
if (r < (s - 1)) {
if ((err = mp_sqr(&Qkdz, &Qkdz)) != MP_OKAY) goto LBL_LS_ERR;
if ((err = mp_mod(&Qkdz, a, &Qkdz)) != MP_OKAY) goto LBL_LS_ERR;
if ((err = mp_mul_2(&Qkdz, &Q2kdz)) != MP_OKAY) goto LBL_LS_ERR;
}
}
LBL_LS_ERR:
mp_clear_multi(&Q2kdz, &T4z, &T3z, &T2z, &T1z, &Qkdz, &Q2mz, &Qmz, &V2mz, &U2mz, &Vz, &Uz, &Np1, &gcd, &Dz, NULL);
return err;
}
#endif
#endif
#endif
|
Changes to libtommath/bn_mp_radix_size.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_RADIX_SIZE_C | | < < < < < < < < | < | | > | | | | | | | | | < < > > > > | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 |
#include "tommath_private.h"
#ifdef BN_MP_RADIX_SIZE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* returns size of ASCII representation */
mp_err mp_radix_size(const mp_int *a, int radix, int *size)
{
mp_err err;
int digs;
mp_int t;
mp_digit d;
*size = 0;
/* make sure the radix is in range */
if ((radix < 2) || (radix > 64)) {
return MP_VAL;
}
if (MP_IS_ZERO(a)) {
*size = 2;
return MP_OKAY;
}
/* special case for binary */
if (radix == 2) {
*size = (mp_count_bits(a) + ((a->sign == MP_NEG) ? 1 : 0) + 1);
return MP_OKAY;
}
/* digs is the digit count */
digs = 0;
/* if it's negative add one for the sign */
if (a->sign == MP_NEG) {
++digs;
}
/* init a copy of the input */
if ((err = mp_init_copy(&t, a)) != MP_OKAY) {
return err;
}
/* force temp to positive */
t.sign = MP_ZPOS;
/* fetch out all of the digits */
while (!MP_IS_ZERO(&t)) {
if ((err = mp_div_d(&t, (mp_digit)radix, &t, &d)) != MP_OKAY) {
goto LBL_ERR;
}
++digs;
}
/* return digs + 1, the 1 is for the NULL byte that would be required. */
*size = digs + 1;
err = MP_OKAY;
LBL_ERR:
mp_clear(&t);
return err;
}
#endif
|
Changes to libtommath/bn_mp_radix_smap.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_RADIX_SMAP_C | | < < < < < < < < | < | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
#include "tommath_private.h"
#ifdef BN_MP_RADIX_SMAP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* chars used in radix conversions */
const char *const mp_s_rmap = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/";
const uint8_t mp_s_rmap_reverse[] = {
0xff, 0xff, 0xff, 0x3e, 0xff, 0xff, 0xff, 0x3f, /* ()*+,-./ */
0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, /* 01234567 */
0x08, 0x09, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, /* 89:;<=>? */
0xff, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x10, /* @ABCDEFG */
0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, /* HIJKLMNO */
0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, 0x20, /* PQRSTUVW */
0x21, 0x22, 0x23, 0xff, 0xff, 0xff, 0xff, 0xff, /* XYZ[\]^_ */
0xff, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2a, /* `abcdefg */
0x2b, 0x2c, 0x2d, 0x2e, 0x2f, 0x30, 0x31, 0x32, /* hijklmno */
0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x3a, /* pqrstuvw */
0x3b, 0x3c, 0x3d, 0xff, 0xff, 0xff, 0xff, 0xff, /* xyz{|}~. */
};
const size_t mp_s_rmap_reverse_sz = sizeof(mp_s_rmap_reverse);
#endif
|
Changes to libtommath/bn_mp_rand.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_RAND_C | | < < < < < < < < | < < < < < < < < < | < | < < < < < < < < < < < | < < | < < < < < < < | < < < | < < < | < < < | < | < < < < < < < < | | < < < < < < | < < < < < | < < < < < < | | < < < < < < < < < < < < < | < < < < < < < < < < < < | | < < < < | < < < < < < | | < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < | < < | < < < < < | | | < | < | | < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
#include "tommath_private.h"
#ifdef BN_MP_RAND_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
mp_err(*s_mp_rand_source)(void *out, size_t size) = s_mp_rand_platform;
void mp_rand_source(mp_err(*source)(void *out, size_t size))
{
s_mp_rand_source = (source == NULL) ? s_mp_rand_platform : source;
}
mp_err mp_rand(mp_int *a, int digits)
{
int i;
mp_err err;
mp_zero(a);
if (digits <= 0) {
return MP_OKAY;
}
if ((err = mp_grow(a, digits)) != MP_OKAY) {
return err;
}
if ((err = s_mp_rand_source(a->dp, (size_t)digits * sizeof(mp_digit))) != MP_OKAY) {
return err;
}
/* TODO: We ensure that the highest digit is nonzero. Should this be removed? */
while ((a->dp[digits - 1] & MP_MASK) == 0u) {
if ((err = s_mp_rand_source(a->dp + digits - 1, sizeof(mp_digit))) != MP_OKAY) {
return err;
}
}
a->used = digits;
for (i = 0; i < digits; ++i) {
a->dp[i] &= MP_MASK;
}
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_read_radix.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_READ_RADIX_C | | < < < < < < < < | < | > | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
#include "tommath_private.h"
#ifdef BN_MP_READ_RADIX_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
#define MP_TOUPPER(c) ((((c) >= 'a') && ((c) <= 'z')) ? (((c) + 'A') - 'a') : (c))
/* read a string [ASCII] in a given radix */
mp_err mp_read_radix(mp_int *a, const char *str, int radix)
{
mp_err err;
int y;
mp_sign neg;
unsigned pos;
char ch;
/* zero the digit bignum */
mp_zero(a);
/* make sure the radix is ok */
if ((radix < 2) || (radix > 64)) {
return MP_VAL;
|
| ︙ | ︙ | |||
58 59 60 61 62 63 64 |
/* if the char was found in the map
* and is less than the given radix add it
* to the number, otherwise exit the loop.
*/
if ((y == 0xff) || (y >= radix)) {
break;
}
| | | | | | < < < < | 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 |
/* if the char was found in the map
* and is less than the given radix add it
* to the number, otherwise exit the loop.
*/
if ((y == 0xff) || (y >= radix)) {
break;
}
if ((err = mp_mul_d(a, (mp_digit)radix, a)) != MP_OKAY) {
return err;
}
if ((err = mp_add_d(a, (mp_digit)y, a)) != MP_OKAY) {
return err;
}
++str;
}
/* if an illegal character was found, fail. */
if (!((*str == '\0') || (*str == '\r') || (*str == '\n'))) {
mp_zero(a);
return MP_VAL;
}
/* set the sign only if a != 0 */
if (!MP_IS_ZERO(a)) {
a->sign = neg;
}
return MP_OKAY;
}
#endif
|
Deleted libtommath/bn_mp_read_signed_bin.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/bn_mp_read_unsigned_bin.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to libtommath/bn_mp_reduce.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_REDUCE_C | | < < < < < < < < | < | > | | | | | < | | | | | < | | < < | | | | > | > | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 |
#include "tommath_private.h"
#ifdef BN_MP_REDUCE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* reduces x mod m, assumes 0 < x < m**2, mu is
* precomputed via mp_reduce_setup.
* From HAC pp.604 Algorithm 14.42
*/
mp_err mp_reduce(mp_int *x, const mp_int *m, const mp_int *mu)
{
mp_int q;
mp_err err;
int um = m->used;
/* q = x */
if ((err = mp_init_copy(&q, x)) != MP_OKAY) {
return err;
}
/* q1 = x / b**(k-1) */
mp_rshd(&q, um - 1);
/* according to HAC this optimization is ok */
if ((mp_digit)um > ((mp_digit)1 << (MP_DIGIT_BIT - 1))) {
if ((err = mp_mul(&q, mu, &q)) != MP_OKAY) {
goto CLEANUP;
}
} else if (MP_HAS(S_MP_MUL_HIGH_DIGS)) {
if ((err = s_mp_mul_high_digs(&q, mu, &q, um)) != MP_OKAY) {
goto CLEANUP;
}
} else if (MP_HAS(S_MP_MUL_HIGH_DIGS_FAST)) {
if ((err = s_mp_mul_high_digs_fast(&q, mu, &q, um)) != MP_OKAY) {
goto CLEANUP;
}
} else {
err = MP_VAL;
goto CLEANUP;
}
/* q3 = q2 / b**(k+1) */
mp_rshd(&q, um + 1);
/* x = x mod b**(k+1), quick (no division) */
if ((err = mp_mod_2d(x, MP_DIGIT_BIT * (um + 1), x)) != MP_OKAY) {
goto CLEANUP;
}
/* q = q * m mod b**(k+1), quick (no division) */
if ((err = s_mp_mul_digs(&q, m, &q, um + 1)) != MP_OKAY) {
goto CLEANUP;
}
/* x = x - q */
if ((err = mp_sub(x, &q, x)) != MP_OKAY) {
goto CLEANUP;
}
/* If x < 0, add b**(k+1) to it */
if (mp_cmp_d(x, 0uL) == MP_LT) {
mp_set(&q, 1uL);
if ((err = mp_lshd(&q, um + 1)) != MP_OKAY) {
goto CLEANUP;
}
if ((err = mp_add(x, &q, x)) != MP_OKAY) {
goto CLEANUP;
}
}
/* Back off if it's too big */
while (mp_cmp(x, m) != MP_LT) {
if ((err = s_mp_sub(x, m, x)) != MP_OKAY) {
goto CLEANUP;
}
}
CLEANUP:
mp_clear(&q);
return err;
}
#endif
|
Changes to libtommath/bn_mp_reduce_2k.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_REDUCE_2K_C | | < < < < < < < < | < | > | | | | | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 |
#include "tommath_private.h"
#ifdef BN_MP_REDUCE_2K_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* reduces a modulo n where n is of the form 2**p - d */
mp_err mp_reduce_2k(mp_int *a, const mp_int *n, mp_digit d)
{
mp_int q;
mp_err err;
int p;
if ((err = mp_init(&q)) != MP_OKAY) {
return err;
}
p = mp_count_bits(n);
top:
/* q = a/2**p, a = a mod 2**p */
if ((err = mp_div_2d(a, p, &q, a)) != MP_OKAY) {
goto LBL_ERR;
}
if (d != 1u) {
/* q = q * d */
if ((err = mp_mul_d(&q, d, &q)) != MP_OKAY) {
goto LBL_ERR;
}
}
/* a = a + q */
if ((err = s_mp_add(a, &q, a)) != MP_OKAY) {
goto LBL_ERR;
}
if (mp_cmp_mag(a, n) != MP_LT) {
if ((err = s_mp_sub(a, n, a)) != MP_OKAY) {
goto LBL_ERR;
}
goto top;
}
LBL_ERR:
mp_clear(&q);
return err;
}
#endif
|
Changes to libtommath/bn_mp_reduce_2k_l.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_REDUCE_2K_L_C | | < < < < < < < < | < | > | | | | | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 |
#include "tommath_private.h"
#ifdef BN_MP_REDUCE_2K_L_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* reduces a modulo n where n is of the form 2**p - d
This differs from reduce_2k since "d" can be larger
than a single digit.
*/
mp_err mp_reduce_2k_l(mp_int *a, const mp_int *n, const mp_int *d)
{
mp_int q;
mp_err err;
int p;
if ((err = mp_init(&q)) != MP_OKAY) {
return err;
}
p = mp_count_bits(n);
top:
/* q = a/2**p, a = a mod 2**p */
if ((err = mp_div_2d(a, p, &q, a)) != MP_OKAY) {
goto LBL_ERR;
}
/* q = q * d */
if ((err = mp_mul(&q, d, &q)) != MP_OKAY) {
goto LBL_ERR;
}
/* a = a + q */
if ((err = s_mp_add(a, &q, a)) != MP_OKAY) {
goto LBL_ERR;
}
if (mp_cmp_mag(a, n) != MP_LT) {
if ((err = s_mp_sub(a, n, a)) != MP_OKAY) {
goto LBL_ERR;
}
goto top;
}
LBL_ERR:
mp_clear(&q);
return err;
}
#endif
|
Changes to libtommath/bn_mp_reduce_2k_setup.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_REDUCE_2K_SETUP_C | | < < < < < < < < | < | < > > | | | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
#include "tommath_private.h"
#ifdef BN_MP_REDUCE_2K_SETUP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* determines the setup value */
mp_err mp_reduce_2k_setup(const mp_int *a, mp_digit *d)
{
mp_err err;
mp_int tmp;
int p;
if ((err = mp_init(&tmp)) != MP_OKAY) {
return err;
}
p = mp_count_bits(a);
if ((err = mp_2expt(&tmp, p)) != MP_OKAY) {
mp_clear(&tmp);
return err;
}
if ((err = s_mp_sub(&tmp, a, &tmp)) != MP_OKAY) {
mp_clear(&tmp);
return err;
}
*d = tmp.dp[0];
mp_clear(&tmp);
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_reduce_2k_setup_l.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_REDUCE_2K_SETUP_L_C | | < < < < < < < < | < | < > | | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
#include "tommath_private.h"
#ifdef BN_MP_REDUCE_2K_SETUP_L_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* determines the setup value */
mp_err mp_reduce_2k_setup_l(const mp_int *a, mp_int *d)
{
mp_err err;
mp_int tmp;
if ((err = mp_init(&tmp)) != MP_OKAY) {
return err;
}
if ((err = mp_2expt(&tmp, mp_count_bits(a))) != MP_OKAY) {
goto LBL_ERR;
}
if ((err = s_mp_sub(&tmp, a, d)) != MP_OKAY) {
goto LBL_ERR;
}
LBL_ERR:
mp_clear(&tmp);
return err;
}
#endif
|
Changes to libtommath/bn_mp_reduce_is_2k.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_REDUCE_IS_2K_C | | < < < < < < < < | < | | | > | | > < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
#include "tommath_private.h"
#ifdef BN_MP_REDUCE_IS_2K_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* determines if mp_reduce_2k can be used */
mp_bool mp_reduce_is_2k(const mp_int *a)
{
int ix, iy, iw;
mp_digit iz;
if (a->used == 0) {
return MP_NO;
} else if (a->used == 1) {
return MP_YES;
} else if (a->used > 1) {
iy = mp_count_bits(a);
iz = 1;
iw = 1;
/* Test every bit from the second digit up, must be 1 */
for (ix = MP_DIGIT_BIT; ix < iy; ix++) {
if ((a->dp[iw] & iz) == 0u) {
return MP_NO;
}
iz <<= 1;
if (iz > MP_DIGIT_MAX) {
++iw;
iz = 1;
}
}
return MP_YES;
} else {
return MP_YES;
}
}
#endif
|
Changes to libtommath/bn_mp_reduce_is_2k_l.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_REDUCE_IS_2K_L_C | | < < < < < < < < | < | | | < | > < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
#include "tommath_private.h"
#ifdef BN_MP_REDUCE_IS_2K_L_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* determines if reduce_2k_l can be used */
mp_bool mp_reduce_is_2k_l(const mp_int *a)
{
int ix, iy;
if (a->used == 0) {
return MP_NO;
} else if (a->used == 1) {
return MP_YES;
} else if (a->used > 1) {
/* if more than half of the digits are -1 we're sold */
for (iy = ix = 0; ix < a->used; ix++) {
if (a->dp[ix] == MP_DIGIT_MAX) {
++iy;
}
}
return (iy >= (a->used/2)) ? MP_YES : MP_NO;
} else {
return MP_NO;
}
}
#endif
|
Changes to libtommath/bn_mp_reduce_setup.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_REDUCE_SETUP_C | | < < < < < < < < | < | < | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
#include "tommath_private.h"
#ifdef BN_MP_REDUCE_SETUP_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* pre-calculate the value required for Barrett reduction
* For a given modulus "b" it calulates the value required in "a"
*/
mp_err mp_reduce_setup(mp_int *a, const mp_int *b)
{
mp_err err;
if ((err = mp_2expt(a, b->used * 2 * MP_DIGIT_BIT)) != MP_OKAY) {
return err;
}
return mp_div(a, b, a, NULL);
}
#endif
|
Added libtommath/bn_mp_root_u32.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 |
#include "tommath_private.h"
#ifdef BN_MP_ROOT_U32_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* find the n'th root of an integer
*
* Result found such that (c)**b <= a and (c+1)**b > a
*
* This algorithm uses Newton's approximation
* x[i+1] = x[i] - f(x[i])/f'(x[i])
* which will find the root in log(N) time where
* each step involves a fair bit.
*/
mp_err mp_root_u32(const mp_int *a, uint32_t b, mp_int *c)
{
mp_int t1, t2, t3, a_;
mp_ord cmp;
int ilog2;
mp_err err;
/* input must be positive if b is even */
if (((b & 1u) == 0u) && (a->sign == MP_NEG)) {
return MP_VAL;
}
if ((err = mp_init_multi(&t1, &t2, &t3, NULL)) != MP_OKAY) {
return err;
}
/* if a is negative fudge the sign but keep track */
a_ = *a;
a_.sign = MP_ZPOS;
/* Compute seed: 2^(log_2(n)/b + 2)*/
ilog2 = mp_count_bits(a);
/*
If "b" is larger than INT_MAX it is also larger than
log_2(n) because the bit-length of the "n" is measured
with an int and hence the root is always < 2 (two).
*/
if (b > (uint32_t)(INT_MAX/2)) {
mp_set(c, 1uL);
c->sign = a->sign;
err = MP_OKAY;
goto LBL_ERR;
}
/* "b" is smaller than INT_MAX, we can cast safely */
if (ilog2 < (int)b) {
mp_set(c, 1uL);
c->sign = a->sign;
err = MP_OKAY;
goto LBL_ERR;
}
ilog2 = ilog2 / ((int)b);
if (ilog2 == 0) {
mp_set(c, 1uL);
c->sign = a->sign;
err = MP_OKAY;
goto LBL_ERR;
}
/* Start value must be larger than root */
ilog2 += 2;
if ((err = mp_2expt(&t2,ilog2)) != MP_OKAY) goto LBL_ERR;
do {
/* t1 = t2 */
if ((err = mp_copy(&t2, &t1)) != MP_OKAY) goto LBL_ERR;
/* t2 = t1 - ((t1**b - a) / (b * t1**(b-1))) */
/* t3 = t1**(b-1) */
if ((err = mp_expt_u32(&t1, b - 1u, &t3)) != MP_OKAY) goto LBL_ERR;
/* numerator */
/* t2 = t1**b */
if ((err = mp_mul(&t3, &t1, &t2)) != MP_OKAY) goto LBL_ERR;
/* t2 = t1**b - a */
if ((err = mp_sub(&t2, &a_, &t2)) != MP_OKAY) goto LBL_ERR;
/* denominator */
/* t3 = t1**(b-1) * b */
if ((err = mp_mul_d(&t3, b, &t3)) != MP_OKAY) goto LBL_ERR;
/* t3 = (t1**b - a)/(b * t1**(b-1)) */
if ((err = mp_div(&t2, &t3, &t3, NULL)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_sub(&t1, &t3, &t2)) != MP_OKAY) goto LBL_ERR;
/*
Number of rounds is at most log_2(root). If it is more it
got stuck, so break out of the loop and do the rest manually.
*/
if (ilog2-- == 0) {
break;
}
} while (mp_cmp(&t1, &t2) != MP_EQ);
/* result can be off by a few so check */
/* Loop beneath can overshoot by one if found root is smaller than actual root */
for (;;) {
if ((err = mp_expt_u32(&t1, b, &t2)) != MP_OKAY) goto LBL_ERR;
cmp = mp_cmp(&t2, &a_);
if (cmp == MP_EQ) {
err = MP_OKAY;
goto LBL_ERR;
}
if (cmp == MP_LT) {
if ((err = mp_add_d(&t1, 1uL, &t1)) != MP_OKAY) goto LBL_ERR;
} else {
break;
}
}
/* correct overshoot from above or from recurrence */
for (;;) {
if ((err = mp_expt_u32(&t1, b, &t2)) != MP_OKAY) goto LBL_ERR;
if (mp_cmp(&t2, &a_) == MP_GT) {
if ((err = mp_sub_d(&t1, 1uL, &t1)) != MP_OKAY) goto LBL_ERR;
} else {
break;
}
}
/* set the result */
mp_exch(&t1, c);
/* set the sign of the result */
c->sign = a->sign;
err = MP_OKAY;
LBL_ERR:
mp_clear_multi(&t1, &t2, &t3, NULL);
return err;
}
#endif
|
Changes to libtommath/bn_mp_rshd.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_RSHD_C | | < < < < < < < < | < > < < < | | | | | | | | | | | | | | | | | | | < | < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 |
#include "tommath_private.h"
#ifdef BN_MP_RSHD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* shift right a certain amount of digits */
void mp_rshd(mp_int *a, int b)
{
int x;
mp_digit *bottom, *top;
/* if b <= 0 then ignore it */
if (b <= 0) {
return;
}
/* if b > used then simply zero it and return */
if (a->used <= b) {
mp_zero(a);
return;
}
/* shift the digits down */
/* bottom */
bottom = a->dp;
/* top [offset into digits] */
top = a->dp + b;
/* this is implemented as a sliding window where
* the window is b-digits long and digits from
* the top of the window are copied to the bottom
*
* e.g.
b-2 | b-1 | b0 | b1 | b2 | ... | bb | ---->
/\ | ---->
\-------------------/ ---->
*/
for (x = 0; x < (a->used - b); x++) {
*bottom++ = *top++;
}
/* zero the top digits */
MP_ZERO_DIGITS(bottom, a->used - x);
/* remove excess digits */
a->used -= b;
}
#endif
|
Added libtommath/bn_mp_sbin_size.c.
> > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 |
#include "tommath_private.h"
#ifdef BN_MP_SBIN_SIZE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* get the size for an signed equivalent */
size_t mp_sbin_size(const mp_int *a)
{
return 1u + mp_ubin_size(a);
}
#endif
|
Changes to libtommath/bn_mp_set.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_SET_C | | < < < < < < < < | < < > > < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
#include "tommath_private.h"
#ifdef BN_MP_SET_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* set to a digit */
void mp_set(mp_int *a, mp_digit b)
{
a->dp[0] = b & MP_MASK;
a->sign = MP_ZPOS;
a->used = (a->dp[0] != 0u) ? 1 : 0;
MP_ZERO_DIGITS(a->dp + a->used, a->alloc - a->used);
}
#endif
|
Changes to libtommath/bn_mp_set_double.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_SET_DOUBLE_C | | < < < < < < < < | < | | | > | | | | < < | < | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 |
#include "tommath_private.h"
#ifdef BN_MP_SET_DOUBLE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
#if defined(__STDC_IEC_559__) || defined(__GCC_IEC_559)
mp_err mp_set_double(mp_int *a, double b)
{
uint64_t frac;
int exp;
mp_err err;
union {
double dbl;
uint64_t bits;
} cast;
cast.dbl = b;
exp = (int)((unsigned)(cast.bits >> 52) & 0x7FFu);
frac = (cast.bits & (((uint64_t)1 << 52) - (uint64_t)1)) | ((uint64_t)1 << 52);
if (exp == 0x7FF) { /* +-inf, NaN */
return MP_VAL;
}
exp -= 1023 + 52;
mp_set_u64(a, frac);
err = (exp < 0) ? mp_div_2d(a, -exp, a, NULL) : mp_mul_2d(a, exp, a);
if (err != MP_OKAY) {
return err;
}
if (((cast.bits >> 63) != 0u) && !MP_IS_ZERO(a)) {
a->sign = MP_NEG;
}
return MP_OKAY;
}
#else
/* pragma message() not supported by several compilers (in mostly older but still used versions) */
# ifdef _MSC_VER
# pragma message("mp_set_double implementation is only available on platforms with IEEE754 floating point format")
# else
# warning "mp_set_double implementation is only available on platforms with IEEE754 floating point format"
# endif
#endif
#endif
|
Added libtommath/bn_mp_set_i32.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_SET_I32_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_SET_SIGNED(mp_set_i32, mp_set_u32, int32_t, uint32_t) #endif |
Added libtommath/bn_mp_set_i64.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_SET_I64_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_SET_SIGNED(mp_set_i64, mp_set_u64, int64_t, uint64_t) #endif |
Deleted libtommath/bn_mp_set_int.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added libtommath/bn_mp_set_l.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_SET_L_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_SET_SIGNED(mp_set_l, mp_set_ul, long, unsigned long) #endif |
Added libtommath/bn_mp_set_ll.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_SET_LL_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_SET_SIGNED(mp_set_ll, mp_set_ull, long long, unsigned long long) #endif |
Deleted libtommath/bn_mp_set_long.c.
|
| < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/bn_mp_set_long_long.c.
|
| < < < < < < < < < < < < < < < < < < < < < |
Added libtommath/bn_mp_set_u32.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_SET_U32_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_SET_UNSIGNED(mp_set_u32, uint32_t) #endif |
Added libtommath/bn_mp_set_u64.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_SET_U64_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_SET_UNSIGNED(mp_set_u64, uint64_t) #endif |
Added libtommath/bn_mp_set_ul.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_SET_UL_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_SET_UNSIGNED(mp_set_ul, unsigned long) #endif |
Added libtommath/bn_mp_set_ull.c.
> > > > > > > | 1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_MP_SET_ULL_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ MP_SET_UNSIGNED(mp_set_ull, unsigned long long) #endif |
Changes to libtommath/bn_mp_shrink.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_SHRINK_C | | < < < < < < < < | < | < | < < < < | | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
#include "tommath_private.h"
#ifdef BN_MP_SHRINK_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* shrink a bignum */
mp_err mp_shrink(mp_int *a)
{
mp_digit *tmp;
int alloc = MP_MAX(MP_MIN_PREC, a->used);
if (a->alloc != alloc) {
if ((tmp = (mp_digit *) MP_REALLOC(a->dp,
(size_t)a->alloc * sizeof(mp_digit),
(size_t)alloc * sizeof(mp_digit))) == NULL) {
return MP_MEM;
}
a->dp = tmp;
a->alloc = alloc;
}
return MP_OKAY;
}
#endif
|
Deleted libtommath/bn_mp_signed_bin_size.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to libtommath/bn_mp_sqr.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_SQR_C | | < < < < < < < < | < | < | < | | | | < < < | | < < < < | | | < | | < < < | | | < | < | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
#include "tommath_private.h"
#ifdef BN_MP_SQR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* computes b = a*a */
mp_err mp_sqr(const mp_int *a, mp_int *b)
{
mp_err err;
if (MP_HAS(S_MP_TOOM_SQR) && /* use Toom-Cook? */
(a->used >= MP_TOOM_SQR_CUTOFF)) {
err = s_mp_toom_sqr(a, b);
} else if (MP_HAS(S_MP_KARATSUBA_SQR) && /* Karatsuba? */
(a->used >= MP_KARATSUBA_SQR_CUTOFF)) {
err = s_mp_karatsuba_sqr(a, b);
} else if (MP_HAS(S_MP_SQR_FAST) && /* can we use the fast comba multiplier? */
(((a->used * 2) + 1) < MP_WARRAY) &&
(a->used < (MP_MAXFAST / 2))) {
err = s_mp_sqr_fast(a, b);
} else if (MP_HAS(S_MP_SQR)) {
err = s_mp_sqr(a, b);
} else {
err = MP_VAL;
}
b->sign = MP_ZPOS;
return err;
}
#endif
|
Changes to libtommath/bn_mp_sqrmod.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_SQRMOD_C | | < < < < < < < < | < | | | | | < < > | > > | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
#include "tommath_private.h"
#ifdef BN_MP_SQRMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* c = a * a (mod b) */
mp_err mp_sqrmod(const mp_int *a, const mp_int *b, mp_int *c)
{
mp_err err;
mp_int t;
if ((err = mp_init(&t)) != MP_OKAY) {
return err;
}
if ((err = mp_sqr(a, &t)) != MP_OKAY) {
goto LBL_ERR;
}
err = mp_mod(&t, b, c);
LBL_ERR:
mp_clear(&t);
return err;
}
#endif
|
Changes to libtommath/bn_mp_sqrt.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_SQRT_C | | < < < < < < < < | < | | | | | | | | | | | | | | | | | | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 |
#include "tommath_private.h"
#ifdef BN_MP_SQRT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
#ifndef NO_FLOATING_POINT
#include <math.h>
#if (MP_DIGIT_BIT != 28) || (FLT_RADIX != 2) || (DBL_MANT_DIG != 53) || (DBL_MAX_EXP != 1024)
#define NO_FLOATING_POINT
#endif
#endif
/* this function is less generic than mp_n_root, simpler and faster */
mp_err mp_sqrt(const mp_int *arg, mp_int *ret)
{
mp_err err;
mp_int t1, t2;
#ifndef NO_FLOATING_POINT
int i, j, k;
volatile double d;
mp_digit dig;
#endif
/* must be positive */
if (arg->sign == MP_NEG) {
return MP_VAL;
}
/* easy out */
if (MP_IS_ZERO(arg)) {
mp_zero(ret);
return MP_OKAY;
}
#ifndef NO_FLOATING_POINT
i = (arg->used / 2) - 1;
j = 2 * i;
if ((err = mp_init_size(&t1, i+2)) != MP_OKAY) {
return err;
}
if ((err = mp_init(&t2)) != MP_OKAY) {
goto E2;
}
for (k = 0; k < i; ++k) {
t1.dp[k] = (mp_digit) 0;
}
/* Estimate the square root using the hardware floating point unit. */
d = 0.0;
for (k = arg->used-1; k >= j; --k) {
d = ldexp(d, MP_DIGIT_BIT) + (double)(arg->dp[k]);
}
/*
* At this point, d is the nearest floating point number to the most
* significant 1 or 2 mp_digits of arg. Extract its square root.
*/
d = sqrt(d);
/* dig is the most significant mp_digit of the square root */
dig = (mp_digit) ldexp(d, -MP_DIGIT_BIT);
/*
* If the most significant digit is nonzero, find the next digit down
* by subtracting MP_DIGIT_BIT times thie most significant digit.
* Subtract one from the result so that our initial estimate is always
* low.
*/
if (dig) {
t1.used = i+2;
d -= ldexp((double) dig, MP_DIGIT_BIT);
if (d >= 1.0) {
t1.dp[i+1] = dig;
t1.dp[i] = ((mp_digit) d) - 1;
} else {
t1.dp[i+1] = dig-1;
t1.dp[i] = MP_DIGIT_MAX;
}
} else {
t1.used = i+1;
t1.dp[i] = ((mp_digit) d) - 1;
}
#else
if ((err = mp_init_copy(&t1, arg)) != MP_OKAY) {
return err;
}
if ((err = mp_init(&t2)) != MP_OKAY) {
goto E2;
}
/* First approx. (not very bad for large arg) */
mp_rshd(&t1, t1.used/2);
#endif
/* t1 > 0 */
if ((err = mp_div(arg, &t1, &t2, NULL)) != MP_OKAY) {
goto E1;
}
if ((err = mp_add(&t1, &t2, &t1)) != MP_OKAY) {
goto E1;
}
if ((err = mp_div_2(&t1, &t1)) != MP_OKAY) {
goto E1;
}
/* And now t1 > sqrt(arg) */
do {
if ((err = mp_div(arg, &t1, &t2, NULL)) != MP_OKAY) {
goto E1;
}
if ((err = mp_add(&t1, &t2, &t1)) != MP_OKAY) {
goto E1;
}
if ((err = mp_div_2(&t1, &t1)) != MP_OKAY) {
goto E1;
}
/* t1 >= sqrt(arg) >= t2 at this point */
} while (mp_cmp_mag(&t1, &t2) == MP_GT);
mp_exch(&t1, ret);
E1:
mp_clear(&t2);
E2:
mp_clear(&t1);
return err;
}
#endif
|
Changes to libtommath/bn_mp_sqrtmod_prime.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_SQRTMOD_PRIME_C | | < < < < < < < < | < | > | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | | | | | | | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 |
#include "tommath_private.h"
#ifdef BN_MP_SQRTMOD_PRIME_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* Tonelli-Shanks algorithm
* https://en.wikipedia.org/wiki/Tonelli%E2%80%93Shanks_algorithm
* https://gmplib.org/list-archives/gmp-discuss/2013-April/005300.html
*
*/
mp_err mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret)
{
mp_err err;
int legendre;
mp_int t1, C, Q, S, Z, M, T, R, two;
mp_digit i;
/* first handle the simple cases */
if (mp_cmp_d(n, 0uL) == MP_EQ) {
mp_zero(ret);
return MP_OKAY;
}
if (mp_cmp_d(prime, 2uL) == MP_EQ) return MP_VAL; /* prime must be odd */
if ((err = mp_kronecker(n, prime, &legendre)) != MP_OKAY) return err;
if (legendre == -1) return MP_VAL; /* quadratic non-residue mod prime */
if ((err = mp_init_multi(&t1, &C, &Q, &S, &Z, &M, &T, &R, &two, NULL)) != MP_OKAY) {
return err;
}
/* SPECIAL CASE: if prime mod 4 == 3
* compute directly: err = n^(prime+1)/4 mod prime
* Handbook of Applied Cryptography algorithm 3.36
*/
if ((err = mp_mod_d(prime, 4uL, &i)) != MP_OKAY) goto cleanup;
if (i == 3u) {
if ((err = mp_add_d(prime, 1uL, &t1)) != MP_OKAY) goto cleanup;
if ((err = mp_div_2(&t1, &t1)) != MP_OKAY) goto cleanup;
if ((err = mp_div_2(&t1, &t1)) != MP_OKAY) goto cleanup;
if ((err = mp_exptmod(n, &t1, prime, ret)) != MP_OKAY) goto cleanup;
err = MP_OKAY;
goto cleanup;
}
/* NOW: Tonelli-Shanks algorithm */
/* factor out powers of 2 from prime-1, defining Q and S as: prime-1 = Q*2^S */
if ((err = mp_copy(prime, &Q)) != MP_OKAY) goto cleanup;
if ((err = mp_sub_d(&Q, 1uL, &Q)) != MP_OKAY) goto cleanup;
/* Q = prime - 1 */
mp_zero(&S);
/* S = 0 */
while (MP_IS_EVEN(&Q)) {
if ((err = mp_div_2(&Q, &Q)) != MP_OKAY) goto cleanup;
/* Q = Q / 2 */
if ((err = mp_add_d(&S, 1uL, &S)) != MP_OKAY) goto cleanup;
/* S = S + 1 */
}
/* find a Z such that the Legendre symbol (Z|prime) == -1 */
mp_set_u32(&Z, 2u);
/* Z = 2 */
for (;;) {
if ((err = mp_kronecker(&Z, prime, &legendre)) != MP_OKAY) goto cleanup;
if (legendre == -1) break;
if ((err = mp_add_d(&Z, 1uL, &Z)) != MP_OKAY) goto cleanup;
/* Z = Z + 1 */
}
if ((err = mp_exptmod(&Z, &Q, prime, &C)) != MP_OKAY) goto cleanup;
/* C = Z ^ Q mod prime */
if ((err = mp_add_d(&Q, 1uL, &t1)) != MP_OKAY) goto cleanup;
if ((err = mp_div_2(&t1, &t1)) != MP_OKAY) goto cleanup;
/* t1 = (Q + 1) / 2 */
if ((err = mp_exptmod(n, &t1, prime, &R)) != MP_OKAY) goto cleanup;
/* R = n ^ ((Q + 1) / 2) mod prime */
if ((err = mp_exptmod(n, &Q, prime, &T)) != MP_OKAY) goto cleanup;
/* T = n ^ Q mod prime */
if ((err = mp_copy(&S, &M)) != MP_OKAY) goto cleanup;
/* M = S */
mp_set_u32(&two, 2u);
for (;;) {
if ((err = mp_copy(&T, &t1)) != MP_OKAY) goto cleanup;
i = 0;
for (;;) {
if (mp_cmp_d(&t1, 1uL) == MP_EQ) break;
if ((err = mp_exptmod(&t1, &two, prime, &t1)) != MP_OKAY) goto cleanup;
i++;
}
if (i == 0u) {
if ((err = mp_copy(&R, ret)) != MP_OKAY) goto cleanup;
err = MP_OKAY;
goto cleanup;
}
if ((err = mp_sub_d(&M, i, &t1)) != MP_OKAY) goto cleanup;
if ((err = mp_sub_d(&t1, 1uL, &t1)) != MP_OKAY) goto cleanup;
if ((err = mp_exptmod(&two, &t1, prime, &t1)) != MP_OKAY) goto cleanup;
/* t1 = 2 ^ (M - i - 1) */
if ((err = mp_exptmod(&C, &t1, prime, &t1)) != MP_OKAY) goto cleanup;
/* t1 = C ^ (2 ^ (M - i - 1)) mod prime */
if ((err = mp_sqrmod(&t1, prime, &C)) != MP_OKAY) goto cleanup;
/* C = (t1 * t1) mod prime */
if ((err = mp_mulmod(&R, &t1, prime, &R)) != MP_OKAY) goto cleanup;
/* R = (R * t1) mod prime */
if ((err = mp_mulmod(&T, &C, prime, &T)) != MP_OKAY) goto cleanup;
/* T = (T * C) mod prime */
mp_set(&M, i);
/* M = i */
}
cleanup:
mp_clear_multi(&t1, &C, &Q, &S, &Z, &M, &T, &R, &two, NULL);
return err;
}
#endif
|
Changes to libtommath/bn_mp_sub.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_SUB_C | | < < < < < < < < | < | < < < | > | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 |
#include "tommath_private.h"
#ifdef BN_MP_SUB_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* high level subtraction (handles signs) */
mp_err mp_sub(const mp_int *a, const mp_int *b, mp_int *c)
{
mp_sign sa = a->sign, sb = b->sign;
mp_err err;
if (sa != sb) {
/* subtract a negative from a positive, OR */
/* subtract a positive from a negative. */
/* In either case, ADD their magnitudes, */
/* and use the sign of the first number. */
c->sign = sa;
err = s_mp_add(a, b, c);
} else {
/* subtract a positive from a positive, OR */
/* subtract a negative from a negative. */
/* First, take the difference between their */
/* magnitudes, then... */
if (mp_cmp_mag(a, b) != MP_LT) {
/* Copy the sign from the first */
c->sign = sa;
/* The first has a larger or equal magnitude */
err = s_mp_sub(a, b, c);
} else {
/* The result has the *opposite* sign from */
/* the first number. */
c->sign = (sa == MP_ZPOS) ? MP_NEG : MP_ZPOS;
/* The second has a larger magnitude */
err = s_mp_sub(b, a, c);
}
}
return err;
}
#endif
|
Changes to libtommath/bn_mp_sub_d.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_SUB_D_C | | < < < < < < < < | < | | > | | | | | > > | < < < < < | | | < | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
#include "tommath_private.h"
#ifdef BN_MP_SUB_D_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* single digit subtraction */
mp_err mp_sub_d(const mp_int *a, mp_digit b, mp_int *c)
{
mp_digit *tmpa, *tmpc;
mp_err err;
int ix, oldused;
/* grow c as required */
if (c->alloc < (a->used + 1)) {
if ((err = mp_grow(c, a->used + 1)) != MP_OKAY) {
return err;
}
}
/* if a is negative just do an unsigned
* addition [with fudged signs]
*/
if (a->sign == MP_NEG) {
mp_int a_ = *a;
a_.sign = MP_ZPOS;
err = mp_add_d(&a_, b, c);
c->sign = MP_NEG;
/* clamp */
mp_clamp(c);
return err;
}
/* setup regs */
oldused = c->used;
tmpa = a->dp;
tmpc = c->dp;
/* if a <= b simply fix the single digit */
if (((a->used == 1) && (a->dp[0] <= b)) || (a->used == 0)) {
if (a->used == 1) {
*tmpc++ = b - *tmpa;
} else {
*tmpc++ = b;
}
ix = 1;
/* negative/1digit */
c->sign = MP_NEG;
c->used = 1;
} else {
mp_digit mu = b;
/* positive/size */
c->sign = MP_ZPOS;
c->used = a->used;
/* subtract digits, mu is carry */
for (ix = 0; ix < a->used; ix++) {
*tmpc = *tmpa++ - mu;
mu = *tmpc >> (MP_SIZEOF_BITS(mp_digit) - 1u);
*tmpc++ &= MP_MASK;
}
}
/* zero excess digits */
MP_ZERO_DIGITS(tmpc, oldused - ix);
mp_clamp(c);
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_mp_submod.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_SUBMOD_C | | < < < < < < < < | < | < > | < | | | < < > | > > | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
#include "tommath_private.h"
#ifdef BN_MP_SUBMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* d = a - b (mod c) */
mp_err mp_submod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d)
{
mp_err err;
mp_int t;
if ((err = mp_init(&t)) != MP_OKAY) {
return err;
}
if ((err = mp_sub(a, b, &t)) != MP_OKAY) {
goto LBL_ERR;
}
err = mp_mod(&t, c, d);
LBL_ERR:
mp_clear(&t);
return err;
}
#endif
|
Added libtommath/bn_mp_to_radix.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 |
#include "tommath_private.h"
#ifdef BN_MP_TO_RADIX_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* stores a bignum as a ASCII string in a given radix (2..64)
*
* Stores upto "size - 1" chars and always a NULL byte, puts the number of characters
* written, including the '\0', in "written".
*/
mp_err mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix)
{
size_t digs;
mp_err err;
mp_int t;
mp_digit d;
char *_s = str;
/* check range of radix and size*/
if (maxlen < 2u) {
return MP_BUF;
}
if ((radix < 2) || (radix > 64)) {
return MP_VAL;
}
/* quick out if its zero */
if (MP_IS_ZERO(a)) {
*str++ = '0';
*str = '\0';
if (written != NULL) {
*written = 2u;
}
return MP_OKAY;
}
if ((err = mp_init_copy(&t, a)) != MP_OKAY) {
return err;
}
/* if it is negative output a - */
if (t.sign == MP_NEG) {
/* we have to reverse our digits later... but not the - sign!! */
++_s;
/* store the flag and mark the number as positive */
*str++ = '-';
t.sign = MP_ZPOS;
/* subtract a char */
--maxlen;
}
digs = 0u;
while (!MP_IS_ZERO(&t)) {
if (--maxlen < 1u) {
/* no more room */
err = MP_BUF;
goto LBL_ERR;
}
if ((err = mp_div_d(&t, (mp_digit)radix, &t, &d)) != MP_OKAY) {
goto LBL_ERR;
}
*str++ = mp_s_rmap[d];
++digs;
}
/* reverse the digits of the string. In this case _s points
* to the first digit [exluding the sign] of the number
*/
s_mp_reverse((unsigned char *)_s, digs);
/* append a NULL so the string is properly terminated */
*str = '\0';
digs++;
if (written != NULL) {
*written = (a->sign == MP_NEG) ? (digs + 1u): digs;
}
LBL_ERR:
mp_clear(&t);
return err;
}
#endif
|
Added libtommath/bn_mp_to_sbin.c.
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
#include "tommath_private.h"
#ifdef BN_MP_TO_SBIN_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* store in signed [big endian] format */
mp_err mp_to_sbin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written)
{
mp_err err;
if (maxlen == 0u) {
return MP_BUF;
}
if ((err = mp_to_ubin(a, buf + 1, maxlen - 1u, written)) != MP_OKAY) {
return err;
}
if (written != NULL) {
(*written)++;
}
buf[0] = (a->sign == MP_ZPOS) ? (unsigned char)0 : (unsigned char)1;
return MP_OKAY;
}
#endif
|
Deleted libtommath/bn_mp_to_signed_bin.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/bn_mp_to_signed_bin_n.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added libtommath/bn_mp_to_ubin.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 |
#include "tommath_private.h"
#ifdef BN_MP_TO_UBIN_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* store in unsigned [big endian] format */
mp_err mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written)
{
size_t x, count;
mp_err err;
mp_int t;
count = mp_ubin_size(a);
if (count > maxlen) {
return MP_BUF;
}
if ((err = mp_init_copy(&t, a)) != MP_OKAY) {
return err;
}
for (x = count; x --> 0u;) {
#ifndef MP_8BIT
buf[x] = (unsigned char)(t.dp[0] & 255u);
#else
buf[x] = (unsigned char)(t.dp[0] | ((t.dp[1] & 1u) << 7));
#endif
if ((err = mp_div_2d(&t, 8, &t, NULL)) != MP_OKAY) {
goto LBL_ERR;
}
}
if (written != NULL) {
*written = count;
}
LBL_ERR:
mp_clear(&t);
return err;
}
#endif
|
Deleted libtommath/bn_mp_to_unsigned_bin.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/bn_mp_to_unsigned_bin_n.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/bn_mp_toom_mul.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/bn_mp_toom_sqr.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/bn_mp_toradix.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted libtommath/bn_mp_toradix_n.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Added libtommath/bn_mp_ubin_size.c.
> > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 |
#include "tommath_private.h"
#ifdef BN_MP_UBIN_SIZE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* get the size for an unsigned equivalent */
size_t mp_ubin_size(const mp_int *a)
{
size_t size = (size_t)mp_count_bits(a);
return (size / 8u) + (((size & 7u) != 0u) ? 1u : 0u);
}
#endif
|
Added libtommath/bn_mp_unpack.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 |
#include "tommath_private.h"
#ifdef BN_MP_UNPACK_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* based on gmp's mpz_import.
* see http://gmplib.org/manual/Integer-Import-and-Export.html
*/
mp_err mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size,
mp_endian endian, size_t nails, const void *op)
{
mp_err err;
size_t odd_nails, nail_bytes, i, j;
unsigned char odd_nail_mask;
mp_zero(rop);
if (endian == MP_NATIVE_ENDIAN) {
MP_GET_ENDIANNESS(endian);
}
odd_nails = (nails % 8u);
odd_nail_mask = 0xff;
for (i = 0; i < odd_nails; ++i) {
odd_nail_mask ^= (unsigned char)(1u << (7u - i));
}
nail_bytes = nails / 8u;
for (i = 0; i < count; ++i) {
for (j = 0; j < (size - nail_bytes); ++j) {
unsigned char byte = *((const unsigned char *)op +
(((order == MP_MSB_FIRST) ? i : ((count - 1u) - i)) * size) +
((endian == MP_BIG_ENDIAN) ? (j + nail_bytes) : (((size - 1u) - j) - nail_bytes)));
if ((err = mp_mul_2d(rop, (j == 0u) ? (int)(8u - odd_nails) : 8, rop)) != MP_OKAY) {
return err;
}
rop->dp[0] |= (j == 0u) ? (mp_digit)(byte & odd_nail_mask) : (mp_digit)byte;
rop->used += 1;
}
}
mp_clamp(rop);
return MP_OKAY;
}
#endif
|
Deleted libtommath/bn_mp_unsigned_bin_size.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to libtommath/bn_mp_xor.c.
1 2 3 4 5 6 7 8 |
#include "tommath_private.h"
#ifdef BN_MP_XOR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* two complement xor */
mp_err mp_xor(const mp_int *a, const mp_int *b, mp_int *c)
{
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 |
#include "tommath_private.h"
#ifdef BN_MP_XOR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* two complement xor */
mp_err mp_xor(const mp_int *a, const mp_int *b, mp_int *c)
{
int used = MP_MAX(a->used, b->used) + 1, i;
mp_err err;
mp_digit ac = 1, bc = 1, cc = 1;
mp_sign csign = (a->sign != b->sign) ? MP_NEG : MP_ZPOS;
if (c->alloc < used) {
if ((err = mp_grow(c, used)) != MP_OKAY) {
return err;
|
| ︙ | ︙ |
Changes to libtommath/bn_mp_zero.c.
1 2 | #include "tommath_private.h" #ifdef BN_MP_ZERO_C | | < < < < < < < < | < < < < | < < < | < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 |
#include "tommath_private.h"
#ifdef BN_MP_ZERO_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* set to zero */
void mp_zero(mp_int *a)
{
a->sign = MP_ZPOS;
a->used = 0;
MP_ZERO_DIGITS(a->dp, a->alloc);
}
#endif
|
Changes to libtommath/bn_prime_tab.c.
1 2 | #include "tommath_private.h" #ifdef BN_PRIME_TAB_C | | < < < < < < < < | < | 1 2 3 4 5 6 7 8 9 10 11 |
#include "tommath_private.h"
#ifdef BN_PRIME_TAB_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
const mp_digit ltm_prime_tab[] = {
0x0002, 0x0003, 0x0005, 0x0007, 0x000B, 0x000D, 0x0011, 0x0013,
0x0017, 0x001D, 0x001F, 0x0025, 0x0029, 0x002B, 0x002F, 0x0035,
0x003B, 0x003D, 0x0043, 0x0047, 0x0049, 0x004F, 0x0053, 0x0059,
0x0061, 0x0065, 0x0067, 0x006B, 0x006D, 0x0071, 0x007F,
#ifndef MP_8BIT
|
| ︙ | ︙ | |||
48 49 50 51 52 53 54 55 56 | 0x052F, 0x0551, 0x0557, 0x055D, 0x0565, 0x0577, 0x0581, 0x058F, 0x0593, 0x0595, 0x0599, 0x059F, 0x05A7, 0x05AB, 0x05AD, 0x05B3, 0x05BF, 0x05C9, 0x05CB, 0x05CF, 0x05D1, 0x05D5, 0x05DB, 0x05E7, 0x05F3, 0x05FB, 0x0607, 0x060D, 0x0611, 0x0617, 0x061F, 0x0623, 0x062B, 0x062F, 0x063D, 0x0641, 0x0647, 0x0649, 0x064D, 0x0653 #endif }; #endif | > > > > > > > > > > > > > < < < > | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | 0x052F, 0x0551, 0x0557, 0x055D, 0x0565, 0x0577, 0x0581, 0x058F, 0x0593, 0x0595, 0x0599, 0x059F, 0x05A7, 0x05AB, 0x05AD, 0x05B3, 0x05BF, 0x05C9, 0x05CB, 0x05CF, 0x05D1, 0x05D5, 0x05DB, 0x05E7, 0x05F3, 0x05FB, 0x0607, 0x060D, 0x0611, 0x0617, 0x061F, 0x0623, 0x062B, 0x062F, 0x063D, 0x0641, 0x0647, 0x0649, 0x064D, 0x0653 #endif }; #if defined(__GNUC__) && __GNUC__ >= 4 #pragma GCC diagnostic push #pragma GCC diagnostic ignored "-Wdeprecated-declarations" const mp_digit *s_mp_prime_tab = ltm_prime_tab; #pragma GCC diagnostic pop #elif defined(_MSC_VER) && _MSC_VER >= 1500 #pragma warning(push) #pragma warning(disable: 4996) const mp_digit *s_mp_prime_tab = ltm_prime_tab; #pragma warning(pop) #else const mp_digit *s_mp_prime_tab = ltm_prime_tab; #endif #endif |
Deleted libtommath/bn_reverse.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to libtommath/bn_s_mp_add.c.
1 2 | #include "tommath_private.h" #ifdef BN_S_MP_ADD_C | | < < < < < < < < | < | > | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 |
#include "tommath_private.h"
#ifdef BN_S_MP_ADD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* low level addition, based on HAC pp.594, Algorithm 14.7 */
mp_err s_mp_add(const mp_int *a, const mp_int *b, mp_int *c)
{
const mp_int *x;
mp_err err;
int olduse, min, max;
/* find sizes, we let |a| <= |b| which means we have to sort
* them. "x" will point to the input with the most digits
*/
if (a->used > b->used) {
min = b->used;
max = a->used;
x = a;
} else {
min = a->used;
max = b->used;
x = b;
}
/* init result */
if (c->alloc < (max + 1)) {
if ((err = mp_grow(c, max + 1)) != MP_OKAY) {
return err;
}
}
/* get old used digit count and set new one */
olduse = c->used;
c->used = max + 1;
|
| ︙ | ︙ | |||
60 61 62 63 64 65 66 |
/* zero the carry */
u = 0;
for (i = 0; i < min; i++) {
/* Compute the sum at one digit, T[i] = A[i] + B[i] + U */
*tmpc = *tmpa++ + *tmpb++ + u;
/* U = carry bit of T[i] */
| | | | < < < < < < | 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 |
/* zero the carry */
u = 0;
for (i = 0; i < min; i++) {
/* Compute the sum at one digit, T[i] = A[i] + B[i] + U */
*tmpc = *tmpa++ + *tmpb++ + u;
/* U = carry bit of T[i] */
u = *tmpc >> (mp_digit)MP_DIGIT_BIT;
/* take away carry bit from T[i] */
*tmpc++ &= MP_MASK;
}
/* now copy higher words if any, that is in A+B
* if A or B has more digits add those in
*/
if (min != max) {
for (; i < max; i++) {
/* T[i] = X[i] + U */
*tmpc = x->dp[i] + u;
/* U = carry bit of T[i] */
u = *tmpc >> (mp_digit)MP_DIGIT_BIT;
/* take away carry bit from T[i] */
*tmpc++ &= MP_MASK;
}
}
/* add carry */
*tmpc++ = u;
/* clear digits above oldused */
MP_ZERO_DIGITS(tmpc, olduse - c->used);
}
mp_clamp(c);
return MP_OKAY;
}
#endif
|
Added libtommath/bn_s_mp_balance_mul.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 |
#include "tommath_private.h"
#ifdef BN_S_MP_BALANCE_MUL_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* single-digit multiplication with the smaller number as the single-digit */
mp_err s_mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c)
{
int count, len_a, len_b, nblocks, i, j, bsize;
mp_int a0, tmp, A, B, r;
mp_err err;
len_a = a->used;
len_b = b->used;
nblocks = MP_MAX(a->used, b->used) / MP_MIN(a->used, b->used);
bsize = MP_MIN(a->used, b->used) ;
if ((err = mp_init_size(&a0, bsize + 2)) != MP_OKAY) {
return err;
}
if ((err = mp_init_multi(&tmp, &r, NULL)) != MP_OKAY) {
mp_clear(&a0);
return err;
}
/* Make sure that A is the larger one*/
if (len_a < len_b) {
B = *a;
A = *b;
} else {
A = *a;
B = *b;
}
for (i = 0, j=0; i < nblocks; i++) {
/* Cut a slice off of a */
a0.used = 0;
for (count = 0; count < bsize; count++) {
a0.dp[count] = A.dp[ j++ ];
a0.used++;
}
mp_clamp(&a0);
/* Multiply with b */
if ((err = mp_mul(&a0, &B, &tmp)) != MP_OKAY) {
goto LBL_ERR;
}
/* Shift tmp to the correct position */
if ((err = mp_lshd(&tmp, bsize * i)) != MP_OKAY) {
goto LBL_ERR;
}
/* Add to output. No carry needed */
if ((err = mp_add(&r, &tmp, &r)) != MP_OKAY) {
goto LBL_ERR;
}
}
/* The left-overs; there are always left-overs */
if (j < A.used) {
a0.used = 0;
for (count = 0; j < A.used; count++) {
a0.dp[count] = A.dp[ j++ ];
a0.used++;
}
mp_clamp(&a0);
if ((err = mp_mul(&a0, &B, &tmp)) != MP_OKAY) {
goto LBL_ERR;
}
if ((err = mp_lshd(&tmp, bsize * i)) != MP_OKAY) {
goto LBL_ERR;
}
if ((err = mp_add(&r, &tmp, &r)) != MP_OKAY) {
goto LBL_ERR;
}
}
mp_exch(&r,c);
LBL_ERR:
mp_clear_multi(&a0, &tmp, &r,NULL);
return err;
}
#endif
|
Changes to libtommath/bn_s_mp_exptmod.c.
1 2 | #include "tommath_private.h" #ifdef BN_S_MP_EXPTMOD_C | | < < < < < < < < | < > > | > | | < < | < < | < | < | < < | < < | < < | < < | < | < | < < | < < | < < | < < | | | < < | < < | < < | < < | < < | < < | < < | < < | < < | < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 |
#include "tommath_private.h"
#ifdef BN_S_MP_EXPTMOD_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
#ifdef MP_LOW_MEM
# define TAB_SIZE 32
# define MAX_WINSIZE 5
#else
# define TAB_SIZE 256
# define MAX_WINSIZE 0
#endif
mp_err s_mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode)
{
mp_int M[TAB_SIZE], res, mu;
mp_digit buf;
mp_err err;
int bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize;
mp_err(*redux)(mp_int *x, const mp_int *m, const mp_int *mu);
/* find window size */
x = mp_count_bits(X);
if (x <= 7) {
winsize = 2;
} else if (x <= 36) {
winsize = 3;
} else if (x <= 140) {
winsize = 4;
} else if (x <= 450) {
winsize = 5;
} else if (x <= 1303) {
winsize = 6;
} else if (x <= 3529) {
winsize = 7;
} else {
winsize = 8;
}
winsize = MAX_WINSIZE ? MP_MIN(MAX_WINSIZE, winsize) : winsize;
/* init M array */
/* init first cell */
if ((err = mp_init(&M[1])) != MP_OKAY) {
return err;
}
/* now init the second half of the array */
for (x = 1<<(winsize-1); x < (1 << winsize); x++) {
if ((err = mp_init(&M[x])) != MP_OKAY) {
for (y = 1<<(winsize-1); y < x; y++) {
mp_clear(&M[y]);
}
mp_clear(&M[1]);
return err;
}
}
/* create mu, used for Barrett reduction */
if ((err = mp_init(&mu)) != MP_OKAY) goto LBL_M;
if (redmode == 0) {
if ((err = mp_reduce_setup(&mu, P)) != MP_OKAY) goto LBL_MU;
redux = mp_reduce;
} else {
if ((err = mp_reduce_2k_setup_l(P, &mu)) != MP_OKAY) goto LBL_MU;
redux = mp_reduce_2k_l;
}
/* create M table
*
* The M table contains powers of the base,
* e.g. M[x] = G**x mod P
*
* The first half of the table is not
* computed though accept for M[0] and M[1]
*/
if ((err = mp_mod(G, P, &M[1])) != MP_OKAY) goto LBL_MU;
/* compute the value at M[1<<(winsize-1)] by squaring
* M[1] (winsize-1) times
*/
if ((err = mp_copy(&M[1], &M[(size_t)1 << (winsize - 1)])) != MP_OKAY) goto LBL_MU;
for (x = 0; x < (winsize - 1); x++) {
/* square it */
if ((err = mp_sqr(&M[(size_t)1 << (winsize - 1)],
&M[(size_t)1 << (winsize - 1)])) != MP_OKAY) goto LBL_MU;
/* reduce modulo P */
if ((err = redux(&M[(size_t)1 << (winsize - 1)], P, &mu)) != MP_OKAY) goto LBL_MU;
}
/* create upper table, that is M[x] = M[x-1] * M[1] (mod P)
* for x = (2**(winsize - 1) + 1) to (2**winsize - 1)
*/
for (x = (1 << (winsize - 1)) + 1; x < (1 << winsize); x++) {
if ((err = mp_mul(&M[x - 1], &M[1], &M[x])) != MP_OKAY) goto LBL_MU;
if ((err = redux(&M[x], P, &mu)) != MP_OKAY) goto LBL_MU;
}
/* setup result */
if ((err = mp_init(&res)) != MP_OKAY) goto LBL_MU;
mp_set(&res, 1uL);
/* set initial mode and bit cnt */
mode = 0;
bitcnt = 1;
buf = 0;
digidx = X->used - 1;
bitcpy = 0;
bitbuf = 0;
for (;;) {
/* grab next digit as required */
if (--bitcnt == 0) {
/* if digidx == -1 we are out of digits */
if (digidx == -1) {
break;
}
/* read next digit and reset the bitcnt */
buf = X->dp[digidx--];
bitcnt = (int)MP_DIGIT_BIT;
}
/* grab the next msb from the exponent */
y = (buf >> (mp_digit)(MP_DIGIT_BIT - 1)) & 1uL;
buf <<= (mp_digit)1;
/* if the bit is zero and mode == 0 then we ignore it
* These represent the leading zero bits before the first 1 bit
* in the exponent. Technically this opt is not required but it
* does lower the # of trivial squaring/reductions used
*/
if ((mode == 0) && (y == 0)) {
continue;
}
/* if the bit is zero and mode == 1 then we square */
if ((mode == 1) && (y == 0)) {
if ((err = mp_sqr(&res, &res)) != MP_OKAY) goto LBL_RES;
if ((err = redux(&res, P, &mu)) != MP_OKAY) goto LBL_RES;
continue;
}
/* else we add it to the window */
bitbuf |= (y << (winsize - ++bitcpy));
mode = 2;
if (bitcpy == winsize) {
/* ok window is filled so square as required and multiply */
/* square first */
for (x = 0; x < winsize; x++) {
if ((err = mp_sqr(&res, &res)) != MP_OKAY) goto LBL_RES;
if ((err = redux(&res, P, &mu)) != MP_OKAY) goto LBL_RES;
}
/* then multiply */
if ((err = mp_mul(&res, &M[bitbuf], &res)) != MP_OKAY) goto LBL_RES;
if ((err = redux(&res, P, &mu)) != MP_OKAY) goto LBL_RES;
/* empty window and reset */
bitcpy = 0;
bitbuf = 0;
mode = 1;
}
}
/* if bits remain then square/multiply */
if ((mode == 2) && (bitcpy > 0)) {
/* square then multiply if the bit is set */
for (x = 0; x < bitcpy; x++) {
if ((err = mp_sqr(&res, &res)) != MP_OKAY) goto LBL_RES;
if ((err = redux(&res, P, &mu)) != MP_OKAY) goto LBL_RES;
bitbuf <<= 1;
if ((bitbuf & (1 << winsize)) != 0) {
/* then multiply */
if ((err = mp_mul(&res, &M[1], &res)) != MP_OKAY) goto LBL_RES;
if ((err = redux(&res, P, &mu)) != MP_OKAY) goto LBL_RES;
}
}
}
mp_exch(&res, Y);
err = MP_OKAY;
LBL_RES:
mp_clear(&res);
LBL_MU:
mp_clear(&mu);
LBL_M:
mp_clear(&M[1]);
for (x = 1<<(winsize-1); x < (1 << winsize); x++) {
mp_clear(&M[x]);
}
return err;
}
#endif
|
Added libtommath/bn_s_mp_exptmod_fast.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 |
#include "tommath_private.h"
#ifdef BN_S_MP_EXPTMOD_FAST_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* computes Y == G**X mod P, HAC pp.616, Algorithm 14.85
*
* Uses a left-to-right k-ary sliding window to compute the modular exponentiation.
* The value of k changes based on the size of the exponent.
*
* Uses Montgomery or Diminished Radix reduction [whichever appropriate]
*/
#ifdef MP_LOW_MEM
# define TAB_SIZE 32
# define MAX_WINSIZE 5
#else
# define TAB_SIZE 256
# define MAX_WINSIZE 0
#endif
mp_err s_mp_exptmod_fast(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode)
{
mp_int M[TAB_SIZE], res;
mp_digit buf, mp;
int bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize;
mp_err err;
/* use a pointer to the reduction algorithm. This allows us to use
* one of many reduction algorithms without modding the guts of
* the code with if statements everywhere.
*/
mp_err(*redux)(mp_int *x, const mp_int *n, mp_digit rho);
/* find window size */
x = mp_count_bits(X);
if (x <= 7) {
winsize = 2;
} else if (x <= 36) {
winsize = 3;
} else if (x <= 140) {
winsize = 4;
} else if (x <= 450) {
winsize = 5;
} else if (x <= 1303) {
winsize = 6;
} else if (x <= 3529) {
winsize = 7;
} else {
winsize = 8;
}
winsize = MAX_WINSIZE ? MP_MIN(MAX_WINSIZE, winsize) : winsize;
/* init M array */
/* init first cell */
if ((err = mp_init_size(&M[1], P->alloc)) != MP_OKAY) {
return err;
}
/* now init the second half of the array */
for (x = 1<<(winsize-1); x < (1 << winsize); x++) {
if ((err = mp_init_size(&M[x], P->alloc)) != MP_OKAY) {
for (y = 1<<(winsize-1); y < x; y++) {
mp_clear(&M[y]);
}
mp_clear(&M[1]);
return err;
}
}
/* determine and setup reduction code */
if (redmode == 0) {
if (MP_HAS(MP_MONTGOMERY_SETUP)) {
/* now setup montgomery */
if ((err = mp_montgomery_setup(P, &mp)) != MP_OKAY) goto LBL_M;
} else {
err = MP_VAL;
goto LBL_M;
}
/* automatically pick the comba one if available (saves quite a few calls/ifs) */
if (MP_HAS(S_MP_MONTGOMERY_REDUCE_FAST) &&
(((P->used * 2) + 1) < MP_WARRAY) &&
(P->used < MP_MAXFAST)) {
redux = s_mp_montgomery_reduce_fast;
} else if (MP_HAS(MP_MONTGOMERY_REDUCE)) {
/* use slower baseline Montgomery method */
redux = mp_montgomery_reduce;
} else {
err = MP_VAL;
goto LBL_M;
}
} else if (redmode == 1) {
if (MP_HAS(MP_DR_SETUP) && MP_HAS(MP_DR_REDUCE)) {
/* setup DR reduction for moduli of the form B**k - b */
mp_dr_setup(P, &mp);
redux = mp_dr_reduce;
} else {
err = MP_VAL;
goto LBL_M;
}
} else if (MP_HAS(MP_REDUCE_2K_SETUP) && MP_HAS(MP_REDUCE_2K)) {
/* setup DR reduction for moduli of the form 2**k - b */
if ((err = mp_reduce_2k_setup(P, &mp)) != MP_OKAY) goto LBL_M;
redux = mp_reduce_2k;
} else {
err = MP_VAL;
goto LBL_M;
}
/* setup result */
if ((err = mp_init_size(&res, P->alloc)) != MP_OKAY) goto LBL_M;
/* create M table
*
*
* The first half of the table is not computed though accept for M[0] and M[1]
*/
if (redmode == 0) {
if (MP_HAS(MP_MONTGOMERY_CALC_NORMALIZATION)) {
/* now we need R mod m */
if ((err = mp_montgomery_calc_normalization(&res, P)) != MP_OKAY) goto LBL_RES;
/* now set M[1] to G * R mod m */
if ((err = mp_mulmod(G, &res, P, &M[1])) != MP_OKAY) goto LBL_RES;
} else {
err = MP_VAL;
goto LBL_RES;
}
} else {
mp_set(&res, 1uL);
if ((err = mp_mod(G, P, &M[1])) != MP_OKAY) goto LBL_RES;
}
/* compute the value at M[1<<(winsize-1)] by squaring M[1] (winsize-1) times */
if ((err = mp_copy(&M[1], &M[(size_t)1 << (winsize - 1)])) != MP_OKAY) goto LBL_RES;
for (x = 0; x < (winsize - 1); x++) {
if ((err = mp_sqr(&M[(size_t)1 << (winsize - 1)], &M[(size_t)1 << (winsize - 1)])) != MP_OKAY) goto LBL_RES;
if ((err = redux(&M[(size_t)1 << (winsize - 1)], P, mp)) != MP_OKAY) goto LBL_RES;
}
/* create upper table */
for (x = (1 << (winsize - 1)) + 1; x < (1 << winsize); x++) {
if ((err = mp_mul(&M[x - 1], &M[1], &M[x])) != MP_OKAY) goto LBL_RES;
if ((err = redux(&M[x], P, mp)) != MP_OKAY) goto LBL_RES;
}
/* set initial mode and bit cnt */
mode = 0;
bitcnt = 1;
buf = 0;
digidx = X->used - 1;
bitcpy = 0;
bitbuf = 0;
for (;;) {
/* grab next digit as required */
if (--bitcnt == 0) {
/* if digidx == -1 we are out of digits so break */
if (digidx == -1) {
break;
}
/* read next digit and reset bitcnt */
buf = X->dp[digidx--];
bitcnt = (int)MP_DIGIT_BIT;
}
/* grab the next msb from the exponent */
y = (mp_digit)(buf >> (MP_DIGIT_BIT - 1)) & 1uL;
buf <<= (mp_digit)1;
/* if the bit is zero and mode == 0 then we ignore it
* These represent the leading zero bits before the first 1 bit
* in the exponent. Technically this opt is not required but it
* does lower the # of trivial squaring/reductions used
*/
if ((mode == 0) && (y == 0)) {
continue;
}
/* if the bit is zero and mode == 1 then we square */
if ((mode == 1) && (y == 0)) {
if ((err = mp_sqr(&res, &res)) != MP_OKAY) goto LBL_RES;
if ((err = redux(&res, P, mp)) != MP_OKAY) goto LBL_RES;
continue;
}
/* else we add it to the window */
bitbuf |= (y << (winsize - ++bitcpy));
mode = 2;
if (bitcpy == winsize) {
/* ok window is filled so square as required and multiply */
/* square first */
for (x = 0; x < winsize; x++) {
if ((err = mp_sqr(&res, &res)) != MP_OKAY) goto LBL_RES;
if ((err = redux(&res, P, mp)) != MP_OKAY) goto LBL_RES;
}
/* then multiply */
if ((err = mp_mul(&res, &M[bitbuf], &res)) != MP_OKAY) goto LBL_RES;
if ((err = redux(&res, P, mp)) != MP_OKAY) goto LBL_RES;
/* empty window and reset */
bitcpy = 0;
bitbuf = 0;
mode = 1;
}
}
/* if bits remain then square/multiply */
if ((mode == 2) && (bitcpy > 0)) {
/* square then multiply if the bit is set */
for (x = 0; x < bitcpy; x++) {
if ((err = mp_sqr(&res, &res)) != MP_OKAY) goto LBL_RES;
if ((err = redux(&res, P, mp)) != MP_OKAY) goto LBL_RES;
/* get next bit of the window */
bitbuf <<= 1;
if ((bitbuf & (1 << winsize)) != 0) {
/* then multiply */
if ((err = mp_mul(&res, &M[1], &res)) != MP_OKAY) goto LBL_RES;
if ((err = redux(&res, P, mp)) != MP_OKAY) goto LBL_RES;
}
}
}
if (redmode == 0) {
/* fixup result if Montgomery reduction is used
* recall that any value in a Montgomery system is
* actually multiplied by R mod n. So we have
* to reduce one more time to cancel out the factor
* of R.
*/
if ((err = redux(&res, P, mp)) != MP_OKAY) goto LBL_RES;
}
/* swap res with Y */
mp_exch(&res, Y);
err = MP_OKAY;
LBL_RES:
mp_clear(&res);
LBL_M:
mp_clear(&M[1]);
for (x = 1<<(winsize-1); x < (1 << winsize); x++) {
mp_clear(&M[x]);
}
return err;
}
#endif
|
Changes to libtommath/bn_s_mp_get_bit.c.
1 2 3 4 5 6 7 | #include "tommath_private.h" #ifdef BN_S_MP_GET_BIT_C /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ /* Get bit at position b and return MP_YES if the bit is 1, MP_NO if it is 0 */ | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
#include "tommath_private.h"
#ifdef BN_S_MP_GET_BIT_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* Get bit at position b and return MP_YES if the bit is 1, MP_NO if it is 0 */
mp_bool s_mp_get_bit(const mp_int *a, unsigned int b)
{
mp_digit bit;
int limb = (int)(b / MP_DIGIT_BIT);
if (limb >= a->used) {
return MP_NO;
}
bit = (mp_digit)1 << (b % MP_DIGIT_BIT);
return ((a->dp[limb] & bit) != 0u) ? MP_YES : MP_NO;
}
#endif
|
Added libtommath/bn_s_mp_invmod_fast.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 |
#include "tommath_private.h"
#ifdef BN_S_MP_INVMOD_FAST_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* computes the modular inverse via binary extended euclidean algorithm,
* that is c = 1/a mod b
*
* Based on slow invmod except this is optimized for the case where b is
* odd as per HAC Note 14.64 on pp. 610
*/
mp_err s_mp_invmod_fast(const mp_int *a, const mp_int *b, mp_int *c)
{
mp_int x, y, u, v, B, D;
mp_sign neg;
mp_err err;
/* 2. [modified] b must be odd */
if (MP_IS_EVEN(b)) {
return MP_VAL;
}
/* init all our temps */
if ((err = mp_init_multi(&x, &y, &u, &v, &B, &D, NULL)) != MP_OKAY) {
return err;
}
/* x == modulus, y == value to invert */
if ((err = mp_copy(b, &x)) != MP_OKAY) goto LBL_ERR;
/* we need y = |a| */
if ((err = mp_mod(a, b, &y)) != MP_OKAY) goto LBL_ERR;
/* if one of x,y is zero return an error! */
if (MP_IS_ZERO(&x) || MP_IS_ZERO(&y)) {
err = MP_VAL;
goto LBL_ERR;
}
/* 3. u=x, v=y, A=1, B=0, C=0,D=1 */
if ((err = mp_copy(&x, &u)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_copy(&y, &v)) != MP_OKAY) goto LBL_ERR;
mp_set(&D, 1uL);
top:
/* 4. while u is even do */
while (MP_IS_EVEN(&u)) {
/* 4.1 u = u/2 */
if ((err = mp_div_2(&u, &u)) != MP_OKAY) goto LBL_ERR;
/* 4.2 if B is odd then */
if (MP_IS_ODD(&B)) {
if ((err = mp_sub(&B, &x, &B)) != MP_OKAY) goto LBL_ERR;
}
/* B = B/2 */
if ((err = mp_div_2(&B, &B)) != MP_OKAY) goto LBL_ERR;
}
/* 5. while v is even do */
while (MP_IS_EVEN(&v)) {
/* 5.1 v = v/2 */
if ((err = mp_div_2(&v, &v)) != MP_OKAY) goto LBL_ERR;
/* 5.2 if D is odd then */
if (MP_IS_ODD(&D)) {
/* D = (D-x)/2 */
if ((err = mp_sub(&D, &x, &D)) != MP_OKAY) goto LBL_ERR;
}
/* D = D/2 */
if ((err = mp_div_2(&D, &D)) != MP_OKAY) goto LBL_ERR;
}
/* 6. if u >= v then */
if (mp_cmp(&u, &v) != MP_LT) {
/* u = u - v, B = B - D */
if ((err = mp_sub(&u, &v, &u)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_sub(&B, &D, &B)) != MP_OKAY) goto LBL_ERR;
} else {
/* v - v - u, D = D - B */
if ((err = mp_sub(&v, &u, &v)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_sub(&D, &B, &D)) != MP_OKAY) goto LBL_ERR;
}
/* if not zero goto step 4 */
if (!MP_IS_ZERO(&u)) {
goto top;
}
/* now a = C, b = D, gcd == g*v */
/* if v != 1 then there is no inverse */
if (mp_cmp_d(&v, 1uL) != MP_EQ) {
err = MP_VAL;
goto LBL_ERR;
}
/* b is now the inverse */
neg = a->sign;
while (D.sign == MP_NEG) {
if ((err = mp_add(&D, b, &D)) != MP_OKAY) goto LBL_ERR;
}
/* too big */
while (mp_cmp_mag(&D, b) != MP_LT) {
if ((err = mp_sub(&D, b, &D)) != MP_OKAY) goto LBL_ERR;
}
mp_exch(&D, c);
c->sign = neg;
err = MP_OKAY;
LBL_ERR:
mp_clear_multi(&x, &y, &u, &v, &B, &D, NULL);
return err;
}
#endif
|
Added libtommath/bn_s_mp_invmod_slow.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 |
#include "tommath_private.h"
#ifdef BN_S_MP_INVMOD_SLOW_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* hac 14.61, pp608 */
mp_err s_mp_invmod_slow(const mp_int *a, const mp_int *b, mp_int *c)
{
mp_int x, y, u, v, A, B, C, D;
mp_err err;
/* b cannot be negative */
if ((b->sign == MP_NEG) || MP_IS_ZERO(b)) {
return MP_VAL;
}
/* init temps */
if ((err = mp_init_multi(&x, &y, &u, &v,
&A, &B, &C, &D, NULL)) != MP_OKAY) {
return err;
}
/* x = a, y = b */
if ((err = mp_mod(a, b, &x)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_copy(b, &y)) != MP_OKAY) goto LBL_ERR;
/* 2. [modified] if x,y are both even then return an error! */
if (MP_IS_EVEN(&x) && MP_IS_EVEN(&y)) {
err = MP_VAL;
goto LBL_ERR;
}
/* 3. u=x, v=y, A=1, B=0, C=0,D=1 */
if ((err = mp_copy(&x, &u)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_copy(&y, &v)) != MP_OKAY) goto LBL_ERR;
mp_set(&A, 1uL);
mp_set(&D, 1uL);
top:
/* 4. while u is even do */
while (MP_IS_EVEN(&u)) {
/* 4.1 u = u/2 */
if ((err = mp_div_2(&u, &u)) != MP_OKAY) goto LBL_ERR;
/* 4.2 if A or B is odd then */
if (MP_IS_ODD(&A) || MP_IS_ODD(&B)) {
/* A = (A+y)/2, B = (B-x)/2 */
if ((err = mp_add(&A, &y, &A)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_sub(&B, &x, &B)) != MP_OKAY) goto LBL_ERR;
}
/* A = A/2, B = B/2 */
if ((err = mp_div_2(&A, &A)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_div_2(&B, &B)) != MP_OKAY) goto LBL_ERR;
}
/* 5. while v is even do */
while (MP_IS_EVEN(&v)) {
/* 5.1 v = v/2 */
if ((err = mp_div_2(&v, &v)) != MP_OKAY) goto LBL_ERR;
/* 5.2 if C or D is odd then */
if (MP_IS_ODD(&C) || MP_IS_ODD(&D)) {
/* C = (C+y)/2, D = (D-x)/2 */
if ((err = mp_add(&C, &y, &C)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_sub(&D, &x, &D)) != MP_OKAY) goto LBL_ERR;
}
/* C = C/2, D = D/2 */
if ((err = mp_div_2(&C, &C)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_div_2(&D, &D)) != MP_OKAY) goto LBL_ERR;
}
/* 6. if u >= v then */
if (mp_cmp(&u, &v) != MP_LT) {
/* u = u - v, A = A - C, B = B - D */
if ((err = mp_sub(&u, &v, &u)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_sub(&A, &C, &A)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_sub(&B, &D, &B)) != MP_OKAY) goto LBL_ERR;
} else {
/* v - v - u, C = C - A, D = D - B */
if ((err = mp_sub(&v, &u, &v)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_sub(&C, &A, &C)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_sub(&D, &B, &D)) != MP_OKAY) goto LBL_ERR;
}
/* if not zero goto step 4 */
if (!MP_IS_ZERO(&u)) {
goto top;
}
/* now a = C, b = D, gcd == g*v */
/* if v != 1 then there is no inverse */
if (mp_cmp_d(&v, 1uL) != MP_EQ) {
err = MP_VAL;
goto LBL_ERR;
}
/* if its too low */
while (mp_cmp_d(&C, 0uL) == MP_LT) {
if ((err = mp_add(&C, b, &C)) != MP_OKAY) goto LBL_ERR;
}
/* too big */
while (mp_cmp_mag(&C, b) != MP_LT) {
if ((err = mp_sub(&C, b, &C)) != MP_OKAY) goto LBL_ERR;
}
/* C is now the inverse */
mp_exch(&C, c);
err = MP_OKAY;
LBL_ERR:
mp_clear_multi(&x, &y, &u, &v, &A, &B, &C, &D, NULL);
return err;
}
#endif
|
Added libtommath/bn_s_mp_karatsuba_mul.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 |
#include "tommath_private.h"
#ifdef BN_S_MP_KARATSUBA_MUL_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* c = |a| * |b| using Karatsuba Multiplication using
* three half size multiplications
*
* Let B represent the radix [e.g. 2**MP_DIGIT_BIT] and
* let n represent half of the number of digits in
* the min(a,b)
*
* a = a1 * B**n + a0
* b = b1 * B**n + b0
*
* Then, a * b =>
a1b1 * B**2n + ((a1 + a0)(b1 + b0) - (a0b0 + a1b1)) * B + a0b0
*
* Note that a1b1 and a0b0 are used twice and only need to be
* computed once. So in total three half size (half # of
* digit) multiplications are performed, a0b0, a1b1 and
* (a1+b1)(a0+b0)
*
* Note that a multiplication of half the digits requires
* 1/4th the number of single precision multiplications so in
* total after one call 25% of the single precision multiplications
* are saved. Note also that the call to mp_mul can end up back
* in this function if the a0, a1, b0, or b1 are above the threshold.
* This is known as divide-and-conquer and leads to the famous
* O(N**lg(3)) or O(N**1.584) work which is asymptopically lower than
* the standard O(N**2) that the baseline/comba methods use.
* Generally though the overhead of this method doesn't pay off
* until a certain size (N ~ 80) is reached.
*/
mp_err s_mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c)
{
mp_int x0, x1, y0, y1, t1, x0y0, x1y1;
int B;
mp_err err = MP_MEM; /* default the return code to an error */
/* min # of digits */
B = MP_MIN(a->used, b->used);
/* now divide in two */
B = B >> 1;
/* init copy all the temps */
if (mp_init_size(&x0, B) != MP_OKAY) {
goto LBL_ERR;
}
if (mp_init_size(&x1, a->used - B) != MP_OKAY) {
goto X0;
}
if (mp_init_size(&y0, B) != MP_OKAY) {
goto X1;
}
if (mp_init_size(&y1, b->used - B) != MP_OKAY) {
goto Y0;
}
/* init temps */
if (mp_init_size(&t1, B * 2) != MP_OKAY) {
goto Y1;
}
if (mp_init_size(&x0y0, B * 2) != MP_OKAY) {
goto T1;
}
if (mp_init_size(&x1y1, B * 2) != MP_OKAY) {
goto X0Y0;
}
/* now shift the digits */
x0.used = y0.used = B;
x1.used = a->used - B;
y1.used = b->used - B;
{
int x;
mp_digit *tmpa, *tmpb, *tmpx, *tmpy;
/* we copy the digits directly instead of using higher level functions
* since we also need to shift the digits
*/
tmpa = a->dp;
tmpb = b->dp;
tmpx = x0.dp;
tmpy = y0.dp;
for (x = 0; x < B; x++) {
*tmpx++ = *tmpa++;
*tmpy++ = *tmpb++;
}
tmpx = x1.dp;
for (x = B; x < a->used; x++) {
*tmpx++ = *tmpa++;
}
tmpy = y1.dp;
for (x = B; x < b->used; x++) {
*tmpy++ = *tmpb++;
}
}
/* only need to clamp the lower words since by definition the
* upper words x1/y1 must have a known number of digits
*/
mp_clamp(&x0);
mp_clamp(&y0);
/* now calc the products x0y0 and x1y1 */
/* after this x0 is no longer required, free temp [x0==t2]! */
if (mp_mul(&x0, &y0, &x0y0) != MP_OKAY) {
goto X1Y1; /* x0y0 = x0*y0 */
}
if (mp_mul(&x1, &y1, &x1y1) != MP_OKAY) {
goto X1Y1; /* x1y1 = x1*y1 */
}
/* now calc x1+x0 and y1+y0 */
if (s_mp_add(&x1, &x0, &t1) != MP_OKAY) {
goto X1Y1; /* t1 = x1 - x0 */
}
if (s_mp_add(&y1, &y0, &x0) != MP_OKAY) {
goto X1Y1; /* t2 = y1 - y0 */
}
if (mp_mul(&t1, &x0, &t1) != MP_OKAY) {
goto X1Y1; /* t1 = (x1 + x0) * (y1 + y0) */
}
/* add x0y0 */
if (mp_add(&x0y0, &x1y1, &x0) != MP_OKAY) {
goto X1Y1; /* t2 = x0y0 + x1y1 */
}
if (s_mp_sub(&t1, &x0, &t1) != MP_OKAY) {
goto X1Y1; /* t1 = (x1+x0)*(y1+y0) - (x1y1 + x0y0) */
}
/* shift by B */
if (mp_lshd(&t1, B) != MP_OKAY) {
goto X1Y1; /* t1 = (x0y0 + x1y1 - (x1-x0)*(y1-y0))<<B */
}
if (mp_lshd(&x1y1, B * 2) != MP_OKAY) {
goto X1Y1; /* x1y1 = x1y1 << 2*B */
}
if (mp_add(&x0y0, &t1, &t1) != MP_OKAY) {
goto X1Y1; /* t1 = x0y0 + t1 */
}
if (mp_add(&t1, &x1y1, c) != MP_OKAY) {
goto X1Y1; /* t1 = x0y0 + t1 + x1y1 */
}
/* Algorithm succeeded set the return code to MP_OKAY */
err = MP_OKAY;
X1Y1:
mp_clear(&x1y1);
X0Y0:
mp_clear(&x0y0);
T1:
mp_clear(&t1);
Y1:
mp_clear(&y1);
Y0:
mp_clear(&y0);
X1:
mp_clear(&x1);
X0:
mp_clear(&x0);
LBL_ERR:
return err;
}
#endif
|
Added libtommath/bn_s_mp_karatsuba_sqr.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 |
#include "tommath_private.h"
#ifdef BN_S_MP_KARATSUBA_SQR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* Karatsuba squaring, computes b = a*a using three
* half size squarings
*
* See comments of karatsuba_mul for details. It
* is essentially the same algorithm but merely
* tuned to perform recursive squarings.
*/
mp_err s_mp_karatsuba_sqr(const mp_int *a, mp_int *b)
{
mp_int x0, x1, t1, t2, x0x0, x1x1;
int B;
mp_err err = MP_MEM;
/* min # of digits */
B = a->used;
/* now divide in two */
B = B >> 1;
/* init copy all the temps */
if (mp_init_size(&x0, B) != MP_OKAY)
goto LBL_ERR;
if (mp_init_size(&x1, a->used - B) != MP_OKAY)
goto X0;
/* init temps */
if (mp_init_size(&t1, a->used * 2) != MP_OKAY)
goto X1;
if (mp_init_size(&t2, a->used * 2) != MP_OKAY)
goto T1;
if (mp_init_size(&x0x0, B * 2) != MP_OKAY)
goto T2;
if (mp_init_size(&x1x1, (a->used - B) * 2) != MP_OKAY)
goto X0X0;
{
int x;
mp_digit *dst, *src;
src = a->dp;
/* now shift the digits */
dst = x0.dp;
for (x = 0; x < B; x++) {
*dst++ = *src++;
}
dst = x1.dp;
for (x = B; x < a->used; x++) {
*dst++ = *src++;
}
}
x0.used = B;
x1.used = a->used - B;
mp_clamp(&x0);
/* now calc the products x0*x0 and x1*x1 */
if (mp_sqr(&x0, &x0x0) != MP_OKAY)
goto X1X1; /* x0x0 = x0*x0 */
if (mp_sqr(&x1, &x1x1) != MP_OKAY)
goto X1X1; /* x1x1 = x1*x1 */
/* now calc (x1+x0)**2 */
if (s_mp_add(&x1, &x0, &t1) != MP_OKAY)
goto X1X1; /* t1 = x1 - x0 */
if (mp_sqr(&t1, &t1) != MP_OKAY)
goto X1X1; /* t1 = (x1 - x0) * (x1 - x0) */
/* add x0y0 */
if (s_mp_add(&x0x0, &x1x1, &t2) != MP_OKAY)
goto X1X1; /* t2 = x0x0 + x1x1 */
if (s_mp_sub(&t1, &t2, &t1) != MP_OKAY)
goto X1X1; /* t1 = (x1+x0)**2 - (x0x0 + x1x1) */
/* shift by B */
if (mp_lshd(&t1, B) != MP_OKAY)
goto X1X1; /* t1 = (x0x0 + x1x1 - (x1-x0)*(x1-x0))<<B */
if (mp_lshd(&x1x1, B * 2) != MP_OKAY)
goto X1X1; /* x1x1 = x1x1 << 2*B */
if (mp_add(&x0x0, &t1, &t1) != MP_OKAY)
goto X1X1; /* t1 = x0x0 + t1 */
if (mp_add(&t1, &x1x1, b) != MP_OKAY)
goto X1X1; /* t1 = x0x0 + t1 + x1x1 */
err = MP_OKAY;
X1X1:
mp_clear(&x1x1);
X0X0:
mp_clear(&x0x0);
T2:
mp_clear(&t2);
T1:
mp_clear(&t1);
X1:
mp_clear(&x1);
X0:
mp_clear(&x0);
LBL_ERR:
return err;
}
#endif
|
Added libtommath/bn_s_mp_montgomery_reduce_fast.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 |
#include "tommath_private.h"
#ifdef BN_S_MP_MONTGOMERY_REDUCE_FAST_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* computes xR**-1 == x (mod N) via Montgomery Reduction
*
* This is an optimized implementation of montgomery_reduce
* which uses the comba method to quickly calculate the columns of the
* reduction.
*
* Based on Algorithm 14.32 on pp.601 of HAC.
*/
mp_err s_mp_montgomery_reduce_fast(mp_int *x, const mp_int *n, mp_digit rho)
{
int ix, olduse;
mp_err err;
mp_word W[MP_WARRAY];
if (x->used > MP_WARRAY) {
return MP_VAL;
}
/* get old used count */
olduse = x->used;
/* grow a as required */
if (x->alloc < (n->used + 1)) {
if ((err = mp_grow(x, n->used + 1)) != MP_OKAY) {
return err;
}
}
/* first we have to get the digits of the input into
* an array of double precision words W[...]
*/
{
mp_word *_W;
mp_digit *tmpx;
/* alias for the W[] array */
_W = W;
/* alias for the digits of x*/
tmpx = x->dp;
/* copy the digits of a into W[0..a->used-1] */
for (ix = 0; ix < x->used; ix++) {
*_W++ = *tmpx++;
}
/* zero the high words of W[a->used..m->used*2] */
if (ix < ((n->used * 2) + 1)) {
MP_ZERO_BUFFER(_W, sizeof(mp_word) * (size_t)(((n->used * 2) + 1) - ix));
}
}
/* now we proceed to zero successive digits
* from the least significant upwards
*/
for (ix = 0; ix < n->used; ix++) {
/* mu = ai * m' mod b
*
* We avoid a double precision multiplication (which isn't required)
* by casting the value down to a mp_digit. Note this requires
* that W[ix-1] have the carry cleared (see after the inner loop)
*/
mp_digit mu;
mu = ((W[ix] & MP_MASK) * rho) & MP_MASK;
/* a = a + mu * m * b**i
*
* This is computed in place and on the fly. The multiplication
* by b**i is handled by offseting which columns the results
* are added to.
*
* Note the comba method normally doesn't handle carries in the
* inner loop In this case we fix the carry from the previous
* column since the Montgomery reduction requires digits of the
* result (so far) [see above] to work. This is
* handled by fixing up one carry after the inner loop. The
* carry fixups are done in order so after these loops the
* first m->used words of W[] have the carries fixed
*/
{
int iy;
mp_digit *tmpn;
mp_word *_W;
/* alias for the digits of the modulus */
tmpn = n->dp;
/* Alias for the columns set by an offset of ix */
_W = W + ix;
/* inner loop */
for (iy = 0; iy < n->used; iy++) {
*_W++ += (mp_word)mu * (mp_word)*tmpn++;
}
}
/* now fix carry for next digit, W[ix+1] */
W[ix + 1] += W[ix] >> (mp_word)MP_DIGIT_BIT;
}
/* now we have to propagate the carries and
* shift the words downward [all those least
* significant digits we zeroed].
*/
{
mp_digit *tmpx;
mp_word *_W, *_W1;
/* nox fix rest of carries */
/* alias for current word */
_W1 = W + ix;
/* alias for next word, where the carry goes */
_W = W + ++ix;
for (; ix < ((n->used * 2) + 1); ix++) {
*_W++ += *_W1++ >> (mp_word)MP_DIGIT_BIT;
}
/* copy out, A = A/b**n
*
* The result is A/b**n but instead of converting from an
* array of mp_word to mp_digit than calling mp_rshd
* we just copy them in the right order
*/
/* alias for destination word */
tmpx = x->dp;
/* alias for shifted double precision result */
_W = W + n->used;
for (ix = 0; ix < (n->used + 1); ix++) {
*tmpx++ = *_W++ & (mp_word)MP_MASK;
}
/* zero oldused digits, if the input a was larger than
* m->used+1 we'll have to clear the digits
*/
MP_ZERO_DIGITS(tmpx, olduse - ix);
}
/* set the max used and clamp */
x->used = n->used + 1;
mp_clamp(x);
/* if A >= m then A = A - m */
if (mp_cmp_mag(x, n) != MP_LT) {
return s_mp_sub(x, n, x);
}
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_s_mp_mul_digs.c.
1 2 | #include "tommath_private.h" #ifdef BN_S_MP_MUL_DIGS_C | | < < < < < < < < | < | > | | | < | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
#include "tommath_private.h"
#ifdef BN_S_MP_MUL_DIGS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* multiplies |a| * |b| and only computes upto digs digits of result
* HAC pp. 595, Algorithm 14.12 Modified so you can control how
* many digits of output are created.
*/
mp_err s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs)
{
mp_int t;
mp_err err;
int pa, pb, ix, iy;
mp_digit u;
mp_word r;
mp_digit tmpx, *tmpt, *tmpy;
/* can we use the fast multiplier? */
if ((digs < MP_WARRAY) &&
(MP_MIN(a->used, b->used) < MP_MAXFAST)) {
return s_mp_mul_digs_fast(a, b, c, digs);
}
if ((err = mp_init_size(&t, digs)) != MP_OKAY) {
return err;
}
t.used = digs;
/* compute the digits of the product directly */
pa = a->used;
for (ix = 0; ix < pa; ix++) {
/* set the carry to zero */
u = 0;
/* limit ourselves to making digs digits of output */
pb = MP_MIN(b->used, digs - ix);
/* setup some aliases */
/* copy of the digit from a used within the nested loop */
tmpx = a->dp[ix];
/* an alias for the destination shifted ix places */
tmpt = t.dp + ix;
|
| ︙ | ︙ | |||
62 63 64 65 66 67 68 |
((mp_word)tmpx * (mp_word)*tmpy++) +
(mp_word)u;
/* the new column is the lower part of the result */
*tmpt++ = (mp_digit)(r & (mp_word)MP_MASK);
/* get the carry word from the result */
| | < < < < | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 |
((mp_word)tmpx * (mp_word)*tmpy++) +
(mp_word)u;
/* the new column is the lower part of the result */
*tmpt++ = (mp_digit)(r & (mp_word)MP_MASK);
/* get the carry word from the result */
u = (mp_digit)(r >> (mp_word)MP_DIGIT_BIT);
}
/* set carry if it is placed below digs */
if ((ix + iy) < digs) {
*tmpt = u;
}
}
mp_clamp(&t);
mp_exch(&t, c);
mp_clear(&t);
return MP_OKAY;
}
#endif
|
Added libtommath/bn_s_mp_mul_digs_fast.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 |
#include "tommath_private.h"
#ifdef BN_S_MP_MUL_DIGS_FAST_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* Fast (comba) multiplier
*
* This is the fast column-array [comba] multiplier. It is
* designed to compute the columns of the product first
* then handle the carries afterwards. This has the effect
* of making the nested loops that compute the columns very
* simple and schedulable on super-scalar processors.
*
* This has been modified to produce a variable number of
* digits of output so if say only a half-product is required
* you don't have to compute the upper half (a feature
* required for fast Barrett reduction).
*
* Based on Algorithm 14.12 on pp.595 of HAC.
*
*/
mp_err s_mp_mul_digs_fast(const mp_int *a, const mp_int *b, mp_int *c, int digs)
{
int olduse, pa, ix, iz;
mp_err err;
mp_digit W[MP_WARRAY];
mp_word _W;
/* grow the destination as required */
if (c->alloc < digs) {
if ((err = mp_grow(c, digs)) != MP_OKAY) {
return err;
}
}
/* number of output digits to produce */
pa = MP_MIN(digs, a->used + b->used);
/* clear the carry */
_W = 0;
for (ix = 0; ix < pa; ix++) {
int tx, ty;
int iy;
mp_digit *tmpx, *tmpy;
/* get offsets into the two bignums */
ty = MP_MIN(b->used-1, ix);
tx = ix - ty;
/* setup temp aliases */
tmpx = a->dp + tx;
tmpy = b->dp + ty;
/* this is the number of times the loop will iterrate, essentially
while (tx++ < a->used && ty-- >= 0) { ... }
*/
iy = MP_MIN(a->used-tx, ty+1);
/* execute loop */
for (iz = 0; iz < iy; ++iz) {
_W += (mp_word)*tmpx++ * (mp_word)*tmpy--;
}
/* store term */
W[ix] = (mp_digit)_W & MP_MASK;
/* make next carry */
_W = _W >> (mp_word)MP_DIGIT_BIT;
}
/* setup dest */
olduse = c->used;
c->used = pa;
{
mp_digit *tmpc;
tmpc = c->dp;
for (ix = 0; ix < pa; ix++) {
/* now extract the previous digit [below the carry] */
*tmpc++ = W[ix];
}
/* clear unused digits [that existed in the old copy of c] */
MP_ZERO_DIGITS(tmpc, olduse - ix);
}
mp_clamp(c);
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_s_mp_mul_high_digs.c.
1 2 | #include "tommath_private.h" #ifdef BN_S_MP_MUL_HIGH_DIGS_C | | < < < < < < < < | < | | | > | | | | | < | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
#include "tommath_private.h"
#ifdef BN_S_MP_MUL_HIGH_DIGS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* multiplies |a| * |b| and does not compute the lower digs digits
* [meant to get the higher part of the product]
*/
mp_err s_mp_mul_high_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs)
{
mp_int t;
int pa, pb, ix, iy;
mp_err err;
mp_digit u;
mp_word r;
mp_digit tmpx, *tmpt, *tmpy;
/* can we use the fast multiplier? */
if (MP_HAS(S_MP_MUL_HIGH_DIGS_FAST)
&& ((a->used + b->used + 1) < MP_WARRAY)
&& (MP_MIN(a->used, b->used) < MP_MAXFAST)) {
return s_mp_mul_high_digs_fast(a, b, c, digs);
}
if ((err = mp_init_size(&t, a->used + b->used + 1)) != MP_OKAY) {
return err;
}
t.used = a->used + b->used + 1;
pa = a->used;
pb = b->used;
for (ix = 0; ix < pa; ix++) {
/* clear the carry */
|
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
((mp_word)tmpx * (mp_word)*tmpy++) +
(mp_word)u;
/* get the lower part */
*tmpt++ = (mp_digit)(r & (mp_word)MP_MASK);
/* carry the carry */
| | < < < < | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 |
((mp_word)tmpx * (mp_word)*tmpy++) +
(mp_word)u;
/* get the lower part */
*tmpt++ = (mp_digit)(r & (mp_word)MP_MASK);
/* carry the carry */
u = (mp_digit)(r >> (mp_word)MP_DIGIT_BIT);
}
*tmpt = u;
}
mp_clamp(&t);
mp_exch(&t, c);
mp_clear(&t);
return MP_OKAY;
}
#endif
|
Added libtommath/bn_s_mp_mul_high_digs_fast.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 |
#include "tommath_private.h"
#ifdef BN_S_MP_MUL_HIGH_DIGS_FAST_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* this is a modified version of s_mp_mul_digs_fast that only produces
* output digits *above* digs. See the comments for s_mp_mul_digs_fast
* to see how it works.
*
* This is used in the Barrett reduction since for one of the multiplications
* only the higher digits were needed. This essentially halves the work.
*
* Based on Algorithm 14.12 on pp.595 of HAC.
*/
mp_err s_mp_mul_high_digs_fast(const mp_int *a, const mp_int *b, mp_int *c, int digs)
{
int olduse, pa, ix, iz;
mp_err err;
mp_digit W[MP_WARRAY];
mp_word _W;
/* grow the destination as required */
pa = a->used + b->used;
if (c->alloc < pa) {
if ((err = mp_grow(c, pa)) != MP_OKAY) {
return err;
}
}
/* number of output digits to produce */
pa = a->used + b->used;
_W = 0;
for (ix = digs; ix < pa; ix++) {
int tx, ty, iy;
mp_digit *tmpx, *tmpy;
/* get offsets into the two bignums */
ty = MP_MIN(b->used-1, ix);
tx = ix - ty;
/* setup temp aliases */
tmpx = a->dp + tx;
tmpy = b->dp + ty;
/* this is the number of times the loop will iterrate, essentially its
while (tx++ < a->used && ty-- >= 0) { ... }
*/
iy = MP_MIN(a->used-tx, ty+1);
/* execute loop */
for (iz = 0; iz < iy; iz++) {
_W += (mp_word)*tmpx++ * (mp_word)*tmpy--;
}
/* store term */
W[ix] = (mp_digit)_W & MP_MASK;
/* make next carry */
_W = _W >> (mp_word)MP_DIGIT_BIT;
}
/* setup dest */
olduse = c->used;
c->used = pa;
{
mp_digit *tmpc;
tmpc = c->dp + digs;
for (ix = digs; ix < pa; ix++) {
/* now extract the previous digit [below the carry] */
*tmpc++ = W[ix];
}
/* clear unused digits [that existed in the old copy of c] */
MP_ZERO_DIGITS(tmpc, olduse - ix);
}
mp_clamp(c);
return MP_OKAY;
}
#endif
|
Added libtommath/bn_s_mp_prime_is_divisible.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
#include "tommath_private.h"
#ifdef BN_S_MP_PRIME_IS_DIVISIBLE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* determines if an integers is divisible by one
* of the first PRIME_SIZE primes or not
*
* sets result to 0 if not, 1 if yes
*/
mp_err s_mp_prime_is_divisible(const mp_int *a, mp_bool *result)
{
int ix;
mp_err err;
mp_digit res;
/* default to not */
*result = MP_NO;
for (ix = 0; ix < PRIVATE_MP_PRIME_TAB_SIZE; ix++) {
/* what is a mod LBL_prime_tab[ix] */
if ((err = mp_mod_d(a, s_mp_prime_tab[ix], &res)) != MP_OKAY) {
return err;
}
/* is the residue zero? */
if (res == 0u) {
*result = MP_YES;
return MP_OKAY;
}
}
return MP_OKAY;
}
#endif
|
Added libtommath/bn_s_mp_rand_jenkins.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
#include "tommath_private.h"
#ifdef BN_S_MP_RAND_JENKINS_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* Bob Jenkins' http://burtleburtle.net/bob/rand/smallprng.html */
/* Chosen for speed and a good "mix" */
typedef struct {
uint64_t a;
uint64_t b;
uint64_t c;
uint64_t d;
} ranctx;
static ranctx jenkins_x;
#define rot(x,k) (((x)<<(k))|((x)>>(64-(k))))
static uint64_t s_rand_jenkins_val(void)
{
uint64_t e = jenkins_x.a - rot(jenkins_x.b, 7);
jenkins_x.a = jenkins_x.b ^ rot(jenkins_x.c, 13);
jenkins_x.b = jenkins_x.c + rot(jenkins_x.d, 37);
jenkins_x.c = jenkins_x.d + e;
jenkins_x.d = e + jenkins_x.a;
return jenkins_x.d;
}
void s_mp_rand_jenkins_init(uint64_t seed)
{
int i;
jenkins_x.a = 0xf1ea5eedULL;
jenkins_x.b = jenkins_x.c = jenkins_x.d = seed;
for (i = 0; i < 20; ++i) {
(void)s_rand_jenkins_val();
}
}
mp_err s_mp_rand_jenkins(void *p, size_t n)
{
char *q = (char *)p;
while (n > 0u) {
int i;
uint64_t x = s_rand_jenkins_val();
for (i = 0; (i < 8) && (n > 0u); ++i, --n) {
*q++ = (char)(x & 0xFFuLL);
x >>= 8;
}
}
return MP_OKAY;
}
#endif
|
Added libtommath/bn_s_mp_rand_platform.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 |
#include "tommath_private.h"
#ifdef BN_S_MP_RAND_PLATFORM_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* First the OS-specific special cases
* - *BSD
* - Windows
*/
#if defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__) || defined(__DragonFly__)
#define BN_S_READ_ARC4RANDOM_C
static mp_err s_read_arc4random(void *p, size_t n)
{
arc4random_buf(p, n);
return MP_OKAY;
}
#endif
#if defined(_WIN32) || defined(_WIN32_WCE)
#define BN_S_READ_WINCSP_C
#ifndef _WIN32_WINNT
#define _WIN32_WINNT 0x0400
#endif
#ifdef _WIN32_WCE
#define UNDER_CE
#define ARM
#endif
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
#include <wincrypt.h>
static mp_err s_read_wincsp(void *p, size_t n)
{
static HCRYPTPROV hProv = 0;
if (hProv == 0) {
HCRYPTPROV h = 0;
if (!CryptAcquireContext(&h, NULL, MS_DEF_PROV, PROV_RSA_FULL,
(CRYPT_VERIFYCONTEXT | CRYPT_MACHINE_KEYSET)) &&
!CryptAcquireContext(&h, NULL, MS_DEF_PROV, PROV_RSA_FULL,
CRYPT_VERIFYCONTEXT | CRYPT_MACHINE_KEYSET | CRYPT_NEWKEYSET)) {
return MP_ERR;
}
hProv = h;
}
return CryptGenRandom(hProv, (DWORD)n, (BYTE *)p) == TRUE ? MP_OKAY : MP_ERR;
}
#endif /* WIN32 */
#if !defined(BN_S_READ_WINCSP_C) && defined(__linux__) && defined(__GLIBC_PREREQ)
#if __GLIBC_PREREQ(2, 25)
#define BN_S_READ_GETRANDOM_C
#include <sys/random.h>
#include <errno.h>
static mp_err s_read_getrandom(void *p, size_t n)
{
char *q = (char *)p;
while (n > 0u) {
ssize_t ret = getrandom(q, n, 0);
if (ret < 0) {
if (errno == EINTR) {
continue;
}
return MP_ERR;
}
q += ret;
n -= (size_t)ret;
}
return MP_OKAY;
}
#endif
#endif
/* We assume all platforms besides windows provide "/dev/urandom".
* In case yours doesn't, define MP_NO_DEV_URANDOM at compile-time.
*/
#if !defined(BN_S_READ_WINCSP_C) && !defined(MP_NO_DEV_URANDOM)
#define BN_S_READ_URANDOM_C
#ifndef MP_DEV_URANDOM
#define MP_DEV_URANDOM "/dev/urandom"
#endif
#include <fcntl.h>
#include <errno.h>
#include <unistd.h>
static mp_err s_read_urandom(void *p, size_t n)
{
int fd;
char *q = (char *)p;
do {
fd = open(MP_DEV_URANDOM, O_RDONLY);
} while ((fd == -1) && (errno == EINTR));
if (fd == -1) return MP_ERR;
while (n > 0u) {
ssize_t ret = read(fd, p, n);
if (ret < 0) {
if (errno == EINTR) {
continue;
}
close(fd);
return MP_ERR;
}
q += ret;
n -= (size_t)ret;
}
close(fd);
return MP_OKAY;
}
#endif
#if defined(MP_PRNG_ENABLE_LTM_RNG)
#define BN_S_READ_LTM_RNG
unsigned long (*ltm_rng)(unsigned char *out, unsigned long outlen, void (*callback)(void));
void (*ltm_rng_callback)(void);
static mp_err s_read_ltm_rng(void *p, size_t n)
{
unsigned long res;
if (ltm_rng == NULL) return MP_ERR;
res = ltm_rng(p, n, ltm_rng_callback);
if (res != n) return MP_ERR;
return MP_OKAY;
}
#endif
mp_err s_read_arc4random(void *p, size_t n);
mp_err s_read_wincsp(void *p, size_t n);
mp_err s_read_getrandom(void *p, size_t n);
mp_err s_read_urandom(void *p, size_t n);
mp_err s_read_ltm_rng(void *p, size_t n);
mp_err s_mp_rand_platform(void *p, size_t n)
{
mp_err err = MP_ERR;
if ((err != MP_OKAY) && MP_HAS(S_READ_ARC4RANDOM)) err = s_read_arc4random(p, n);
if ((err != MP_OKAY) && MP_HAS(S_READ_WINCSP)) err = s_read_wincsp(p, n);
if ((err != MP_OKAY) && MP_HAS(S_READ_GETRANDOM)) err = s_read_getrandom(p, n);
if ((err != MP_OKAY) && MP_HAS(S_READ_URANDOM)) err = s_read_urandom(p, n);
if ((err != MP_OKAY) && MP_HAS(S_READ_LTM_RNG)) err = s_read_ltm_rng(p, n);
return err;
}
#endif
|
Added libtommath/bn_s_mp_reverse.c.
> > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
#include "tommath_private.h"
#ifdef BN_S_MP_REVERSE_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* reverse an array, used for radix code */
void s_mp_reverse(unsigned char *s, size_t len)
{
size_t ix, iy;
unsigned char t;
ix = 0u;
iy = len - 1u;
while (ix < iy) {
t = s[ix];
s[ix] = s[iy];
s[iy] = t;
++ix;
--iy;
}
}
#endif
|
Changes to libtommath/bn_s_mp_sqr.c.
1 2 | #include "tommath_private.h" #ifdef BN_S_MP_SQR_C | | < < < < < < < < | < | | | > | | | | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 |
#include "tommath_private.h"
#ifdef BN_S_MP_SQR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* low level squaring, b = a*a, HAC pp.596-597, Algorithm 14.16 */
mp_err s_mp_sqr(const mp_int *a, mp_int *b)
{
mp_int t;
int ix, iy, pa;
mp_err err;
mp_word r;
mp_digit u, tmpx, *tmpt;
pa = a->used;
if ((err = mp_init_size(&t, (2 * pa) + 1)) != MP_OKAY) {
return err;
}
/* default used is maximum possible size */
t.used = (2 * pa) + 1;
for (ix = 0; ix < pa; ix++) {
/* first calculate the digit at 2*ix */
/* calculate double precision result */
r = (mp_word)t.dp[2*ix] +
((mp_word)a->dp[ix] * (mp_word)a->dp[ix]);
/* store lower part in result */
t.dp[ix+ix] = (mp_digit)(r & (mp_word)MP_MASK);
/* get the carry */
u = (mp_digit)(r >> (mp_word)MP_DIGIT_BIT);
/* left hand side of A[ix] * A[iy] */
tmpx = a->dp[ix];
/* alias for where to store the results */
tmpt = t.dp + ((2 * ix) + 1);
for (iy = ix + 1; iy < pa; iy++) {
/* first calculate the product */
r = (mp_word)tmpx * (mp_word)a->dp[iy];
/* now calculate the double precision result, note we use
* addition instead of *2 since it's easier to optimize
*/
r = (mp_word)*tmpt + r + r + (mp_word)u;
/* store lower part */
*tmpt++ = (mp_digit)(r & (mp_word)MP_MASK);
/* get carry */
u = (mp_digit)(r >> (mp_word)MP_DIGIT_BIT);
}
/* propagate upwards */
while (u != 0uL) {
r = (mp_word)*tmpt + (mp_word)u;
*tmpt++ = (mp_digit)(r & (mp_word)MP_MASK);
u = (mp_digit)(r >> (mp_word)MP_DIGIT_BIT);
}
}
mp_clamp(&t);
mp_exch(&t, b);
mp_clear(&t);
return MP_OKAY;
}
#endif
|
Added libtommath/bn_s_mp_sqr_fast.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 |
#include "tommath_private.h"
#ifdef BN_S_MP_SQR_FAST_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* the jist of squaring...
* you do like mult except the offset of the tmpx [one that
* starts closer to zero] can't equal the offset of tmpy.
* So basically you set up iy like before then you min it with
* (ty-tx) so that it never happens. You double all those
* you add in the inner loop
After that loop you do the squares and add them in.
*/
mp_err s_mp_sqr_fast(const mp_int *a, mp_int *b)
{
int olduse, pa, ix, iz;
mp_digit W[MP_WARRAY], *tmpx;
mp_word W1;
mp_err err;
/* grow the destination as required */
pa = a->used + a->used;
if (b->alloc < pa) {
if ((err = mp_grow(b, pa)) != MP_OKAY) {
return err;
}
}
/* number of output digits to produce */
W1 = 0;
for (ix = 0; ix < pa; ix++) {
int tx, ty, iy;
mp_word _W;
mp_digit *tmpy;
/* clear counter */
_W = 0;
/* get offsets into the two bignums */
ty = MP_MIN(a->used-1, ix);
tx = ix - ty;
/* setup temp aliases */
tmpx = a->dp + tx;
tmpy = a->dp + ty;
/* this is the number of times the loop will iterrate, essentially
while (tx++ < a->used && ty-- >= 0) { ... }
*/
iy = MP_MIN(a->used-tx, ty+1);
/* now for squaring tx can never equal ty
* we halve the distance since they approach at a rate of 2x
* and we have to round because odd cases need to be executed
*/
iy = MP_MIN(iy, ((ty-tx)+1)>>1);
/* execute loop */
for (iz = 0; iz < iy; iz++) {
_W += (mp_word)*tmpx++ * (mp_word)*tmpy--;
}
/* double the inner product and add carry */
_W = _W + _W + W1;
/* even columns have the square term in them */
if (((unsigned)ix & 1u) == 0u) {
_W += (mp_word)a->dp[ix>>1] * (mp_word)a->dp[ix>>1];
}
/* store it */
W[ix] = (mp_digit)_W & MP_MASK;
/* make next carry */
W1 = _W >> (mp_word)MP_DIGIT_BIT;
}
/* setup dest */
olduse = b->used;
b->used = a->used+a->used;
{
mp_digit *tmpb;
tmpb = b->dp;
for (ix = 0; ix < pa; ix++) {
*tmpb++ = W[ix] & MP_MASK;
}
/* clear unused digits [that existed in the old copy of c] */
MP_ZERO_DIGITS(tmpb, olduse - ix);
}
mp_clamp(b);
return MP_OKAY;
}
#endif
|
Changes to libtommath/bn_s_mp_sub.c.
1 2 | #include "tommath_private.h" #ifdef BN_S_MP_SUB_C | | < < < < < < < < | < | | > | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
#include "tommath_private.h"
#ifdef BN_S_MP_SUB_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* low level subtraction (assumes |a| > |b|), HAC pp.595 Algorithm 14.9 */
mp_err s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c)
{
int olduse, min, max;
mp_err err;
/* find sizes */
min = b->used;
max = a->used;
/* init result */
if (c->alloc < max) {
if ((err = mp_grow(c, max)) != MP_OKAY) {
return err;
}
}
olduse = c->used;
c->used = max;
{
mp_digit u, *tmpa, *tmpb, *tmpc;
|
| ︙ | ︙ | |||
46 47 48 49 50 51 52 |
*tmpc = (*tmpa++ - *tmpb++) - u;
/* U = carry bit of T[i]
* Note this saves performing an AND operation since
* if a carry does occur it will propagate all the way to the
* MSB. As a result a single shift is enough to get the carry
*/
| | | | < < < < < < | 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 |
*tmpc = (*tmpa++ - *tmpb++) - u;
/* U = carry bit of T[i]
* Note this saves performing an AND operation since
* if a carry does occur it will propagate all the way to the
* MSB. As a result a single shift is enough to get the carry
*/
u = *tmpc >> (MP_SIZEOF_BITS(mp_digit) - 1u);
/* Clear carry from T[i] */
*tmpc++ &= MP_MASK;
}
/* now copy higher words if any, e.g. if A has more digits than B */
for (; i < max; i++) {
/* T[i] = A[i] - U */
*tmpc = *tmpa++ - u;
/* U = carry bit of T[i] */
u = *tmpc >> (MP_SIZEOF_BITS(mp_digit) - 1u);
/* Clear carry from T[i] */
*tmpc++ &= MP_MASK;
}
/* clear digits above used (since we may not have grown result above) */
MP_ZERO_DIGITS(tmpc, olduse - c->used);
}
mp_clamp(c);
return MP_OKAY;
}
#endif
|
Added libtommath/bn_s_mp_toom_mul.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 |
#include "tommath_private.h"
#ifdef BN_S_MP_TOOM_MUL_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* multiplication using the Toom-Cook 3-way algorithm
*
* Much more complicated than Karatsuba but has a lower
* asymptotic running time of O(N**1.464). This algorithm is
* only particularly useful on VERY large inputs
* (we're talking 1000s of digits here...).
*/
/*
This file contains code from J. Arndt's book "Matters Computational"
and the accompanying FXT-library with permission of the author.
*/
/*
Setup from
Chung, Jaewook, and M. Anwar Hasan. "Asymmetric squaring formulae."
18th IEEE Symposium on Computer Arithmetic (ARITH'07). IEEE, 2007.
The interpolation from above needed one temporary variable more
than the interpolation here:
Bodrato, Marco, and Alberto Zanoni. "What about Toom-Cook matrices optimality."
Centro Vito Volterra Universita di Roma Tor Vergata (2006)
*/
mp_err s_mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c)
{
mp_int S1, S2, T1, a0, a1, a2, b0, b1, b2;
int B, count;
mp_err err;
/* init temps */
if ((err = mp_init_multi(&S1, &S2, &T1, NULL)) != MP_OKAY) {
return err;
}
/* B */
B = MP_MIN(a->used, b->used) / 3;
/** a = a2 * x^2 + a1 * x + a0; */
if ((err = mp_init_size(&a0, B)) != MP_OKAY) goto LBL_ERRa0;
for (count = 0; count < B; count++) {
a0.dp[count] = a->dp[count];
a0.used++;
}
mp_clamp(&a0);
if ((err = mp_init_size(&a1, B)) != MP_OKAY) goto LBL_ERRa1;
for (; count < (2 * B); count++) {
a1.dp[count - B] = a->dp[count];
a1.used++;
}
mp_clamp(&a1);
if ((err = mp_init_size(&a2, B + (a->used - (3 * B)))) != MP_OKAY) goto LBL_ERRa2;
for (; count < a->used; count++) {
a2.dp[count - (2 * B)] = a->dp[count];
a2.used++;
}
mp_clamp(&a2);
/** b = b2 * x^2 + b1 * x + b0; */
if ((err = mp_init_size(&b0, B)) != MP_OKAY) goto LBL_ERRb0;
for (count = 0; count < B; count++) {
b0.dp[count] = b->dp[count];
b0.used++;
}
mp_clamp(&b0);
if ((err = mp_init_size(&b1, B)) != MP_OKAY) goto LBL_ERRb1;
for (; count < (2 * B); count++) {
b1.dp[count - B] = b->dp[count];
b1.used++;
}
mp_clamp(&b1);
if ((err = mp_init_size(&b2, B + (b->used - (3 * B)))) != MP_OKAY) goto LBL_ERRb2;
for (; count < b->used; count++) {
b2.dp[count - (2 * B)] = b->dp[count];
b2.used++;
}
mp_clamp(&b2);
/** \\ S1 = (a2+a1+a0) * (b2+b1+b0); */
/** T1 = a2 + a1; */
if ((err = mp_add(&a2, &a1, &T1)) != MP_OKAY) goto LBL_ERR;
/** S2 = T1 + a0; */
if ((err = mp_add(&T1, &a0, &S2)) != MP_OKAY) goto LBL_ERR;
/** c = b2 + b1; */
if ((err = mp_add(&b2, &b1, c)) != MP_OKAY) goto LBL_ERR;
/** S1 = c + b0; */
if ((err = mp_add(c, &b0, &S1)) != MP_OKAY) goto LBL_ERR;
/** S1 = S1 * S2; */
if ((err = mp_mul(&S1, &S2, &S1)) != MP_OKAY) goto LBL_ERR;
/** \\S2 = (4*a2+2*a1+a0) * (4*b2+2*b1+b0); */
/** T1 = T1 + a2; */
if ((err = mp_add(&T1, &a2, &T1)) != MP_OKAY) goto LBL_ERR;
/** T1 = T1 << 1; */
if ((err = mp_mul_2(&T1, &T1)) != MP_OKAY) goto LBL_ERR;
/** T1 = T1 + a0; */
if ((err = mp_add(&T1, &a0, &T1)) != MP_OKAY) goto LBL_ERR;
/** c = c + b2; */
if ((err = mp_add(c, &b2, c)) != MP_OKAY) goto LBL_ERR;
/** c = c << 1; */
if ((err = mp_mul_2(c, c)) != MP_OKAY) goto LBL_ERR;
/** c = c + b0; */
if ((err = mp_add(c, &b0, c)) != MP_OKAY) goto LBL_ERR;
/** S2 = T1 * c; */
if ((err = mp_mul(&T1, c, &S2)) != MP_OKAY) goto LBL_ERR;
/** \\S3 = (a2-a1+a0) * (b2-b1+b0); */
/** a1 = a2 - a1; */
if ((err = mp_sub(&a2, &a1, &a1)) != MP_OKAY) goto LBL_ERR;
/** a1 = a1 + a0; */
if ((err = mp_add(&a1, &a0, &a1)) != MP_OKAY) goto LBL_ERR;
/** b1 = b2 - b1; */
if ((err = mp_sub(&b2, &b1, &b1)) != MP_OKAY) goto LBL_ERR;
/** b1 = b1 + b0; */
if ((err = mp_add(&b1, &b0, &b1)) != MP_OKAY) goto LBL_ERR;
/** a1 = a1 * b1; */
if ((err = mp_mul(&a1, &b1, &a1)) != MP_OKAY) goto LBL_ERR;
/** b1 = a2 * b2; */
if ((err = mp_mul(&a2, &b2, &b1)) != MP_OKAY) goto LBL_ERR;
/** \\S2 = (S2 - S3)/3; */
/** S2 = S2 - a1; */
if ((err = mp_sub(&S2, &a1, &S2)) != MP_OKAY) goto LBL_ERR;
/** S2 = S2 / 3; \\ this is an exact division */
if ((err = mp_div_3(&S2, &S2, NULL)) != MP_OKAY) goto LBL_ERR;
/** a1 = S1 - a1; */
if ((err = mp_sub(&S1, &a1, &a1)) != MP_OKAY) goto LBL_ERR;
/** a1 = a1 >> 1; */
if ((err = mp_div_2(&a1, &a1)) != MP_OKAY) goto LBL_ERR;
/** a0 = a0 * b0; */
if ((err = mp_mul(&a0, &b0, &a0)) != MP_OKAY) goto LBL_ERR;
/** S1 = S1 - a0; */
if ((err = mp_sub(&S1, &a0, &S1)) != MP_OKAY) goto LBL_ERR;
/** S2 = S2 - S1; */
if ((err = mp_sub(&S2, &S1, &S2)) != MP_OKAY) goto LBL_ERR;
/** S2 = S2 >> 1; */
if ((err = mp_div_2(&S2, &S2)) != MP_OKAY) goto LBL_ERR;
/** S1 = S1 - a1; */
if ((err = mp_sub(&S1, &a1, &S1)) != MP_OKAY) goto LBL_ERR;
/** S1 = S1 - b1; */
if ((err = mp_sub(&S1, &b1, &S1)) != MP_OKAY) goto LBL_ERR;
/** T1 = b1 << 1; */
if ((err = mp_mul_2(&b1, &T1)) != MP_OKAY) goto LBL_ERR;
/** S2 = S2 - T1; */
if ((err = mp_sub(&S2, &T1, &S2)) != MP_OKAY) goto LBL_ERR;
/** a1 = a1 - S2; */
if ((err = mp_sub(&a1, &S2, &a1)) != MP_OKAY) goto LBL_ERR;
/** P = b1*x^4+ S2*x^3+ S1*x^2+ a1*x + a0; */
if ((err = mp_lshd(&b1, 4 * B)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_lshd(&S2, 3 * B)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_add(&b1, &S2, &b1)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_lshd(&S1, 2 * B)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_add(&b1, &S1, &b1)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_lshd(&a1, 1 * B)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_add(&b1, &a1, &b1)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_add(&b1, &a0, c)) != MP_OKAY) goto LBL_ERR;
/** a * b - P */
LBL_ERR:
mp_clear(&b2);
LBL_ERRb2:
mp_clear(&b1);
LBL_ERRb1:
mp_clear(&b0);
LBL_ERRb0:
mp_clear(&a2);
LBL_ERRa2:
mp_clear(&a1);
LBL_ERRa1:
mp_clear(&a0);
LBL_ERRa0:
mp_clear_multi(&S1, &S2, &T1, NULL);
return err;
}
#endif
|
Added libtommath/bn_s_mp_toom_sqr.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 |
#include "tommath_private.h"
#ifdef BN_S_MP_TOOM_SQR_C
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
/* squaring using Toom-Cook 3-way algorithm */
/*
This file contains code from J. Arndt's book "Matters Computational"
and the accompanying FXT-library with permission of the author.
*/
/* squaring using Toom-Cook 3-way algorithm */
/*
Setup and interpolation from algorithm SQR_3 in
Chung, Jaewook, and M. Anwar Hasan. "Asymmetric squaring formulae."
18th IEEE Symposium on Computer Arithmetic (ARITH'07). IEEE, 2007.
*/
mp_err s_mp_toom_sqr(const mp_int *a, mp_int *b)
{
mp_int S0, a0, a1, a2;
mp_digit *tmpa, *tmpc;
int B, count;
mp_err err;
/* init temps */
if ((err = mp_init(&S0)) != MP_OKAY) {
return err;
}
/* B */
B = a->used / 3;
/** a = a2 * x^2 + a1 * x + a0; */
if ((err = mp_init_size(&a0, B)) != MP_OKAY) goto LBL_ERRa0;
a0.used = B;
if ((err = mp_init_size(&a1, B)) != MP_OKAY) goto LBL_ERRa1;
a1.used = B;
if ((err = mp_init_size(&a2, B + (a->used - (3 * B)))) != MP_OKAY) goto LBL_ERRa2;
tmpa = a->dp;
tmpc = a0.dp;
for (count = 0; count < B; count++) {
*tmpc++ = *tmpa++;
}
tmpc = a1.dp;
for (; count < (2 * B); count++) {
*tmpc++ = *tmpa++;
}
tmpc = a2.dp;
for (; count < a->used; count++) {
*tmpc++ = *tmpa++;
a2.used++;
}
mp_clamp(&a0);
mp_clamp(&a1);
mp_clamp(&a2);
/** S0 = a0^2; */
if ((err = mp_sqr(&a0, &S0)) != MP_OKAY) goto LBL_ERR;
/** \\S1 = (a2 + a1 + a0)^2 */
/** \\S2 = (a2 - a1 + a0)^2 */
/** \\S1 = a0 + a2; */
/** a0 = a0 + a2; */
if ((err = mp_add(&a0, &a2, &a0)) != MP_OKAY) goto LBL_ERR;
/** \\S2 = S1 - a1; */
/** b = a0 - a1; */
if ((err = mp_sub(&a0, &a1, b)) != MP_OKAY) goto LBL_ERR;
/** \\S1 = S1 + a1; */
/** a0 = a0 + a1; */
if ((err = mp_add(&a0, &a1, &a0)) != MP_OKAY) goto LBL_ERR;
/** \\S1 = S1^2; */
/** a0 = a0^2; */
if ((err = mp_sqr(&a0, &a0)) != MP_OKAY) goto LBL_ERR;
/** \\S2 = S2^2; */
/** b = b^2; */
if ((err = mp_sqr(b, b)) != MP_OKAY) goto LBL_ERR;
/** \\ S3 = 2 * a1 * a2 */
/** \\S3 = a1 * a2; */
/** a1 = a1 * a2; */
if ((err = mp_mul(&a1, &a2, &a1)) != MP_OKAY) goto LBL_ERR;
/** \\S3 = S3 << 1; */
/** a1 = a1 << 1; */
if ((err = mp_mul_2(&a1, &a1)) != MP_OKAY) goto LBL_ERR;
/** \\S4 = a2^2; */
/** a2 = a2^2; */
if ((err = mp_sqr(&a2, &a2)) != MP_OKAY) goto LBL_ERR;
/** \\ tmp = (S1 + S2)/2 */
/** \\tmp = S1 + S2; */
/** b = a0 + b; */
if ((err = mp_add(&a0, b, b)) != MP_OKAY) goto LBL_ERR;
/** \\tmp = tmp >> 1; */
/** b = b >> 1; */
if ((err = mp_div_2(b, b)) != MP_OKAY) goto LBL_ERR;
/** \\ S1 = S1 - tmp - S3 */
/** \\S1 = S1 - tmp; */
/** a0 = a0 - b; */
if ((err = mp_sub(&a0, b, &a0)) != MP_OKAY) goto LBL_ERR;
/** \\S1 = S1 - S3; */
/** a0 = a0 - a1; */
if ((err = mp_sub(&a0, &a1, &a0)) != MP_OKAY) goto LBL_ERR;
/** \\S2 = tmp - S4 -S0 */
/** \\S2 = tmp - S4; */
/** b = b - a2; */
if ((err = mp_sub(b, &a2, b)) != MP_OKAY) goto LBL_ERR;
/** \\S2 = S2 - S0; */
/** b = b - S0; */
if ((err = mp_sub(b, &S0, b)) != MP_OKAY) goto LBL_ERR;
/** \\P = S4*x^4 + S3*x^3 + S2*x^2 + S1*x + S0; */
/** P = a2*x^4 + a1*x^3 + b*x^2 + a0*x + S0; */
if ((err = mp_lshd(&a2, 4 * B)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_lshd(&a1, 3 * B)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_lshd(b, 2 * B)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_lshd(&a0, 1 * B)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_add(&a2, &a1, &a2)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_add(&a2, b, b)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_add(b, &a0, b)) != MP_OKAY) goto LBL_ERR;
if ((err = mp_add(b, &S0, b)) != MP_OKAY) goto LBL_ERR;
/** a^2 - P */
LBL_ERR:
mp_clear(&a2);
LBL_ERRa2:
mp_clear(&a1);
LBL_ERRa1:
mp_clear(&a0);
LBL_ERRa0:
mp_clear(&S0);
return err;
}
#endif
|
Deleted libtommath/bncore.c.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to libtommath/changes.txt.
1 2 3 4 5 6 7 |
Jan 28th, 2019
v1.1.0
-- Christoph Zurnieden contributed FIPS 186.4 compliant
prime-checking (PR #113), several other fixes and a load of documentation
-- Daniel Mendler provided two's-complement functions (PR #124)
and mp_{set,get}_double() (PR #123)
-- Francois Perrad took care of linting the sources, provided all fixes and
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
Oct 22nd, 2019
v1.2.0
-- A huge refactoring of the library happened - renaming,
deprecating and replacing existing functions by improved API's.
All deprecated functions, macros and symbols are only marked as such
so this version is still API and ABI compatible to v1.x.
-- Daniel Mendler was pushing for those changes and contributing a load of patches,
refactorings, code reviews and whatnotelse.
-- Christoph Zurnieden re-worked internals of the library, improved the performance,
did code reviews and wrote documentation.
-- Francois Perrad did some refactoring and took again care of linting the sources and
provided all fixes.
-- Jan Nijtmans, Karel Miko and Joachim Breitner contributed various patches.
-- Private symbols can now be hidden for the shared library builds, disabled by default.
-- All API's follow a single code style, are prefixed the same etc.
-- Unified, safer and improved API's
-- Less magic numbers - return values (where appropriate) and most flags are now enums,
this was implemented in a backwards compatible way where return values were int.
-- API's with return values are now by default marked as "warn on unsused result", this
can be disabled if required (which will most likely hide bugs), c.f. MP_WUR in tommath.h
-- Provide a whole set of setters&getters for different primitive types (long, uint32_t, etc.)
-- All those primitive setters are now optimized.
-- It's possible to automatically tune the cutoff values for Karatsuba&Toom-Cook
-- The custom allocators which were formerly known as XMALLOC(), XFREE() etc. are now available
as MP_MALLOC(), MP_REALLOC(), MP_CALLOC() and MP_FREE(). MP_REALLOC() and MP_FREE() now also
provide the allocated size to ease the usage of simple allocators without tracking.
-- Building is now also possible with MSVC 2015, 2017 and 2019 (use makefile.msvc)
-- Added mp_decr() and mp_incr()
-- Added mp_log_u32()
-- Improved prime-checking
-- Improved Toom-Cook multiplication
-- Removed the LTM book (`make docs` now builds the user manual)
Jan 28th, 2019
v1.1.0
-- Christoph Zurnieden contributed FIPS 186.4 compliant
prime-checking (PR #113), several other fixes and a load of documentation
-- Daniel Mendler provided two's-complement functions (PR #124)
and mp_{set,get}_double() (PR #123)
-- Francois Perrad took care of linting the sources, provided all fixes and
|
| ︙ | ︙ |
Added libtommath/helper.pl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 |
#!/usr/bin/env perl
use strict;
use warnings;
use Getopt::Long;
use File::Find 'find';
use File::Basename 'basename';
use File::Glob 'bsd_glob';
sub read_file {
my $f = shift;
open my $fh, "<", $f or die "FATAL: read_rawfile() cannot open file '$f': $!";
binmode $fh;
return do { local $/; <$fh> };
}
sub write_file {
my ($f, $data) = @_;
die "FATAL: write_file() no data" unless defined $data;
open my $fh, ">", $f or die "FATAL: write_file() cannot open file '$f': $!";
binmode $fh;
print $fh $data or die "FATAL: write_file() cannot write to '$f': $!";
close $fh or die "FATAL: write_file() cannot close '$f': $!";
return;
}
sub sanitize_comments {
my($content) = @_;
$content =~ s{/\*(.*?)\*/}{my $x=$1; $x =~ s/\w/x/g; "/*$x*/";}egs;
return $content;
}
sub check_source {
my @all_files = (
bsd_glob("makefile*"),
bsd_glob("*.{h,c,sh,pl}"),
bsd_glob("*/*.{h,c,sh,pl}"),
);
my $fails = 0;
for my $file (sort @all_files) {
my $troubles = {};
my $lineno = 1;
my $content = read_file($file);
$content = sanitize_comments $content;
push @{$troubles->{crlf_line_end}}, '?' if $content =~ /\r/;
for my $l (split /\n/, $content) {
push @{$troubles->{merge_conflict}}, $lineno if $l =~ /^(<<<<<<<|=======|>>>>>>>)([^<=>]|$)/;
push @{$troubles->{trailing_space}}, $lineno if $l =~ / $/;
push @{$troubles->{tab}}, $lineno if $l =~ /\t/ && basename($file) !~ /^makefile/i;
push @{$troubles->{non_ascii_char}}, $lineno if $l =~ /[^[:ascii:]]/;
push @{$troubles->{cpp_comment}}, $lineno if $file =~ /\.(c|h)$/ && ($l =~ /\s\/\// || $l =~ /\/\/\s/);
# we prefer using MP_MALLOC, MP_FREE, MP_REALLOC, MP_CALLOC ...
push @{$troubles->{unwanted_malloc}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bmalloc\s*\(/;
push @{$troubles->{unwanted_realloc}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\brealloc\s*\(/;
push @{$troubles->{unwanted_calloc}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bcalloc\s*\(/;
push @{$troubles->{unwanted_free}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bfree\s*\(/;
# and we probably want to also avoid the following
push @{$troubles->{unwanted_memcpy}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bmemcpy\s*\(/;
push @{$troubles->{unwanted_memset}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bmemset\s*\(/;
push @{$troubles->{unwanted_memcpy}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bmemcpy\s*\(/;
push @{$troubles->{unwanted_memmove}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bmemmove\s*\(/;
push @{$troubles->{unwanted_memcmp}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bmemcmp\s*\(/;
push @{$troubles->{unwanted_strcmp}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bstrcmp\s*\(/;
push @{$troubles->{unwanted_strcpy}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bstrcpy\s*\(/;
push @{$troubles->{unwanted_strncpy}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bstrncpy\s*\(/;
push @{$troubles->{unwanted_clock}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bclock\s*\(/;
push @{$troubles->{unwanted_qsort}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bqsort\s*\(/;
push @{$troubles->{sizeof_no_brackets}}, $lineno if $file =~ /^[^\/]+\.c$/ && $l =~ /\bsizeof\s*[^\(]/;
if ($file =~ m|^[^\/]+\.c$| && $l =~ /^static(\s+[a-zA-Z0-9_]+)+\s+([a-zA-Z0-9_]+)\s*\(/) {
my $funcname = $2;
# static functions should start with s_
push @{$troubles->{staticfunc_name}}, "$lineno($funcname)" if $funcname !~ /^s_/;
}
$lineno++;
}
for my $k (sort keys %$troubles) {
warn "[$k] $file line:" . join(",", @{$troubles->{$k}}) . "\n";
$fails++;
}
}
warn( $fails > 0 ? "check-source: FAIL $fails\n" : "check-source: PASS\n" );
return $fails;
}
sub check_comments {
my $fails = 0;
my $first_comment = <<'MARKER';
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
MARKER
#my @all_files = (bsd_glob("*.{h,c}"), bsd_glob("*/*.{h,c}"));
my @all_files = (bsd_glob("*.{h,c}"));
for my $f (@all_files) {
my $txt = read_file($f);
if ($txt !~ /\Q$first_comment\E/s) {
warn "[first_comment] $f\n";
$fails++;
}
}
warn( $fails > 0 ? "check-comments: FAIL $fails\n" : "check-comments: PASS\n" );
return $fails;
}
sub check_doc {
my $fails = 0;
my $tex = read_file('doc/bn.tex');
my $tmh = read_file('tommath.h');
my @functions = $tmh =~ /\n\s*[a-zA-Z0-9_* ]+?(mp_[a-z0-9_]+)\s*\([^\)]+\)\s*;/sg;
my @macros = $tmh =~ /\n\s*#define\s+([a-z0-9_]+)\s*\([^\)]+\)/sg;
for my $n (sort @functions) {
(my $nn = $n) =~ s/_/\\_/g; # mp_sub_d >> mp\_sub\_d
if ($tex !~ /index\Q{$nn}\E/) {
warn "[missing_doc_for_function] $n\n";
$fails++
}
}
for my $n (sort @macros) {
(my $nn = $n) =~ s/_/\\_/g; # mp_iszero >> mp\_iszero
if ($tex !~ /index\Q{$nn}\E/) {
warn "[missing_doc_for_macro] $n\n";
$fails++
}
}
warn( $fails > 0 ? "check_doc: FAIL $fails\n" : "check-doc: PASS\n" );
return $fails;
}
sub prepare_variable {
my ($varname, @list) = @_;
my $output = "$varname=";
my $len = length($output);
foreach my $obj (sort @list) {
$len = $len + length $obj;
$obj =~ s/\*/\$/;
if ($len > 100) {
$output .= "\\\n";
$len = length $obj;
}
$output .= $obj . ' ';
}
$output =~ s/ $//;
return $output;
}
sub prepare_msvc_files_xml {
my ($all, $exclude_re, $targets) = @_;
my $last = [];
my $depth = 2;
# sort files in the same order as visual studio (ugly, I know)
my @parts = ();
for my $orig (@$all) {
my $p = $orig;
$p =~ s|/|/~|g;
$p =~ s|/~([^/]+)$|/$1|g;
my @l = map { sprintf "% -99s", $_ } split /\//, $p;
push @parts, [ $orig, join(':', @l) ];
}
my @sorted = map { $_->[0] } sort { $a->[1] cmp $b->[1] } @parts;
my $files = "<Files>\r\n";
for my $full (@sorted) {
my @items = split /\//, $full; # split by '/'
$full =~ s|/|\\|g; # replace '/' bt '\'
shift @items; # drop first one (src)
pop @items; # drop last one (filename.ext)
my $current = \@items;
if (join(':', @$current) ne join(':', @$last)) {
my $common = 0;
$common++ while ($last->[$common] && $current->[$common] && $last->[$common] eq $current->[$common]);
my $back = @$last - $common;
if ($back > 0) {
$files .= ("\t" x --$depth) . "</Filter>\r\n" for (1..$back);
}
my $fwd = [ @$current ]; splice(@$fwd, 0, $common);
for my $i (0..scalar(@$fwd) - 1) {
$files .= ("\t" x $depth) . "<Filter\r\n";
$files .= ("\t" x $depth) . "\tName=\"$fwd->[$i]\"\r\n";
$files .= ("\t" x $depth) . "\t>\r\n";
$depth++;
}
$last = $current;
}
$files .= ("\t" x $depth) . "<File\r\n";
$files .= ("\t" x $depth) . "\tRelativePath=\"$full\"\r\n";
$files .= ("\t" x $depth) . "\t>\r\n";
if ($full =~ $exclude_re) {
for (@$targets) {
$files .= ("\t" x $depth) . "\t<FileConfiguration\r\n";
$files .= ("\t" x $depth) . "\t\tName=\"$_\"\r\n";
$files .= ("\t" x $depth) . "\t\tExcludedFromBuild=\"true\"\r\n";
$files .= ("\t" x $depth) . "\t\t>\r\n";
$files .= ("\t" x $depth) . "\t\t<Tool\r\n";
$files .= ("\t" x $depth) . "\t\t\tName=\"VCCLCompilerTool\"\r\n";
$files .= ("\t" x $depth) . "\t\t\tAdditionalIncludeDirectories=\"\"\r\n";
$files .= ("\t" x $depth) . "\t\t\tPreprocessorDefinitions=\"\"\r\n";
$files .= ("\t" x $depth) . "\t\t/>\r\n";
$files .= ("\t" x $depth) . "\t</FileConfiguration>\r\n";
}
}
$files .= ("\t" x $depth) . "</File>\r\n";
}
$files .= ("\t" x --$depth) . "</Filter>\r\n" for (@$last);
$files .= "\t</Files>";
return $files;
}
sub patch_file {
my ($content, @variables) = @_;
for my $v (@variables) {
if ($v =~ /^([A-Z0-9_]+)\s*=.*$/si) {
my $name = $1;
$content =~ s/\n\Q$name\E\b.*?[^\\]\n/\n$v\n/s;
}
else {
die "patch_file failed: " . substr($v, 0, 30) . "..";
}
}
return $content;
}
sub process_makefiles {
my $write = shift;
my $changed_count = 0;
my @o = map { my $x = $_; $x =~ s/\.c$/.o/; $x } bsd_glob("*.c");
my @all = bsd_glob("*.{c,h}");
my $var_o = prepare_variable("OBJECTS", @o);
(my $var_obj = $var_o) =~ s/\.o\b/.obj/sg;
# update MSVC project files
my $msvc_files = prepare_msvc_files_xml(\@all, qr/NOT_USED_HERE/, ['Debug|Win32', 'Release|Win32', 'Debug|x64', 'Release|x64']);
for my $m (qw/libtommath_VS2008.vcproj/) {
my $old = read_file($m);
my $new = $old;
$new =~ s|<Files>.*</Files>|$msvc_files|s;
if ($old ne $new) {
write_file($m, $new) if $write;
warn "changed: $m\n";
$changed_count++;
}
}
# update OBJECTS + HEADERS in makefile*
for my $m (qw/ makefile makefile.shared makefile_include.mk makefile.msvc makefile.unix makefile.mingw /) {
my $old = read_file($m);
my $new = $m eq 'makefile.msvc' ? patch_file($old, $var_obj)
: patch_file($old, $var_o);
if ($old ne $new) {
write_file($m, $new) if $write;
warn "changed: $m\n";
$changed_count++;
}
}
if ($write) {
return 0; # no failures
}
else {
warn( $changed_count > 0 ? "check-makefiles: FAIL $changed_count\n" : "check-makefiles: PASS\n" );
return $changed_count;
}
}
sub draw_func
{
my ($deplist, $depmap, $out, $indent, $funcslist) = @_;
my @funcs = split ',', $funcslist;
# try this if you want to have a look at a minimized version of the callgraph without all the trivial functions
#if ($deplist =~ /$funcs[0]/ || $funcs[0] =~ /BN_MP_(ADD|SUB|CLEAR|CLEAR_\S+|DIV|MUL|COPY|ZERO|GROW|CLAMP|INIT|INIT_\S+|SET|ABS|CMP|CMP_D|EXCH)_C/) {
if ($deplist =~ /$funcs[0]/) {
return $deplist;
} else {
$deplist = $deplist . $funcs[0];
}
if ($indent == 0) {
} elsif ($indent >= 1) {
print {$out} '| ' x ($indent - 1) . '+--->';
}
print {$out} $funcs[0] . "\n";
shift @funcs;
my $olddeplist = $deplist;
foreach my $i (@funcs) {
$deplist = draw_func($deplist, $depmap, $out, $indent + 1, ${$depmap}{$i}) if exists ${$depmap}{$i};
}
return $olddeplist;
}
sub update_dep
{
#open class file and write preamble
open(my $class, '>', 'tommath_class.h') or die "Couldn't open tommath_class.h for writing\n";
print {$class} << 'EOS';
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
#if !(defined(LTM1) && defined(LTM2) && defined(LTM3))
#define LTM_INSIDE
#if defined(LTM2)
# define LTM3
#endif
#if defined(LTM1)
# define LTM2
#endif
#define LTM1
#if defined(LTM_ALL)
EOS
foreach my $filename (glob 'bn*.c') {
my $define = $filename;
print "Processing $filename\n";
# convert filename to upper case so we can use it as a define
$define =~ tr/[a-z]/[A-Z]/;
$define =~ tr/\./_/;
print {$class} "# define $define\n";
# now copy text and apply #ifdef as required
my $apply = 0;
open(my $src, '<', $filename);
open(my $out, '>', 'tmp');
# first line will be the #ifdef
my $line = <$src>;
if ($line =~ /include/) {
print {$out} $line;
} else {
print {$out} << "EOS";
#include "tommath_private.h"
#ifdef $define
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
$line
EOS
$apply = 1;
}
while (<$src>) {
if ($_ !~ /tommath\.h/) {
print {$out} $_;
}
}
if ($apply == 1) {
print {$out} "#endif\n";
}
close $src;
close $out;
unlink $filename;
rename 'tmp', $filename;
}
print {$class} "#endif\n#endif\n";
# now do classes
my %depmap;
foreach my $filename (glob 'bn*.c') {
my $content;
if ($filename =~ "bn_deprecated.c") {
open(my $src, '<', $filename) or die "Can't open source file!\n";
read $src, $content, -s $src;
close $src;
} else {
my $cc = $ENV{'CC'} || 'gcc';
$content = `$cc -E -x c -DLTM_ALL $filename`;
$content =~ s/^# 1 "$filename".*?^# 2 "$filename"//ms;
}
# convert filename to upper case so we can use it as a define
$filename =~ tr/[a-z]/[A-Z]/;
$filename =~ tr/\./_/;
print {$class} "#if defined($filename)\n";
my $list = $filename;
# strip comments
$content =~ s{/\*.*?\*/}{}gs;
# scan for mp_* and make classes
my @deps = ();
foreach my $line (split /\n/, $content) {
while ($line =~ /(fast_)?(s_)?mp\_[a-z_0-9]*((?=\;)|(?=\())|(?<=\()mp\_[a-z_0-9]*(?=\()/g) {
my $a = $&;
next if $a eq "mp_err";
$a =~ tr/[a-z]/[A-Z]/;
$a = 'BN_' . $a . '_C';
push @deps, $a;
}
}
@deps = sort(@deps);
foreach my $a (@deps) {
if ($list !~ /$a/) {
print {$class} "# define $a\n";
}
$list = $list . ',' . $a;
}
$depmap{$filename} = $list;
print {$class} "#endif\n\n";
}
print {$class} << 'EOS';
#ifdef LTM_INSIDE
#undef LTM_INSIDE
#ifdef LTM3
# define LTM_LAST
#endif
#include "tommath_superclass.h"
#include "tommath_class.h"
#else
# define LTM_LAST
#endif
EOS
close $class;
#now let's make a cool call graph...
open(my $out, '>', 'callgraph.txt');
foreach (sort keys %depmap) {
draw_func("", \%depmap, $out, 0, $depmap{$_});
print {$out} "\n\n";
}
close $out;
return 0;
}
sub generate_def {
my @files = split /\n/, `git ls-files`;
@files = grep(/\.c/, @files);
@files = map { my $x = $_; $x =~ s/^bn_|\.c$//g; $x; } @files;
@files = grep(!/mp_radix_smap/, @files);
push(@files, qw(mp_set_int mp_set_long mp_set_long_long mp_get_int mp_get_long mp_get_long_long mp_init_set_int));
my $files = join("\n ", sort(grep(/^mp_/, @files)));
write_file "tommath.def", "; libtommath
;
; Use this command to produce a 32-bit .lib file, for use in any MSVC version
; lib -machine:X86 -name:libtommath.dll -def:tommath.def -out:tommath.lib
; Use this command to produce a 64-bit .lib file, for use in any MSVC version
; lib -machine:X64 -name:libtommath.dll -def:tommath.def -out:tommath.lib
;
EXPORTS
$files
";
return 0;
}
sub die_usage {
die <<"MARKER";
usage: $0 -s OR $0 --check-source
$0 -o OR $0 --check-comments
$0 -m OR $0 --check-makefiles
$0 -a OR $0 --check-all
$0 -u OR $0 --update-files
MARKER
}
GetOptions( "s|check-source" => \my $check_source,
"o|check-comments" => \my $check_comments,
"m|check-makefiles" => \my $check_makefiles,
"d|check-doc" => \my $check_doc,
"a|check-all" => \my $check_all,
"u|update-files" => \my $update_files,
"h|help" => \my $help
) or die_usage;
my $failure;
$failure ||= check_source() if $check_all || $check_source;
$failure ||= check_comments() if $check_all || $check_comments;
$failure ||= check_doc() if $check_doc; # temporarily excluded from --check-all
$failure ||= process_makefiles(0) if $check_all || $check_makefiles;
$failure ||= process_makefiles(1) if $update_files;
$failure ||= update_dep() if $update_files;
$failure ||= generate_def() if $update_files;
die_usage unless defined $failure;
exit $failure ? 1 : 0;
|
Changes to libtommath/libtommath_VS2008.sln.
| ︙ | ︙ |
Changes to libtommath/libtommath_VS2008.vcproj.
| ︙ | ︙ | |||
309 310 311 312 313 314 315 | /> </Configuration> </Configurations> <References> </References> <Files> <File | | < < < < < < < < < < < < < < < < | | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 | /> </Configuration> </Configurations> <References> </References> <Files> <File RelativePath="bn_cutoffs.c" > </File> <File RelativePath="bn_deprecated.c" > </File> <File RelativePath="bn_mp_2expt.c" > </File> <File |
| ︙ | ︙ | |||
395 396 397 398 399 400 401 402 403 404 405 406 407 408 | <File RelativePath="bn_mp_copy.c" > </File> <File RelativePath="bn_mp_count_bits.c" > </File> <File RelativePath="bn_mp_div.c" > </File> <File RelativePath="bn_mp_div_2.c" | > > > > | 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 | <File RelativePath="bn_mp_copy.c" > </File> <File RelativePath="bn_mp_count_bits.c" > </File> <File RelativePath="bn_mp_decr.c" > </File> <File RelativePath="bn_mp_div.c" > </File> <File RelativePath="bn_mp_div_2.c" |
| ︙ | ︙ | |||
427 428 429 430 431 432 433 434 435 436 437 438 439 | <File RelativePath="bn_mp_dr_reduce.c" > </File> <File RelativePath="bn_mp_dr_setup.c" > </File> <File RelativePath="bn_mp_exch.c" > </File> <File | > > > > | < < < < < < < < < < < < > > > > > > > > < < < < | > > > > > > > > > > > > | | > > > > > > > > | > > > > > > > > > > > > > > > > < < < < | | > > > > > > > > > > > > | | < < < < > > > > | 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 | <File RelativePath="bn_mp_dr_reduce.c" > </File> <File RelativePath="bn_mp_dr_setup.c" > </File> <File RelativePath="bn_mp_error_to_string.c" > </File> <File RelativePath="bn_mp_exch.c" > </File> <File RelativePath="bn_mp_expt_u32.c" > </File> <File RelativePath="bn_mp_exptmod.c" > </File> <File RelativePath="bn_mp_exteuclid.c" > </File> <File RelativePath="bn_mp_fread.c" > </File> <File RelativePath="bn_mp_from_sbin.c" > </File> <File RelativePath="bn_mp_from_ubin.c" > </File> <File RelativePath="bn_mp_fwrite.c" > </File> <File RelativePath="bn_mp_gcd.c" > </File> <File RelativePath="bn_mp_get_double.c" > </File> <File RelativePath="bn_mp_get_i32.c" > </File> <File RelativePath="bn_mp_get_i64.c" > </File> <File RelativePath="bn_mp_get_l.c" > </File> <File RelativePath="bn_mp_get_ll.c" > </File> <File RelativePath="bn_mp_get_mag_u32.c" > </File> <File RelativePath="bn_mp_get_mag_u64.c" > </File> <File RelativePath="bn_mp_get_mag_ul.c" > </File> <File RelativePath="bn_mp_get_mag_ull.c" > </File> <File RelativePath="bn_mp_grow.c" > </File> <File RelativePath="bn_mp_incr.c" > </File> <File RelativePath="bn_mp_init.c" > </File> <File RelativePath="bn_mp_init_copy.c" > </File> <File RelativePath="bn_mp_init_i32.c" > </File> <File RelativePath="bn_mp_init_i64.c" > </File> <File RelativePath="bn_mp_init_l.c" > </File> <File RelativePath="bn_mp_init_ll.c" > </File> <File RelativePath="bn_mp_init_multi.c" > </File> <File RelativePath="bn_mp_init_set.c" > </File> <File RelativePath="bn_mp_init_size.c" > </File> <File RelativePath="bn_mp_init_u32.c" > </File> <File RelativePath="bn_mp_init_u64.c" > </File> <File RelativePath="bn_mp_init_ul.c" > </File> <File RelativePath="bn_mp_init_ull.c" > </File> <File RelativePath="bn_mp_invmod.c" > </File> <File RelativePath="bn_mp_is_square.c" > </File> <File RelativePath="bn_mp_iseven.c" > </File> <File RelativePath="bn_mp_isodd.c" > </File> <File RelativePath="bn_mp_kronecker.c" > </File> <File RelativePath="bn_mp_lcm.c" > </File> <File RelativePath="bn_mp_log_u32.c" > </File> <File RelativePath="bn_mp_lshd.c" > </File> <File RelativePath="bn_mp_mod.c" |
| ︙ | ︙ | |||
599 600 601 602 603 604 605 | <File RelativePath="bn_mp_mul_d.c" > </File> <File RelativePath="bn_mp_mulmod.c" > | < < < < < < < < > > > > > > > > < < < < | | 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 | <File RelativePath="bn_mp_mul_d.c" > </File> <File RelativePath="bn_mp_mulmod.c" > </File> <File RelativePath="bn_mp_neg.c" > </File> <File RelativePath="bn_mp_or.c" > </File> <File RelativePath="bn_mp_pack.c" > </File> <File RelativePath="bn_mp_pack_count.c" > </File> <File RelativePath="bn_mp_prime_fermat.c" > </File> <File RelativePath="bn_mp_prime_frobenius_underwood.c" > </File> <File RelativePath="bn_mp_prime_is_prime.c" > </File> <File RelativePath="bn_mp_prime_miller_rabin.c" > </File> <File RelativePath="bn_mp_prime_next_prime.c" > </File> <File RelativePath="bn_mp_prime_rabin_miller_trials.c" > </File> <File RelativePath="bn_mp_prime_rand.c" > </File> <File RelativePath="bn_mp_prime_strong_lucas_selfridge.c" > </File> <File |
| ︙ | ︙ | |||
667 668 669 670 671 672 673 | <File RelativePath="bn_mp_rand.c" > </File> <File RelativePath="bn_mp_read_radix.c" > | < < < < < < < < | 691 692 693 694 695 696 697 698 699 700 701 702 703 704 | <File RelativePath="bn_mp_rand.c" > </File> <File RelativePath="bn_mp_read_radix.c" > </File> <File RelativePath="bn_mp_reduce.c" > </File> <File RelativePath="bn_mp_reduce_2k.c" |
| ︙ | ︙ | |||
707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 | <File RelativePath="bn_mp_reduce_is_2k_l.c" > </File> <File RelativePath="bn_mp_reduce_setup.c" > </File> <File RelativePath="bn_mp_rshd.c" > </File> <File RelativePath="bn_mp_set.c" > </File> <File RelativePath="bn_mp_set_double.c" > </File> <File | > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > | | | 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 | <File RelativePath="bn_mp_reduce_is_2k_l.c" > </File> <File RelativePath="bn_mp_reduce_setup.c" > </File> <File RelativePath="bn_mp_root_u32.c" > </File> <File RelativePath="bn_mp_rshd.c" > </File> <File RelativePath="bn_mp_sbin_size.c" > </File> <File RelativePath="bn_mp_set.c" > </File> <File RelativePath="bn_mp_set_double.c" > </File> <File RelativePath="bn_mp_set_i32.c" > </File> <File RelativePath="bn_mp_set_i64.c" > </File> <File RelativePath="bn_mp_set_l.c" > </File> <File RelativePath="bn_mp_set_ll.c" > </File> <File RelativePath="bn_mp_set_u32.c" > </File> <File RelativePath="bn_mp_set_u64.c" > </File> <File RelativePath="bn_mp_set_ul.c" > </File> <File RelativePath="bn_mp_set_ull.c" > </File> <File RelativePath="bn_mp_shrink.c" > </File> <File RelativePath="bn_mp_signed_rsh.c" > </File> <File RelativePath="bn_mp_sqr.c" > </File> <File |
| ︙ | ︙ | |||
769 770 771 772 773 774 775 | > </File> <File RelativePath="bn_mp_submod.c" > </File> <File | < < < < < < < < < < < < < < < < | | | < < < < < < < < < < < < < < < < | | < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > | 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 | > </File> <File RelativePath="bn_mp_submod.c" > </File> <File RelativePath="bn_mp_to_radix.c" > </File> <File RelativePath="bn_mp_to_sbin.c" > </File> <File RelativePath="bn_mp_to_ubin.c" > </File> <File RelativePath="bn_mp_ubin_size.c" > </File> <File RelativePath="bn_mp_unpack.c" > </File> <File RelativePath="bn_mp_xor.c" > </File> <File RelativePath="bn_mp_zero.c" > </File> <File RelativePath="bn_prime_tab.c" > </File> <File RelativePath="bn_s_mp_add.c" > </File> <File RelativePath="bn_s_mp_balance_mul.c" > </File> <File RelativePath="bn_s_mp_exptmod.c" > </File> <File RelativePath="bn_s_mp_exptmod_fast.c" > </File> <File RelativePath="bn_s_mp_get_bit.c" > </File> <File RelativePath="bn_s_mp_invmod_fast.c" > </File> <File RelativePath="bn_s_mp_invmod_slow.c" > </File> <File RelativePath="bn_s_mp_karatsuba_mul.c" > </File> <File RelativePath="bn_s_mp_karatsuba_sqr.c" > </File> <File RelativePath="bn_s_mp_montgomery_reduce_fast.c" > </File> <File RelativePath="bn_s_mp_mul_digs.c" > </File> <File RelativePath="bn_s_mp_mul_digs_fast.c" > </File> <File RelativePath="bn_s_mp_mul_high_digs.c" > </File> <File RelativePath="bn_s_mp_mul_high_digs_fast.c" > </File> <File RelativePath="bn_s_mp_prime_is_divisible.c" > </File> <File RelativePath="bn_s_mp_rand_jenkins.c" > </File> <File RelativePath="bn_s_mp_rand_platform.c" > </File> <File RelativePath="bn_s_mp_reverse.c" > </File> <File RelativePath="bn_s_mp_sqr.c" > </File> <File RelativePath="bn_s_mp_sqr_fast.c" > </File> <File RelativePath="bn_s_mp_sub.c" > </File> <File RelativePath="bn_s_mp_toom_mul.c" > </File> <File RelativePath="bn_s_mp_toom_sqr.c" > </File> <File RelativePath="tommath.h" > </File> <File RelativePath="tommath_class.h" > </File> <File RelativePath="tommath_cutoffs.h" > </File> <File RelativePath="tommath_private.h" > </File> <File RelativePath="tommath_superclass.h" > </File> </Files> <Globals> </Globals> </VisualStudioProject> |
Changes to libtommath/makefile.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | LIBNAME=libtommath.a endif coverage: LIBNAME:=-Wl,--whole-archive $(LIBNAME) -Wl,--no-whole-archive include makefile_include.mk | | | < | | | | | | > | | | | | | | | | | | | > | < | | > | | > > < < | | | | > | > > | > > | > | | > > > > | < < < | | < | < > | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 |
LIBNAME=libtommath.a
endif
coverage: LIBNAME:=-Wl,--whole-archive $(LIBNAME) -Wl,--no-whole-archive
include makefile_include.mk
%.o: %.c $(HEADERS)
ifneq ($V,1)
@echo " * ${CC} $@"
endif
${silent} ${CC} -c ${LTM_CFLAGS} $< -o $@
LCOV_ARGS=--directory .
#START_INS
OBJECTS=bn_cutoffs.o bn_deprecated.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o bn_mp_addmod.o \
bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \
bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_decr.o bn_mp_div.o bn_mp_div_2.o \
bn_mp_div_2d.o bn_mp_div_3.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o bn_mp_dr_setup.o \
bn_mp_error_to_string.o bn_mp_exch.o bn_mp_expt_u32.o bn_mp_exptmod.o bn_mp_exteuclid.o bn_mp_fread.o \
bn_mp_from_sbin.o bn_mp_from_ubin.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_double.o bn_mp_get_i32.o \
bn_mp_get_i64.o bn_mp_get_l.o bn_mp_get_ll.o bn_mp_get_mag_u32.o bn_mp_get_mag_u64.o bn_mp_get_mag_ul.o \
bn_mp_get_mag_ull.o bn_mp_grow.o bn_mp_incr.o bn_mp_init.o bn_mp_init_copy.o bn_mp_init_i32.o \
bn_mp_init_i64.o bn_mp_init_l.o bn_mp_init_ll.o bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_size.o \
bn_mp_init_u32.o bn_mp_init_u64.o bn_mp_init_ul.o bn_mp_init_ull.o bn_mp_invmod.o bn_mp_is_square.o \
bn_mp_iseven.o bn_mp_isodd.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_log_u32.o bn_mp_lshd.o bn_mp_mod.o \
bn_mp_mod_2d.o bn_mp_mod_d.o bn_mp_montgomery_calc_normalization.o bn_mp_montgomery_reduce.o \
bn_mp_montgomery_setup.o bn_mp_mul.o bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_mulmod.o bn_mp_neg.o \
bn_mp_or.o bn_mp_pack.o bn_mp_pack_count.o bn_mp_prime_fermat.o bn_mp_prime_frobenius_underwood.o \
bn_mp_prime_is_prime.o bn_mp_prime_miller_rabin.o bn_mp_prime_next_prime.o \
bn_mp_prime_rabin_miller_trials.o bn_mp_prime_rand.o bn_mp_prime_strong_lucas_selfridge.o \
bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o bn_mp_read_radix.o bn_mp_reduce.o bn_mp_reduce_2k.o \
bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o \
bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o bn_mp_root_u32.o bn_mp_rshd.o bn_mp_sbin_size.o bn_mp_set.o \
bn_mp_set_double.o bn_mp_set_i32.o bn_mp_set_i64.o bn_mp_set_l.o bn_mp_set_ll.o bn_mp_set_u32.o \
bn_mp_set_u64.o bn_mp_set_ul.o bn_mp_set_ull.o bn_mp_shrink.o bn_mp_signed_rsh.o bn_mp_sqr.o \
bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o bn_mp_sub_d.o bn_mp_submod.o \
bn_mp_to_radix.o bn_mp_to_sbin.o bn_mp_to_ubin.o bn_mp_ubin_size.o bn_mp_unpack.o bn_mp_xor.o bn_mp_zero.o \
bn_prime_tab.o bn_s_mp_add.o bn_s_mp_balance_mul.o bn_s_mp_exptmod.o bn_s_mp_exptmod_fast.o \
bn_s_mp_get_bit.o bn_s_mp_invmod_fast.o bn_s_mp_invmod_slow.o bn_s_mp_karatsuba_mul.o \
bn_s_mp_karatsuba_sqr.o bn_s_mp_montgomery_reduce_fast.o bn_s_mp_mul_digs.o bn_s_mp_mul_digs_fast.o \
bn_s_mp_mul_high_digs.o bn_s_mp_mul_high_digs_fast.o bn_s_mp_prime_is_divisible.o \
bn_s_mp_rand_jenkins.o bn_s_mp_rand_platform.o bn_s_mp_reverse.o bn_s_mp_sqr.o bn_s_mp_sqr_fast.o \
bn_s_mp_sub.o bn_s_mp_toom_mul.o bn_s_mp_toom_sqr.o
#END_INS
$(LIBNAME): $(OBJECTS)
$(AR) $(ARFLAGS) $@ $(OBJECTS)
$(RANLIB) $@
#make a profiled library (takes a while!!!)
#
# This will build the library with profile generation
# then run the test demo and rebuild the library.
#
# So far I've seen improvements in the MP math
profiled:
make CFLAGS="$(CFLAGS) -fprofile-arcs -DTESTING" timing
./timing
rm -f *.a *.o timing
make CFLAGS="$(CFLAGS) -fbranch-probabilities"
#make a single object profiled library
profiled_single:
perl gen.pl
$(CC) $(LTM_CFLAGS) -fprofile-arcs -DTESTING -c mpi.c -o mpi.o
$(CC) $(LTM_CFLAGS) -DTESTING -DTIMER demo/timing.c mpi.o -lgcov -o timing
./timing
rm -f *.o timing
$(CC) $(LTM_CFLAGS) -fbranch-probabilities -DTESTING -c mpi.c -o mpi.o
$(AR) $(ARFLAGS) $(LIBNAME) mpi.o
ranlib $(LIBNAME)
install: $(LIBNAME)
install -d $(DESTDIR)$(LIBPATH)
install -d $(DESTDIR)$(INCPATH)
install -m 644 $(LIBNAME) $(DESTDIR)$(LIBPATH)
install -m 644 $(HEADERS_PUB) $(DESTDIR)$(INCPATH)
uninstall:
rm $(DESTDIR)$(LIBPATH)/$(LIBNAME)
rm $(HEADERS_PUB:%=$(DESTDIR)$(INCPATH)/%)
test_standalone: test
@echo "test_standalone is deprecated, please use make-target 'test'"
DEMOS=test mtest_opponent
define DEMO_template
$(1): demo/$(1).o demo/shared.o $$(LIBNAME)
$$(CC) $$(LTM_CFLAGS) $$(LTM_LFLAGS) $$^ -o $$@
endef
$(foreach demo, $(strip $(DEMOS)), $(eval $(call DEMO_template,$(demo))))
.PHONY: mtest
mtest:
cd mtest ; $(CC) $(LTM_CFLAGS) -O0 mtest.c $(LTM_LFLAGS) -o mtest
timing: $(LIBNAME) demo/timing.c
$(CC) $(LTM_CFLAGS) -DTIMER demo/timing.c $(LIBNAME) $(LTM_LFLAGS) -o timing
tune: $(LIBNAME)
$(MAKE) -C etc tune CFLAGS="$(LTM_CFLAGS)"
$(MAKE)
# You have to create a file .coveralls.yml with the content "repo_token: <the token>"
# in the base folder to be able to submit to coveralls
coveralls: lcov
coveralls-lcov
docs manual:
$(MAKE) -C doc/ $@ V=$(V)
.PHONY: pre_gen
pre_gen:
mkdir -p pre_gen
perl gen.pl
sed -e 's/[[:blank:]]*$$//' mpi.c > pre_gen/mpi.c
rm mpi.c
zipup: clean astyle new_file docs
@# Update the index, so diff-index won't fail in case the pdf has been created.
@# As the pdf creation modifies the tex files, git sometimes detects the
@# modified files, but misses that it's put back to its original version.
@git update-index --refresh
@git diff-index --quiet HEAD -- || ( echo "FAILURE: uncommited changes or not a git" && exit 1 )
rm -rf libtommath-$(VERSION) ltm-$(VERSION).*
@# files/dirs excluded from "git archive" are defined in .gitattributes
git archive --format=tar --prefix=libtommath-$(VERSION)/ HEAD | tar x
@echo 'fixme check'
-@(find libtommath-$(VERSION)/ -type f | xargs grep 'FIXM[E]') && echo '############## BEWARE: the "fixme" marker was found !!! ##############' || true
mkdir -p libtommath-$(VERSION)/doc
cp doc/bn.pdf libtommath-$(VERSION)/doc/
$(MAKE) -C libtommath-$(VERSION)/ pre_gen
tar -c libtommath-$(VERSION)/ | xz -6e -c - > ltm-$(VERSION).tar.xz
zip -9rq ltm-$(VERSION).zip libtommath-$(VERSION)
cp doc/bn.pdf bn-$(VERSION).pdf
rm -rf libtommath-$(VERSION)
gpg -b -a ltm-$(VERSION).tar.xz
gpg -b -a ltm-$(VERSION).zip
new_file:
perl helper.pl --update-files
perlcritic:
perlcritic *.pl doc/*.pl
astyle:
@echo " * run astyle on all sources"
@astyle --options=astylerc --formatted $(OBJECTS:.o=.c) tommath*.h demo/*.c etc/*.c mtest/mtest.c
|
Changes to libtommath/makefile.mingw.
1 2 | # MAKEFILE for MS Windows (mingw + gcc + gmake) # | | | < | | | | | | > | | | | | | | | | | | | > | < | | > | | > > | < | | | | > | > > > > < < < < | 1 2 3 4 5 6 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 | # MAKEFILE for MS Windows (mingw + gcc + gmake) # # BEWARE: variable OBJECTS is updated via helper.pl ### USAGE: # Open a command prompt with gcc + gmake in PATH and start: # # gmake -f makefile.mingw all # test.exe # gmake -f makefile.mingw PREFIX=c:\devel\libtom install #The following can be overridden from command line e.g. make -f makefile.mingw CC=gcc ARFLAGS=rcs PREFIX = c:\mingw CC = gcc AR = ar ARFLAGS = r RANLIB = ranlib STRIP = strip CFLAGS = -O2 LDFLAGS = #Compilation flags LTM_CFLAGS = -I. $(CFLAGS) LTM_LDFLAGS = $(LDFLAGS) -static-libgcc #Libraries to be created LIBMAIN_S =libtommath.a LIBMAIN_I =libtommath.dll.a LIBMAIN_D =libtommath.dll #List of objects to compile (all goes to libtommath.a) OBJECTS=bn_cutoffs.o bn_deprecated.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o bn_mp_addmod.o \ bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \ bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_decr.o bn_mp_div.o bn_mp_div_2.o \ bn_mp_div_2d.o bn_mp_div_3.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o bn_mp_dr_setup.o \ bn_mp_error_to_string.o bn_mp_exch.o bn_mp_expt_u32.o bn_mp_exptmod.o bn_mp_exteuclid.o bn_mp_fread.o \ bn_mp_from_sbin.o bn_mp_from_ubin.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_double.o bn_mp_get_i32.o \ bn_mp_get_i64.o bn_mp_get_l.o bn_mp_get_ll.o bn_mp_get_mag_u32.o bn_mp_get_mag_u64.o bn_mp_get_mag_ul.o \ bn_mp_get_mag_ull.o bn_mp_grow.o bn_mp_incr.o bn_mp_init.o bn_mp_init_copy.o bn_mp_init_i32.o \ bn_mp_init_i64.o bn_mp_init_l.o bn_mp_init_ll.o bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_size.o \ bn_mp_init_u32.o bn_mp_init_u64.o bn_mp_init_ul.o bn_mp_init_ull.o bn_mp_invmod.o bn_mp_is_square.o \ bn_mp_iseven.o bn_mp_isodd.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_log_u32.o bn_mp_lshd.o bn_mp_mod.o \ bn_mp_mod_2d.o bn_mp_mod_d.o bn_mp_montgomery_calc_normalization.o bn_mp_montgomery_reduce.o \ bn_mp_montgomery_setup.o bn_mp_mul.o bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_mulmod.o bn_mp_neg.o \ bn_mp_or.o bn_mp_pack.o bn_mp_pack_count.o bn_mp_prime_fermat.o bn_mp_prime_frobenius_underwood.o \ bn_mp_prime_is_prime.o bn_mp_prime_miller_rabin.o bn_mp_prime_next_prime.o \ bn_mp_prime_rabin_miller_trials.o bn_mp_prime_rand.o bn_mp_prime_strong_lucas_selfridge.o \ bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o bn_mp_read_radix.o bn_mp_reduce.o bn_mp_reduce_2k.o \ bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o \ bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o bn_mp_root_u32.o bn_mp_rshd.o bn_mp_sbin_size.o bn_mp_set.o \ bn_mp_set_double.o bn_mp_set_i32.o bn_mp_set_i64.o bn_mp_set_l.o bn_mp_set_ll.o bn_mp_set_u32.o \ bn_mp_set_u64.o bn_mp_set_ul.o bn_mp_set_ull.o bn_mp_shrink.o bn_mp_signed_rsh.o bn_mp_sqr.o \ bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o bn_mp_sub_d.o bn_mp_submod.o \ bn_mp_to_radix.o bn_mp_to_sbin.o bn_mp_to_ubin.o bn_mp_ubin_size.o bn_mp_unpack.o bn_mp_xor.o bn_mp_zero.o \ bn_prime_tab.o bn_s_mp_add.o bn_s_mp_balance_mul.o bn_s_mp_exptmod.o bn_s_mp_exptmod_fast.o \ bn_s_mp_get_bit.o bn_s_mp_invmod_fast.o bn_s_mp_invmod_slow.o bn_s_mp_karatsuba_mul.o \ bn_s_mp_karatsuba_sqr.o bn_s_mp_montgomery_reduce_fast.o bn_s_mp_mul_digs.o bn_s_mp_mul_digs_fast.o \ bn_s_mp_mul_high_digs.o bn_s_mp_mul_high_digs_fast.o bn_s_mp_prime_is_divisible.o \ bn_s_mp_rand_jenkins.o bn_s_mp_rand_platform.o bn_s_mp_reverse.o bn_s_mp_sqr.o bn_s_mp_sqr_fast.o \ bn_s_mp_sub.o bn_s_mp_toom_mul.o bn_s_mp_toom_sqr.o HEADERS_PUB=tommath.h HEADERS=tommath_private.h tommath_class.h tommath_superclass.h tommath_cutoffs.h $(HEADERS_PUB) #The default rule for make builds the libtommath.a library (static) default: $(LIBMAIN_S) #Dependencies on *.h $(OBJECTS): $(HEADERS) .c.o: $(CC) $(LTM_CFLAGS) -c $< -o $@ #Create libtommath.a $(LIBMAIN_S): $(OBJECTS) $(AR) $(ARFLAGS) $@ $(OBJECTS) $(RANLIB) $@ #Create DLL + import library libtommath.dll.a $(LIBMAIN_D) $(LIBMAIN_I): $(OBJECTS) $(CC) -s -shared -o $(LIBMAIN_D) $^ -Wl,--enable-auto-import,--export-all -Wl,--out-implib=$(LIBMAIN_I) $(LTM_LDFLAGS) $(STRIP) -S $(LIBMAIN_D) #Build test suite test.exe: demo/shared.o demo/test.o $(LIBMAIN_S) $(CC) $(LTM_CFLAGS) $(LTM_LDFLAGS) $^ -o $@ @echo NOTICE: start the tests by launching test.exe test_standalone: test.exe @echo test_standalone is deprecated, please use make-target 'test.exe' all: $(LIBMAIN_S) test.exe tune: $(LIBNAME_S) $(MAKE) -C etc tune $(MAKE) clean: @-cmd /c del /Q /S *.o *.a *.exe *.dll 2>nul #Install the library + headers install: $(LIBMAIN_S) $(LIBMAIN_I) $(LIBMAIN_D) cmd /c if not exist "$(PREFIX)\bin" mkdir "$(PREFIX)\bin" cmd /c if not exist "$(PREFIX)\lib" mkdir "$(PREFIX)\lib" cmd /c if not exist "$(PREFIX)\include" mkdir "$(PREFIX)\include" copy /Y $(LIBMAIN_S) "$(PREFIX)\lib" copy /Y $(LIBMAIN_I) "$(PREFIX)\lib" copy /Y $(LIBMAIN_D) "$(PREFIX)\bin" copy /Y tommath*.h "$(PREFIX)\include" |
Changes to libtommath/makefile.msvc.
1 2 | # MAKEFILE for MS Windows (nmake + Windows SDK) # | | | < | | | | | | > | | | | | | | | | | | | > | < | | > | | > > | < | | | | | > | > > > > < < < < | 1 2 3 4 5 6 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 | # MAKEFILE for MS Windows (nmake + Windows SDK) # # BEWARE: variable OBJECTS is updated via helper.pl ### USAGE: # Open a command prompt with WinSDK variables set and start: # # nmake -f makefile.msvc all # test.exe # nmake -f makefile.msvc PREFIX=c:\devel\libtom install #The following can be overridden from command line e.g. make -f makefile.msvc CC=gcc ARFLAGS=rcs PREFIX = c:\devel CFLAGS = /Ox #Compilation flags LTM_CFLAGS = /nologo /I./ /D_CRT_SECURE_NO_WARNINGS /D_CRT_NONSTDC_NO_DEPRECATE /D__STDC_WANT_SECURE_LIB__=1 /D_CRT_HAS_CXX17=0 /Wall /wd4146 /wd4127 /wd4668 /wd4710 /wd4711 /wd4820 /wd5045 /WX $(CFLAGS) LTM_LDFLAGS = advapi32.lib #Libraries to be created (this makefile builds only static libraries) LIBMAIN_S =tommath.lib #List of objects to compile (all goes to tommath.lib) OBJECTS=bn_cutoffs.obj bn_deprecated.obj bn_mp_2expt.obj bn_mp_abs.obj bn_mp_add.obj bn_mp_add_d.obj bn_mp_addmod.obj \ bn_mp_and.obj bn_mp_clamp.obj bn_mp_clear.obj bn_mp_clear_multi.obj bn_mp_cmp.obj bn_mp_cmp_d.obj bn_mp_cmp_mag.obj \ bn_mp_cnt_lsb.obj bn_mp_complement.obj bn_mp_copy.obj bn_mp_count_bits.obj bn_mp_decr.obj bn_mp_div.obj bn_mp_div_2.obj \ bn_mp_div_2d.obj bn_mp_div_3.obj bn_mp_div_d.obj bn_mp_dr_is_modulus.obj bn_mp_dr_reduce.obj bn_mp_dr_setup.obj \ bn_mp_error_to_string.obj bn_mp_exch.obj bn_mp_expt_u32.obj bn_mp_exptmod.obj bn_mp_exteuclid.obj bn_mp_fread.obj \ bn_mp_from_sbin.obj bn_mp_from_ubin.obj bn_mp_fwrite.obj bn_mp_gcd.obj bn_mp_get_double.obj bn_mp_get_i32.obj \ bn_mp_get_i64.obj bn_mp_get_l.obj bn_mp_get_ll.obj bn_mp_get_mag_u32.obj bn_mp_get_mag_u64.obj bn_mp_get_mag_ul.obj \ bn_mp_get_mag_ull.obj bn_mp_grow.obj bn_mp_incr.obj bn_mp_init.obj bn_mp_init_copy.obj bn_mp_init_i32.obj \ bn_mp_init_i64.obj bn_mp_init_l.obj bn_mp_init_ll.obj bn_mp_init_multi.obj bn_mp_init_set.obj bn_mp_init_size.obj \ bn_mp_init_u32.obj bn_mp_init_u64.obj bn_mp_init_ul.obj bn_mp_init_ull.obj bn_mp_invmod.obj bn_mp_is_square.obj \ bn_mp_iseven.obj bn_mp_isodd.obj bn_mp_kronecker.obj bn_mp_lcm.obj bn_mp_log_u32.obj bn_mp_lshd.obj bn_mp_mod.obj \ bn_mp_mod_2d.obj bn_mp_mod_d.obj bn_mp_montgomery_calc_normalization.obj bn_mp_montgomery_reduce.obj \ bn_mp_montgomery_setup.obj bn_mp_mul.obj bn_mp_mul_2.obj bn_mp_mul_2d.obj bn_mp_mul_d.obj bn_mp_mulmod.obj bn_mp_neg.obj \ bn_mp_or.obj bn_mp_pack.obj bn_mp_pack_count.obj bn_mp_prime_fermat.obj bn_mp_prime_frobenius_underwood.obj \ bn_mp_prime_is_prime.obj bn_mp_prime_miller_rabin.obj bn_mp_prime_next_prime.obj \ bn_mp_prime_rabin_miller_trials.obj bn_mp_prime_rand.obj bn_mp_prime_strong_lucas_selfridge.obj \ bn_mp_radix_size.obj bn_mp_radix_smap.obj bn_mp_rand.obj bn_mp_read_radix.obj bn_mp_reduce.obj bn_mp_reduce_2k.obj \ bn_mp_reduce_2k_l.obj bn_mp_reduce_2k_setup.obj bn_mp_reduce_2k_setup_l.obj bn_mp_reduce_is_2k.obj \ bn_mp_reduce_is_2k_l.obj bn_mp_reduce_setup.obj bn_mp_root_u32.obj bn_mp_rshd.obj bn_mp_sbin_size.obj bn_mp_set.obj \ bn_mp_set_double.obj bn_mp_set_i32.obj bn_mp_set_i64.obj bn_mp_set_l.obj bn_mp_set_ll.obj bn_mp_set_u32.obj \ bn_mp_set_u64.obj bn_mp_set_ul.obj bn_mp_set_ull.obj bn_mp_shrink.obj bn_mp_signed_rsh.obj bn_mp_sqr.obj \ bn_mp_sqrmod.obj bn_mp_sqrt.obj bn_mp_sqrtmod_prime.obj bn_mp_sub.obj bn_mp_sub_d.obj bn_mp_submod.obj \ bn_mp_to_radix.obj bn_mp_to_sbin.obj bn_mp_to_ubin.obj bn_mp_ubin_size.obj bn_mp_unpack.obj bn_mp_xor.obj bn_mp_zero.obj \ bn_prime_tab.obj bn_s_mp_add.obj bn_s_mp_balance_mul.obj bn_s_mp_exptmod.obj bn_s_mp_exptmod_fast.obj \ bn_s_mp_get_bit.obj bn_s_mp_invmod_fast.obj bn_s_mp_invmod_slow.obj bn_s_mp_karatsuba_mul.obj \ bn_s_mp_karatsuba_sqr.obj bn_s_mp_montgomery_reduce_fast.obj bn_s_mp_mul_digs.obj bn_s_mp_mul_digs_fast.obj \ bn_s_mp_mul_high_digs.obj bn_s_mp_mul_high_digs_fast.obj bn_s_mp_prime_is_divisible.obj \ bn_s_mp_rand_jenkins.obj bn_s_mp_rand_platform.obj bn_s_mp_reverse.obj bn_s_mp_sqr.obj bn_s_mp_sqr_fast.obj \ bn_s_mp_sub.obj bn_s_mp_toom_mul.obj bn_s_mp_toom_sqr.obj HEADERS_PUB=tommath.h HEADERS=tommath_private.h tommath_class.h tommath_superclass.h tommath_cutoffs.h $(HEADERS_PUB) #The default rule for make builds the tommath.lib library (static) default: $(LIBMAIN_S) #Dependencies on *.h $(OBJECTS): $(HEADERS) .c.obj: $(CC) $(LTM_CFLAGS) /c $< /Fo$@ #Create tommath.lib $(LIBMAIN_S): $(OBJECTS) lib /out:$(LIBMAIN_S) $(OBJECTS) #Build test suite test.exe: $(LIBMAIN_S) demo/shared.obj demo/test.obj cl $(LTM_CFLAGS) $(TOBJECTS) $(LIBMAIN_S) $(LTM_LDFLAGS) demo/shared.c demo/test.c /Fe$@ @echo NOTICE: start the tests by launching test.exe test_standalone: test.exe @echo test_standalone is deprecated, please use make-target 'test.exe' all: $(LIBMAIN_S) test.exe tune: $(LIBMAIN_S) $(MAKE) -C etc tune $(MAKE) clean: @-cmd /c del /Q /S *.OBJ *.LIB *.EXE *.DLL 2>nul #Install the library + headers install: $(LIBMAIN_S) cmd /c if not exist "$(PREFIX)\bin" mkdir "$(PREFIX)\bin" cmd /c if not exist "$(PREFIX)\lib" mkdir "$(PREFIX)\lib" cmd /c if not exist "$(PREFIX)\include" mkdir "$(PREFIX)\include" copy /Y $(LIBMAIN_S) "$(PREFIX)\lib" copy /Y tommath*.h "$(PREFIX)\include" |
Changes to libtommath/makefile.shared.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 |
ifeq ($(PLATFORM), Darwin)
LIBTOOL:=glibtool
else
LIBTOOL:=libtool
endif
endif
LTCOMPILE = $(LIBTOOL) --mode=compile --tag=CC $(CC)
LCOV_ARGS=--directory .libs --directory .
#START_INS
| > < | | | | | | > | | | | | | | | | | | | > | < | | > | | > > | | | | | < | | < | | > > > > > > | 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 |
ifeq ($(PLATFORM), Darwin)
LIBTOOL:=glibtool
else
LIBTOOL:=libtool
endif
endif
LTCOMPILE = $(LIBTOOL) --mode=compile --tag=CC $(CC)
LTLINK = $(LIBTOOL) --mode=link --tag=CC $(CC)
LCOV_ARGS=--directory .libs --directory .
#START_INS
OBJECTS=bn_cutoffs.o bn_deprecated.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o bn_mp_addmod.o \
bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \
bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_decr.o bn_mp_div.o bn_mp_div_2.o \
bn_mp_div_2d.o bn_mp_div_3.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o bn_mp_dr_setup.o \
bn_mp_error_to_string.o bn_mp_exch.o bn_mp_expt_u32.o bn_mp_exptmod.o bn_mp_exteuclid.o bn_mp_fread.o \
bn_mp_from_sbin.o bn_mp_from_ubin.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_double.o bn_mp_get_i32.o \
bn_mp_get_i64.o bn_mp_get_l.o bn_mp_get_ll.o bn_mp_get_mag_u32.o bn_mp_get_mag_u64.o bn_mp_get_mag_ul.o \
bn_mp_get_mag_ull.o bn_mp_grow.o bn_mp_incr.o bn_mp_init.o bn_mp_init_copy.o bn_mp_init_i32.o \
bn_mp_init_i64.o bn_mp_init_l.o bn_mp_init_ll.o bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_size.o \
bn_mp_init_u32.o bn_mp_init_u64.o bn_mp_init_ul.o bn_mp_init_ull.o bn_mp_invmod.o bn_mp_is_square.o \
bn_mp_iseven.o bn_mp_isodd.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_log_u32.o bn_mp_lshd.o bn_mp_mod.o \
bn_mp_mod_2d.o bn_mp_mod_d.o bn_mp_montgomery_calc_normalization.o bn_mp_montgomery_reduce.o \
bn_mp_montgomery_setup.o bn_mp_mul.o bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_mulmod.o bn_mp_neg.o \
bn_mp_or.o bn_mp_pack.o bn_mp_pack_count.o bn_mp_prime_fermat.o bn_mp_prime_frobenius_underwood.o \
bn_mp_prime_is_prime.o bn_mp_prime_miller_rabin.o bn_mp_prime_next_prime.o \
bn_mp_prime_rabin_miller_trials.o bn_mp_prime_rand.o bn_mp_prime_strong_lucas_selfridge.o \
bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o bn_mp_read_radix.o bn_mp_reduce.o bn_mp_reduce_2k.o \
bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o \
bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o bn_mp_root_u32.o bn_mp_rshd.o bn_mp_sbin_size.o bn_mp_set.o \
bn_mp_set_double.o bn_mp_set_i32.o bn_mp_set_i64.o bn_mp_set_l.o bn_mp_set_ll.o bn_mp_set_u32.o \
bn_mp_set_u64.o bn_mp_set_ul.o bn_mp_set_ull.o bn_mp_shrink.o bn_mp_signed_rsh.o bn_mp_sqr.o \
bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o bn_mp_sub_d.o bn_mp_submod.o \
bn_mp_to_radix.o bn_mp_to_sbin.o bn_mp_to_ubin.o bn_mp_ubin_size.o bn_mp_unpack.o bn_mp_xor.o bn_mp_zero.o \
bn_prime_tab.o bn_s_mp_add.o bn_s_mp_balance_mul.o bn_s_mp_exptmod.o bn_s_mp_exptmod_fast.o \
bn_s_mp_get_bit.o bn_s_mp_invmod_fast.o bn_s_mp_invmod_slow.o bn_s_mp_karatsuba_mul.o \
bn_s_mp_karatsuba_sqr.o bn_s_mp_montgomery_reduce_fast.o bn_s_mp_mul_digs.o bn_s_mp_mul_digs_fast.o \
bn_s_mp_mul_high_digs.o bn_s_mp_mul_high_digs_fast.o bn_s_mp_prime_is_divisible.o \
bn_s_mp_rand_jenkins.o bn_s_mp_rand_platform.o bn_s_mp_reverse.o bn_s_mp_sqr.o bn_s_mp_sqr_fast.o \
bn_s_mp_sub.o bn_s_mp_toom_mul.o bn_s_mp_toom_sqr.o
#END_INS
objs: $(OBJECTS)
.c.o: $(HEADERS)
$(LTCOMPILE) $(LTM_CFLAGS) $(LTM_LDFLAGS) -o $@ -c $<
LOBJECTS = $(OBJECTS:.o=.lo)
$(LIBNAME): $(OBJECTS)
$(LTLINK) $(LTM_LDFLAGS) $(LOBJECTS) -o $(LIBNAME) -rpath $(LIBPATH) -version-info $(VERSION_SO) $(LTM_LIBTOOLFLAGS)
install: $(LIBNAME)
install -d $(DESTDIR)$(LIBPATH)
install -d $(DESTDIR)$(INCPATH)
$(LIBTOOL) --mode=install install -m 644 $(LIBNAME) $(DESTDIR)$(LIBPATH)/$(LIBNAME)
install -m 644 $(HEADERS_PUB) $(DESTDIR)$(INCPATH)
sed -e 's,^prefix=.*,prefix=$(PREFIX),' -e 's,^Version:.*,Version: $(VERSION_PC),' libtommath.pc.in > libtommath.pc
install -d $(DESTDIR)$(LIBPATH)/pkgconfig
install -m 644 libtommath.pc $(DESTDIR)$(LIBPATH)/pkgconfig/
uninstall:
$(LIBTOOL) --mode=uninstall rm $(DESTDIR)$(LIBPATH)/$(LIBNAME)
rm $(HEADERS_PUB:%=$(DESTDIR)$(INCPATH)/%)
rm $(DESTDIR)$(LIBPATH)/pkgconfig/libtommath.pc
test_standalone: test
@echo "test_standalone is deprecated, please use make-target 'test'"
test mtest_opponent: demo/shared.o $(LIBNAME) | demo/test.o demo/mtest_opponent.o
$(LTLINK) $(LTM_LDFLAGS) demo/$@.o $^ -o $@
.PHONY: mtest
mtest:
cd mtest ; $(CC) $(LTM_CFLAGS) -O0 mtest.c $(LTM_LDFLAGS) -o mtest
timing: $(LIBNAME) demo/timing.c
$(LTLINK) $(LTM_CFLAGS) $(LTM_LDFLAGS) -DTIMER demo/timing.c $(LIBNAME) -o timing
tune: $(LIBNAME)
$(LTCOMPILE) $(LTM_CFLAGS) -c etc/tune.c -o etc/tune.o
$(LTLINK) $(LTM_LDFLAGS) -o etc/tune etc/tune.o $(LIBNAME)
cd etc/; /bin/sh tune_it.sh; cd ..
$(MAKE) -f makefile.shared
|
Changes to libtommath/makefile.unix.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 | CC = cc AR = ar ARFLAGS = r RANLIB = ranlib CFLAGS = -O2 LDFLAGS = | | < | | | | | | > | | | | | | | | | | | | > | < | | > | | > > | < | | | > | > > > > | < < < < | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 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 | CC = cc AR = ar ARFLAGS = r RANLIB = ranlib CFLAGS = -O2 LDFLAGS = VERSION = 1.2.0 #Compilation flags LTM_CFLAGS = -I. $(CFLAGS) LTM_LDFLAGS = $(LDFLAGS) #Library to be created (this makefile builds only static library) LIBMAIN_S = libtommath.a OBJECTS=bn_cutoffs.o bn_deprecated.o bn_mp_2expt.o bn_mp_abs.o bn_mp_add.o bn_mp_add_d.o bn_mp_addmod.o \ bn_mp_and.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \ bn_mp_cnt_lsb.o bn_mp_complement.o bn_mp_copy.o bn_mp_count_bits.o bn_mp_decr.o bn_mp_div.o bn_mp_div_2.o \ bn_mp_div_2d.o bn_mp_div_3.o bn_mp_div_d.o bn_mp_dr_is_modulus.o bn_mp_dr_reduce.o bn_mp_dr_setup.o \ bn_mp_error_to_string.o bn_mp_exch.o bn_mp_expt_u32.o bn_mp_exptmod.o bn_mp_exteuclid.o bn_mp_fread.o \ bn_mp_from_sbin.o bn_mp_from_ubin.o bn_mp_fwrite.o bn_mp_gcd.o bn_mp_get_double.o bn_mp_get_i32.o \ bn_mp_get_i64.o bn_mp_get_l.o bn_mp_get_ll.o bn_mp_get_mag_u32.o bn_mp_get_mag_u64.o bn_mp_get_mag_ul.o \ bn_mp_get_mag_ull.o bn_mp_grow.o bn_mp_incr.o bn_mp_init.o bn_mp_init_copy.o bn_mp_init_i32.o \ bn_mp_init_i64.o bn_mp_init_l.o bn_mp_init_ll.o bn_mp_init_multi.o bn_mp_init_set.o bn_mp_init_size.o \ bn_mp_init_u32.o bn_mp_init_u64.o bn_mp_init_ul.o bn_mp_init_ull.o bn_mp_invmod.o bn_mp_is_square.o \ bn_mp_iseven.o bn_mp_isodd.o bn_mp_kronecker.o bn_mp_lcm.o bn_mp_log_u32.o bn_mp_lshd.o bn_mp_mod.o \ bn_mp_mod_2d.o bn_mp_mod_d.o bn_mp_montgomery_calc_normalization.o bn_mp_montgomery_reduce.o \ bn_mp_montgomery_setup.o bn_mp_mul.o bn_mp_mul_2.o bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_mulmod.o bn_mp_neg.o \ bn_mp_or.o bn_mp_pack.o bn_mp_pack_count.o bn_mp_prime_fermat.o bn_mp_prime_frobenius_underwood.o \ bn_mp_prime_is_prime.o bn_mp_prime_miller_rabin.o bn_mp_prime_next_prime.o \ bn_mp_prime_rabin_miller_trials.o bn_mp_prime_rand.o bn_mp_prime_strong_lucas_selfridge.o \ bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_rand.o bn_mp_read_radix.o bn_mp_reduce.o bn_mp_reduce_2k.o \ bn_mp_reduce_2k_l.o bn_mp_reduce_2k_setup.o bn_mp_reduce_2k_setup_l.o bn_mp_reduce_is_2k.o \ bn_mp_reduce_is_2k_l.o bn_mp_reduce_setup.o bn_mp_root_u32.o bn_mp_rshd.o bn_mp_sbin_size.o bn_mp_set.o \ bn_mp_set_double.o bn_mp_set_i32.o bn_mp_set_i64.o bn_mp_set_l.o bn_mp_set_ll.o bn_mp_set_u32.o \ bn_mp_set_u64.o bn_mp_set_ul.o bn_mp_set_ull.o bn_mp_shrink.o bn_mp_signed_rsh.o bn_mp_sqr.o \ bn_mp_sqrmod.o bn_mp_sqrt.o bn_mp_sqrtmod_prime.o bn_mp_sub.o bn_mp_sub_d.o bn_mp_submod.o \ bn_mp_to_radix.o bn_mp_to_sbin.o bn_mp_to_ubin.o bn_mp_ubin_size.o bn_mp_unpack.o bn_mp_xor.o bn_mp_zero.o \ bn_prime_tab.o bn_s_mp_add.o bn_s_mp_balance_mul.o bn_s_mp_exptmod.o bn_s_mp_exptmod_fast.o \ bn_s_mp_get_bit.o bn_s_mp_invmod_fast.o bn_s_mp_invmod_slow.o bn_s_mp_karatsuba_mul.o \ bn_s_mp_karatsuba_sqr.o bn_s_mp_montgomery_reduce_fast.o bn_s_mp_mul_digs.o bn_s_mp_mul_digs_fast.o \ bn_s_mp_mul_high_digs.o bn_s_mp_mul_high_digs_fast.o bn_s_mp_prime_is_divisible.o \ bn_s_mp_rand_jenkins.o bn_s_mp_rand_platform.o bn_s_mp_reverse.o bn_s_mp_sqr.o bn_s_mp_sqr_fast.o \ bn_s_mp_sub.o bn_s_mp_toom_mul.o bn_s_mp_toom_sqr.o HEADERS_PUB=tommath.h HEADERS=tommath_private.h tommath_class.h tommath_superclass.h tommath_cutoffs.h $(HEADERS_PUB) #The default rule for make builds the libtommath.a library (static) default: $(LIBMAIN_S) #Dependencies on *.h $(OBJECTS): $(HEADERS) #This is necessary for compatibility with BSD make (namely on OpenBSD) .SUFFIXES: .o .c .c.o: $(CC) $(LTM_CFLAGS) -c $< -o $@ #Create libtommath.a $(LIBMAIN_S): $(OBJECTS) $(AR) $(ARFLAGS) $@ $(OBJECTS) $(RANLIB) $@ #Build test_standalone suite test: demo/shared.o demo/test.o $(LIBMAIN_S) $(CC) $(LTM_CFLAGS) $(LTM_LDFLAGS) $^ -o $@ @echo "NOTICE: start the tests by: ./test" test_standalone: test @echo "test_standalone is deprecated, please use make-target 'test'" all: $(LIBMAIN_S) test tune: $(LIBMAIN_S) $(MAKE) -C etc tune $(MAKE) #NOTE: this makefile works also on cygwin, thus we need to delete *.exe clean: -@rm -f $(OBJECTS) $(LIBMAIN_S) -@rm -f demo/main.o demo/opponent.o demo/test.o test test.exe #Install the library + headers install: $(LIBMAIN_S) @mkdir -p $(DESTDIR)$(INCPATH) $(DESTDIR)$(LIBPATH)/pkgconfig @cp $(LIBMAIN_S) $(DESTDIR)$(LIBPATH)/ @cp $(HEADERS_PUB) $(DESTDIR)$(INCPATH)/ @sed -e 's,^prefix=.*,prefix=$(PREFIX),' -e 's,^Version:.*,Version: $(VERSION),' libtommath.pc.in > $(DESTDIR)$(LIBPATH)/pkgconfig/libtommath.pc |
Changes to libtommath/makefile_include.mk.
1 2 3 4 5 | # # Include makefile for libtommath # #version of library | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 |
#
# Include makefile for libtommath
#
#version of library
VERSION=1.2.0
VERSION_PC=1.2.0
VERSION_SO=3:0:2
PLATFORM := $(shell uname | sed -e 's/_.*//')
# default make target
default: ${LIBNAME}
# Compiler and Linker Names
|
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | ifneq (,$(findstring $(PLATFORM),FreeBSD OpenBSD DragonFly NetBSD)) MAKE=gmake else MAKE=make endif endif | | > > > > | | > > > > > > > > > | | | | | < | | | > > > > > > > | | | | | < < > > > > | | | | > | | | 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 |
ifneq (,$(findstring $(PLATFORM),FreeBSD OpenBSD DragonFly NetBSD))
MAKE=gmake
else
MAKE=make
endif
endif
LTM_CFLAGS += -I./ -Wall -Wsign-compare -Wextra -Wshadow
ifdef SANITIZER
LTM_CFLAGS += -fsanitize=undefined -fno-sanitize-recover=all -fno-sanitize=float-divide-by-zero
endif
ifndef NO_ADDTL_WARNINGS
# additional warnings
LTM_CFLAGS += -Wdeclaration-after-statement -Wbad-function-cast -Wcast-align
LTM_CFLAGS += -Wstrict-prototypes -Wpointer-arith
endif
ifdef CONV_WARNINGS
LTM_CFLAGS += -std=c89 -Wconversion -Wsign-conversion
ifeq ($(CONV_WARNINGS), strict)
LTM_CFLAGS += -DMP_USE_ENUMS -Wc++-compat
endif
else
LTM_CFLAGS += -Wsystem-headers
endif
ifdef COMPILE_DEBUG
#debug
LTM_CFLAGS += -g3
endif
ifdef COMPILE_SIZE
#for size
LTM_CFLAGS += -Os
else
ifndef IGNORE_SPEED
#for speed
LTM_CFLAGS += -O3 -funroll-loops
#x86 optimizations [should be valid for any GCC install though]
LTM_CFLAGS += -fomit-frame-pointer
endif
endif # COMPILE_SIZE
ifneq ($(findstring clang,$(CC)),)
LTM_CFLAGS += -Wno-typedef-redefinition -Wno-tautological-compare -Wno-builtin-requires-header
endif
ifneq ($(findstring mingw,$(CC)),)
LTM_CFLAGS += -Wno-shadow
endif
ifeq ($(PLATFORM), Darwin)
LTM_CFLAGS += -Wno-nullability-completeness
endif
ifeq ($(PLATFORM), CYGWIN)
LIBTOOLFLAGS += -no-undefined
endif
# add in the standard FLAGS
LTM_CFLAGS += $(CFLAGS)
LTM_LFLAGS += $(LFLAGS)
LTM_LDFLAGS += $(LDFLAGS)
LTM_LIBTOOLFLAGS += $(LIBTOOLFLAGS)
ifeq ($(PLATFORM),FreeBSD)
_ARCH := $(shell sysctl -b hw.machine_arch)
else
_ARCH := $(shell uname -m)
endif
# adjust coverage set
ifneq ($(filter $(_ARCH), i386 i686 x86_64 amd64 ia64),)
COVERAGE = test timing
COVERAGE_APP = ./test && ./timing
else
COVERAGE = test
COVERAGE_APP = ./test
endif
HEADERS_PUB=tommath.h
HEADERS=tommath_private.h tommath_class.h tommath_superclass.h tommath_cutoffs.h $(HEADERS_PUB)
#LIBPATH The directory for libtommath to be installed to.
#INCPATH The directory to install the header files for libtommath.
#DATAPATH The directory to install the pdf docs.
DESTDIR ?=
PREFIX ?= /usr/local
LIBPATH ?= $(PREFIX)/lib
INCPATH ?= $(PREFIX)/include
DATAPATH ?= $(PREFIX)/share/doc/libtommath/pdf
# build & run test-suite
check: test
./test
#make the code coverage of the library
#
coverage: LTM_CFLAGS += -fprofile-arcs -ftest-coverage -DTIMING_NO_LOGS
coverage: LTM_LFLAGS += -lgcov
coverage: LTM_LDFLAGS += -lgcov
coverage: $(COVERAGE)
$(COVERAGE_APP)
lcov: coverage
rm -f coverage.info
lcov --capture --no-external --no-recursion $(LCOV_ARGS) --output-file coverage.info -q
genhtml coverage.info --output-directory coverage -q
# target that removes all coverage output
cleancov-clean:
rm -f `find . -type f -name "*.info" | xargs`
rm -rf coverage/
# cleans everything - coverage output and standard 'clean'
cleancov: cleancov-clean clean
clean:
rm -f *.gcda *.gcno *.gcov *.bat *.o *.a *.obj *.lib *.exe *.dll etclib/*.o \
demo/*.o test timing mtest_opponent mtest/mtest mtest/mtest.exe tuning_list \
*.s mpi.c *.da *.dyn *.dpi tommath.tex `find . -type f | grep [~] | xargs` *.lo *.la
rm -rf .libs/ demo/.libs
${MAKE} -C etc/ clean MAKE=${MAKE}
${MAKE} -C doc/ clean MAKE=${MAKE}
|
Added libtommath/tommath.def.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 |
; libtommath
;
; Use this command to produce a 32-bit .lib file, for use in any MSVC version
; lib -machine:X86 -name:libtommath.dll -def:tommath.def -out:tommath.lib
; Use this command to produce a 64-bit .lib file, for use in any MSVC version
; lib -machine:X64 -name:libtommath.dll -def:tommath.def -out:tommath.lib
;
EXPORTS
mp_2expt
mp_abs
mp_add
mp_add_d
mp_addmod
mp_and
mp_clamp
mp_clear
mp_clear_multi
mp_cmp
mp_cmp_d
mp_cmp_mag
mp_cnt_lsb
mp_complement
mp_copy
mp_count_bits
mp_decr
mp_div
mp_div_2
mp_div_2d
mp_div_3
mp_div_d
mp_dr_is_modulus
mp_dr_reduce
mp_dr_setup
mp_error_to_string
mp_exch
mp_expt_u32
mp_exptmod
mp_exteuclid
mp_fread
mp_from_sbin
mp_from_ubin
mp_fwrite
mp_gcd
mp_get_double
mp_get_i32
mp_get_i64
mp_get_int
mp_get_l
mp_get_ll
mp_get_long
mp_get_long_long
mp_get_mag_u32
mp_get_mag_u64
mp_get_mag_ul
mp_get_mag_ull
mp_grow
mp_incr
mp_init
mp_init_copy
mp_init_i32
mp_init_i64
mp_init_l
mp_init_ll
mp_init_multi
mp_init_set
mp_init_set_int
mp_init_size
mp_init_u32
mp_init_u64
mp_init_ul
mp_init_ull
mp_invmod
mp_is_square
mp_iseven
mp_isodd
mp_kronecker
mp_lcm
mp_log_u32
mp_lshd
mp_mod
mp_mod_2d
mp_mod_d
mp_montgomery_calc_normalization
mp_montgomery_reduce
mp_montgomery_setup
mp_mul
mp_mul_2
mp_mul_2d
mp_mul_d
mp_mulmod
mp_neg
mp_or
mp_pack
mp_pack_count
mp_prime_fermat
mp_prime_frobenius_underwood
mp_prime_is_prime
mp_prime_miller_rabin
mp_prime_next_prime
mp_prime_rabin_miller_trials
mp_prime_rand
mp_prime_strong_lucas_selfridge
mp_radix_size
mp_rand
mp_read_radix
mp_reduce
mp_reduce_2k
mp_reduce_2k_l
mp_reduce_2k_setup
mp_reduce_2k_setup_l
mp_reduce_is_2k
mp_reduce_is_2k_l
mp_reduce_setup
mp_root_u32
mp_rshd
mp_sbin_size
mp_set
mp_set_double
mp_set_i32
mp_set_i64
mp_set_int
mp_set_l
mp_set_ll
mp_set_long
mp_set_long_long
mp_set_u32
mp_set_u64
mp_set_ul
mp_set_ull
mp_shrink
mp_signed_rsh
mp_sqr
mp_sqrmod
mp_sqrt
mp_sqrtmod_prime
mp_sub
mp_sub_d
mp_submod
mp_to_radix
mp_to_sbin
mp_to_ubin
mp_ubin_size
mp_unpack
mp_xor
mp_zero
|
Changes to libtommath/tommath.h.
1 2 3 4 5 6 | /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ #ifndef BN_H_ #define BN_H_ | > > | > | > > > > > > | > > > > > > > > > | | | | > > | | > | | | < < < | | | < < < | > | > | < | < < < | > | > > > > | | > > > > > | > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | > | | | > | > > > | > > | < < < > | > > > > > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | > | | | | | | | | | | | | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < < < < | < | | < < | < | | < | | < < | < < | < < | < | | | > > > > > > | > > > > > | > > | | | | > > > | | | | | | | > > > < < < < < < < < | | > | > | > | > | > > > | > | < < < | | | | | | | | | | > > > > > > | | | | | < < < < < < < | | | | | | | | | > | | | | | | | | | | | | | | | | | | | | | | | > | | | | | | | | | | | | | | > > > > > > > > > > | > | | | | | | | | > > > > > > > > | | | > | | | | | | | | | | | | | | > > > > > < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 |
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
#ifndef BN_H_
#define BN_H_
#if !defined(MP_NO_STDINT) && !defined(_STDINT_H) && !defined(_STDINT_H_) \
&& !defined(__CLANG_STDINT_H) && !defined(_STDINT)
# include <stdint.h>
#endif
#include <stddef.h>
#include <limits.h>
#ifdef LTM_NO_FILE
# warning LTM_NO_FILE has been deprecated, use MP_NO_FILE.
# define MP_NO_FILE
#endif
#ifndef MP_NO_FILE
# include <stdio.h>
#endif
#ifdef MP_8BIT
# ifdef _MSC_VER
# pragma message("8-bit (MP_8BIT) support is deprecated and will be dropped completely in the next version.")
# else
# warning "8-bit (MP_8BIT) support is deprecated and will be dropped completely in the next version."
# endif
#endif
#ifdef __cplusplus
extern "C" {
#endif
/* MS Visual C++ doesn't have a 128bit type for words, so fall back to 32bit MPI's (where words are 64bit) */
#if (defined(_MSC_VER) || defined(__LLP64__) || defined(__e2k__) || defined(__LCC__)) && !defined(MP_32BIT) && !defined(MP_64BIT)
# define MP_32BIT
#endif
/* detect 64-bit mode if possible */
#if defined(__x86_64__) || defined(_M_X64) || defined(_M_AMD64) || \
defined(__powerpc64__) || defined(__ppc64__) || defined(__PPC64__) || \
defined(__s390x__) || defined(__arch64__) || defined(__aarch64__) || \
defined(__sparcv9) || defined(__sparc_v9__) || defined(__sparc64__) || \
defined(__ia64) || defined(__ia64__) || defined(__itanium__) || defined(_M_IA64) || \
defined(__LP64__) || defined(_LP64) || defined(__64BIT__)
# if !(defined(MP_64BIT) || defined(MP_32BIT) || defined(MP_16BIT) || defined(MP_8BIT))
# if defined(__GNUC__) && !defined(__hppa)
/* we support 128bit integers only via: __attribute__((mode(TI))) */
# define MP_64BIT
# else
/* otherwise we fall back to MP_32BIT even on 64bit platforms */
# define MP_32BIT
# endif
# endif
#endif
#ifdef MP_DIGIT_BIT
# error Defining MP_DIGIT_BIT is disallowed, use MP_8/16/31/32/64BIT
#endif
/* some default configurations.
*
* A "mp_digit" must be able to hold MP_DIGIT_BIT + 1 bits
* A "mp_word" must be able to hold 2*MP_DIGIT_BIT + 1 bits
*
* At the very least a mp_digit must be able to hold 7 bits
* [any size beyond that is ok provided it doesn't overflow the data type]
*/
#ifdef MP_8BIT
typedef uint8_t mp_digit;
typedef uint16_t private_mp_word;
# define MP_DIGIT_BIT 7
#elif defined(MP_16BIT)
typedef uint16_t mp_digit;
typedef uint32_t private_mp_word;
# define MP_DIGIT_BIT 15
#elif defined(MP_64BIT)
/* for GCC only on supported platforms */
typedef uint64_t mp_digit;
#if defined(__GNUC__)
typedef unsigned long private_mp_word __attribute__((mode(TI)));
#endif
# define MP_DIGIT_BIT 60
#else
typedef uint32_t mp_digit;
typedef uint64_t private_mp_word;
# ifdef MP_31BIT
/*
* This is an extension that uses 31-bit digits.
* Please be aware that not all functions support this size, especially s_mp_mul_digs_fast
* will be reduced to work on small numbers only:
* Up to 8 limbs, 248 bits instead of up to 512 limbs, 15872 bits with MP_28BIT.
*/
# define MP_DIGIT_BIT 31
# else
/* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */
# define MP_DIGIT_BIT 28
# define MP_28BIT
# endif
#endif
/* mp_word is a private type */
#define mp_word MP_DEPRECATED_PRAGMA("mp_word has been made private") private_mp_word
#define MP_SIZEOF_MP_DIGIT (MP_DEPRECATED_PRAGMA("MP_SIZEOF_MP_DIGIT has been deprecated, use sizeof (mp_digit)") sizeof (mp_digit))
#define MP_MASK ((((mp_digit)1)<<((mp_digit)MP_DIGIT_BIT))-((mp_digit)1))
#define MP_DIGIT_MAX MP_MASK
/* Primality generation flags */
#define MP_PRIME_BBS 0x0001 /* BBS style prime */
#define MP_PRIME_SAFE 0x0002 /* Safe prime (p-1)/2 == prime */
#define MP_PRIME_2MSB_ON 0x0008 /* force 2nd MSB to 1 */
#define LTM_PRIME_BBS (MP_DEPRECATED_PRAGMA("LTM_PRIME_BBS has been deprecated, use MP_PRIME_BBS") MP_PRIME_BBS)
#define LTM_PRIME_SAFE (MP_DEPRECATED_PRAGMA("LTM_PRIME_SAFE has been deprecated, use MP_PRIME_SAFE") MP_PRIME_SAFE)
#define LTM_PRIME_2MSB_ON (MP_DEPRECATED_PRAGMA("LTM_PRIME_2MSB_ON has been deprecated, use MP_PRIME_2MSB_ON") MP_PRIME_2MSB_ON)
#ifdef MP_USE_ENUMS
typedef enum {
MP_ZPOS = 0, /* positive */
MP_NEG = 1 /* negative */
} mp_sign;
typedef enum {
MP_LT = -1, /* less than */
MP_EQ = 0, /* equal */
MP_GT = 1 /* greater than */
} mp_ord;
typedef enum {
MP_NO = 0,
MP_YES = 1
} mp_bool;
typedef enum {
MP_OKAY = 0, /* no error */
MP_ERR = -1, /* unknown error */
MP_MEM = -2, /* out of mem */
MP_VAL = -3, /* invalid input */
MP_ITER = -4, /* maximum iterations reached */
MP_BUF = -5 /* buffer overflow, supplied buffer too small */
} mp_err;
typedef enum {
MP_LSB_FIRST = -1,
MP_MSB_FIRST = 1
} mp_order;
typedef enum {
MP_LITTLE_ENDIAN = -1,
MP_NATIVE_ENDIAN = 0,
MP_BIG_ENDIAN = 1
} mp_endian;
#else
typedef int mp_sign;
#define MP_ZPOS 0 /* positive integer */
#define MP_NEG 1 /* negative */
typedef int mp_ord;
#define MP_LT -1 /* less than */
#define MP_EQ 0 /* equal to */
#define MP_GT 1 /* greater than */
typedef int mp_bool;
#define MP_YES 1
#define MP_NO 0
typedef int mp_err;
#define MP_OKAY 0 /* no error */
#define MP_ERR -1 /* unknown error */
#define MP_MEM -2 /* out of mem */
#define MP_VAL -3 /* invalid input */
#define MP_RANGE (MP_DEPRECATED_PRAGMA("MP_RANGE has been deprecated in favor of MP_VAL") MP_VAL)
#define MP_ITER -4 /* maximum iterations reached */
#define MP_BUF -5 /* buffer overflow, supplied buffer too small */
typedef int mp_order;
#define MP_LSB_FIRST -1
#define MP_MSB_FIRST 1
typedef int mp_endian;
#define MP_LITTLE_ENDIAN -1
#define MP_NATIVE_ENDIAN 0
#define MP_BIG_ENDIAN 1
#endif
/* tunable cutoffs */
#ifndef MP_FIXED_CUTOFFS
extern int
KARATSUBA_MUL_CUTOFF,
KARATSUBA_SQR_CUTOFF,
TOOM_MUL_CUTOFF,
TOOM_SQR_CUTOFF;
#endif
/* define this to use lower memory usage routines (exptmods mostly) */
/* #define MP_LOW_MEM */
/* default precision */
#ifndef MP_PREC
# ifndef MP_LOW_MEM
# define PRIVATE_MP_PREC 32 /* default digits of precision */
# elif defined(MP_8BIT)
# define PRIVATE_MP_PREC 16 /* default digits of precision */
# else
# define PRIVATE_MP_PREC 8 /* default digits of precision */
# endif
# define MP_PREC (MP_DEPRECATED_PRAGMA("MP_PREC is an internal macro") PRIVATE_MP_PREC)
#endif
/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */
#define PRIVATE_MP_WARRAY (int)(1 << (((CHAR_BIT * (int)sizeof(private_mp_word)) - (2 * MP_DIGIT_BIT)) + 1))
#define MP_WARRAY (MP_DEPRECATED_PRAGMA("MP_WARRAY is an internal macro") PRIVATE_MP_WARRAY)
#if defined(__GNUC__) && __GNUC__ >= 4
# define MP_NULL_TERMINATED __attribute__((sentinel))
#else
# define MP_NULL_TERMINATED
#endif
/*
* MP_WUR - warn unused result
* ---------------------------
*
* The result of functions annotated with MP_WUR must be
* checked and cannot be ignored.
*
* Most functions in libtommath return an error code.
* This error code must be checked in order to prevent crashes or invalid
* results.
*
* If you still want to avoid the error checks for quick and dirty programs
* without robustness guarantees, you can `#define MP_WUR` before including
* tommath.h, disabling the warnings.
*/
#ifndef MP_WUR
# if defined(__GNUC__) && __GNUC__ >= 4
# define MP_WUR __attribute__((warn_unused_result))
# else
# define MP_WUR
# endif
#endif
#if defined(__GNUC__) && (__GNUC__ * 100 + __GNUC_MINOR__ >= 405)
# define MP_DEPRECATED(x) __attribute__((deprecated("replaced by " #x)))
#elif defined(_MSC_VER) && _MSC_VER >= 1500
# define MP_DEPRECATED(x) __declspec(deprecated("replaced by " #x))
#else
# define MP_DEPRECATED(x)
#endif
#ifndef MP_NO_DEPRECATED_PRAGMA
#if defined(__GNUC__) && (__GNUC__ * 100 + __GNUC_MINOR__ >= 301)
# define PRIVATE_MP_DEPRECATED_PRAGMA(s) _Pragma(#s)
# define MP_DEPRECATED_PRAGMA(s) PRIVATE_MP_DEPRECATED_PRAGMA(GCC warning s)
#elif defined(_MSC_VER) && _MSC_VER >= 1500
# define MP_DEPRECATED_PRAGMA(s) __pragma(message(s))
#endif
#endif
#ifndef MP_DEPRECATED_PRAGMA
# define MP_DEPRECATED_PRAGMA(s)
#endif
#define DIGIT_BIT (MP_DEPRECATED_PRAGMA("DIGIT_BIT macro is deprecated, MP_DIGIT_BIT instead") MP_DIGIT_BIT)
#define USED(m) (MP_DEPRECATED_PRAGMA("USED macro is deprecated, use z->used instead") (m)->used)
#define DIGIT(m, k) (MP_DEPRECATED_PRAGMA("DIGIT macro is deprecated, use z->dp instead") (m)->dp[(k)])
#define SIGN(m) (MP_DEPRECATED_PRAGMA("SIGN macro is deprecated, use z->sign instead") (m)->sign)
/* the infamous mp_int structure */
#ifndef MP_INT_DECLARED
#define MP_INT_DECLARED
typedef struct mp_int mp_int;
#endif
struct mp_int {
int used, alloc;
mp_sign sign;
mp_digit *dp;
};
/* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */
typedef int private_mp_prime_callback(unsigned char *dst, int len, void *dat);
typedef private_mp_prime_callback MP_DEPRECATED(mp_rand_source) ltm_prime_callback;
/* error code to char* string */
const char *mp_error_to_string(mp_err code) MP_WUR;
/* ---> init and deinit bignum functions <--- */
/* init a bignum */
mp_err mp_init(mp_int *a) MP_WUR;
/* free a bignum */
void mp_clear(mp_int *a);
/* init a null terminated series of arguments */
mp_err mp_init_multi(mp_int *mp, ...) MP_NULL_TERMINATED MP_WUR;
/* clear a null terminated series of arguments */
void mp_clear_multi(mp_int *mp, ...) MP_NULL_TERMINATED;
/* exchange two ints */
void mp_exch(mp_int *a, mp_int *b);
/* shrink ram required for a bignum */
mp_err mp_shrink(mp_int *a) MP_WUR;
/* grow an int to a given size */
mp_err mp_grow(mp_int *a, int size) MP_WUR;
/* init to a given number of digits */
mp_err mp_init_size(mp_int *a, int size) MP_WUR;
/* ---> Basic Manipulations <--- */
#define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO)
mp_bool mp_iseven(const mp_int *a) MP_WUR;
mp_bool mp_isodd(const mp_int *a) MP_WUR;
#define mp_isneg(a) (((a)->sign != MP_ZPOS) ? MP_YES : MP_NO)
/* set to zero */
void mp_zero(mp_int *a);
/* get and set doubles */
double mp_get_double(const mp_int *a) MP_WUR;
mp_err mp_set_double(mp_int *a, double b) MP_WUR;
/* get integer, set integer and init with integer (int32_t) */
int32_t mp_get_i32(const mp_int *a) MP_WUR;
void mp_set_i32(mp_int *a, int32_t b);
mp_err mp_init_i32(mp_int *a, int32_t b) MP_WUR;
/* get integer, set integer and init with integer, behaves like two complement for negative numbers (uint32_t) */
#define mp_get_u32(a) ((uint32_t)mp_get_i32(a))
void mp_set_u32(mp_int *a, uint32_t b);
mp_err mp_init_u32(mp_int *a, uint32_t b) MP_WUR;
/* get integer, set integer and init with integer (int64_t) */
int64_t mp_get_i64(const mp_int *a) MP_WUR;
void mp_set_i64(mp_int *a, int64_t b);
mp_err mp_init_i64(mp_int *a, int64_t b) MP_WUR;
/* get integer, set integer and init with integer, behaves like two complement for negative numbers (uint64_t) */
#define mp_get_u64(a) ((uint64_t)mp_get_i64(a))
void mp_set_u64(mp_int *a, uint64_t b);
mp_err mp_init_u64(mp_int *a, uint64_t b) MP_WUR;
/* get magnitude */
uint32_t mp_get_mag_u32(const mp_int *a) MP_WUR;
uint64_t mp_get_mag_u64(const mp_int *a) MP_WUR;
unsigned long mp_get_mag_ul(const mp_int *a) MP_WUR;
#ifdef _MSC_VER
#define mp_get_mag_ull(a) ((unsigned __int64)mp_get_mag_u64(a))
#else
unsigned long long mp_get_mag_ull(const mp_int *a) MP_WUR;
#endif
/* get integer, set integer (long) */
long mp_get_l(const mp_int *a) MP_WUR;
void mp_set_l(mp_int *a, long b);
mp_err mp_init_l(mp_int *a, long b) MP_WUR;
/* get integer, set integer (unsigned long) */
#define mp_get_ul(a) ((unsigned long)mp_get_l(a))
void mp_set_ul(mp_int *a, unsigned long b);
mp_err mp_init_ul(mp_int *a, unsigned long b) MP_WUR;
#ifdef _MSC_VER
/* get integer, set integer (long long) */
#define mp_get_ll(a) ((__int64)mp_get_i64(a))
#define mp_set_ll(a,b) mp_set_i64(a,b)
#define mp_init_ll(a,b) mp_init_i64(a,b)
/* get integer, set integer (unsigned long long) */
#define mp_get_ull(a) ((unsigned __int64)mp_get_i64(a))
#define mp_set_ull(a,b) mp_set_u64(a,b)
#define mp_init_ull(a,b) mp_init_u64(a,b)
#else
/* get integer, set integer (long long) */
long long mp_get_ll(const mp_int *a) MP_WUR;
void mp_set_ll(mp_int *a, long long b);
mp_err mp_init_ll(mp_int *a, long long b) MP_WUR;
/* get integer, set integer (unsigned long long) */
#define mp_get_ull(a) ((unsigned long long)mp_get_ll(a))
void mp_set_ull(mp_int *a, unsigned long long b);
mp_err mp_init_ull(mp_int *a, unsigned long long b) MP_WUR;
#endif
/* set to single unsigned digit, up to MP_DIGIT_MAX */
void mp_set(mp_int *a, mp_digit b);
mp_err mp_init_set(mp_int *a, mp_digit b) MP_WUR;
/* get integer, set integer and init with integer (deprecated) */
MP_DEPRECATED(mp_get_mag_u32/mp_get_u32) unsigned long mp_get_int(const mp_int *a) MP_WUR;
MP_DEPRECATED(mp_get_mag_ul/mp_get_ul) unsigned long mp_get_long(const mp_int *a) MP_WUR;
#ifdef _MSC_VER
MP_DEPRECATED(mp_get_mag_ull/mp_get_ull) unsigned __int64 mp_get_long_long(const mp_int *a) MP_WUR;
#endif
MP_DEPRECATED(mp_set_ul) mp_err mp_set_int(mp_int *a, unsigned long b);
MP_DEPRECATED(mp_set_ul) mp_err mp_set_long(mp_int *a, unsigned long b);
#ifdef _MSC_VER
MP_DEPRECATED(mp_set_ull) mp_err mp_set_long_long(mp_int *a, unsigned __int64 b);
#endif
MP_DEPRECATED(mp_init_ul) mp_err mp_init_set_int(mp_int *a, unsigned long b) MP_WUR;
/* copy, b = a */
mp_err mp_copy(const mp_int *a, mp_int *b) MP_WUR;
/* inits and copies, a = b */
mp_err mp_init_copy(mp_int *a, const mp_int *b) MP_WUR;
/* trim unused digits */
void mp_clamp(mp_int *a);
/* export binary data */
MP_DEPRECATED(mp_pack) mp_err mp_export(void *rop, size_t *countp, int order, size_t size,
int endian, size_t nails, const mp_int *op) MP_WUR;
/* import binary data */
MP_DEPRECATED(mp_unpack) mp_err mp_import(mp_int *rop, size_t count, int order,
size_t size, int endian, size_t nails,
const void *op) MP_WUR;
/* unpack binary data */
mp_err mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian,
size_t nails, const void *op) MP_WUR;
/* pack binary data */
size_t mp_pack_count(const mp_int *a, size_t nails, size_t size) MP_WUR;
mp_err mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order, size_t size,
mp_endian endian, size_t nails, const mp_int *op) MP_WUR;
/* ---> digit manipulation <--- */
/* right shift by "b" digits */
void mp_rshd(mp_int *a, int b);
/* left shift by "b" digits */
mp_err mp_lshd(mp_int *a, int b) MP_WUR;
/* c = a / 2**b, implemented as c = a >> b */
mp_err mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d) MP_WUR;
/* b = a/2 */
mp_err mp_div_2(const mp_int *a, mp_int *b) MP_WUR;
/* a/3 => 3c + d == a */
mp_err mp_div_3(const mp_int *a, mp_int *c, mp_digit *d) MP_WUR;
/* c = a * 2**b, implemented as c = a << b */
mp_err mp_mul_2d(const mp_int *a, int b, mp_int *c) MP_WUR;
/* b = a*2 */
mp_err mp_mul_2(const mp_int *a, mp_int *b) MP_WUR;
/* c = a mod 2**b */
mp_err mp_mod_2d(const mp_int *a, int b, mp_int *c) MP_WUR;
/* computes a = 2**b */
mp_err mp_2expt(mp_int *a, int b) MP_WUR;
/* Counts the number of lsbs which are zero before the first zero bit */
int mp_cnt_lsb(const mp_int *a) MP_WUR;
/* I Love Earth! */
/* makes a pseudo-random mp_int of a given size */
mp_err mp_rand(mp_int *a, int digits) MP_WUR;
/* makes a pseudo-random small int of a given size */
MP_DEPRECATED(mp_rand) mp_err mp_rand_digit(mp_digit *r) MP_WUR;
/* use custom random data source instead of source provided the platform */
void mp_rand_source(mp_err(*source)(void *out, size_t size));
#ifdef MP_PRNG_ENABLE_LTM_RNG
# warning MP_PRNG_ENABLE_LTM_RNG has been deprecated, use mp_rand_source instead.
/* A last resort to provide random data on systems without any of the other
* implemented ways to gather entropy.
* It is compatible with `rng_get_bytes()` from libtomcrypt so you could
* provide that one and then set `ltm_rng = rng_get_bytes;` */
extern unsigned long (*ltm_rng)(unsigned char *out, unsigned long outlen, void (*callback)(void));
extern void (*ltm_rng_callback)(void);
#endif
/* ---> binary operations <--- */
/* Checks the bit at position b and returns MP_YES
* if the bit is 1, MP_NO if it is 0 and MP_VAL
* in case of error
*/
MP_DEPRECATED(s_mp_get_bit) int mp_get_bit(const mp_int *a, int b) MP_WUR;
/* c = a XOR b (two complement) */
MP_DEPRECATED(mp_xor) mp_err mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
mp_err mp_xor(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
/* c = a OR b (two complement) */
MP_DEPRECATED(mp_or) mp_err mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
mp_err mp_or(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
/* c = a AND b (two complement) */
MP_DEPRECATED(mp_and) mp_err mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
mp_err mp_and(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
/* b = ~a (bitwise not, two complement) */
mp_err mp_complement(const mp_int *a, mp_int *b) MP_WUR;
/* right shift with sign extension */
MP_DEPRECATED(mp_signed_rsh) mp_err mp_tc_div_2d(const mp_int *a, int b, mp_int *c) MP_WUR;
mp_err mp_signed_rsh(const mp_int *a, int b, mp_int *c) MP_WUR;
/* ---> Basic arithmetic <--- */
/* b = -a */
mp_err mp_neg(const mp_int *a, mp_int *b) MP_WUR;
/* b = |a| */
mp_err mp_abs(const mp_int *a, mp_int *b) MP_WUR;
/* compare a to b */
mp_ord mp_cmp(const mp_int *a, const mp_int *b) MP_WUR;
/* compare |a| to |b| */
mp_ord mp_cmp_mag(const mp_int *a, const mp_int *b) MP_WUR;
/* c = a + b */
mp_err mp_add(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
/* c = a - b */
mp_err mp_sub(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
/* c = a * b */
mp_err mp_mul(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
/* b = a*a */
mp_err mp_sqr(const mp_int *a, mp_int *b) MP_WUR;
/* a/b => cb + d == a */
mp_err mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d) MP_WUR;
/* c = a mod b, 0 <= c < b */
mp_err mp_mod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
/* Increment "a" by one like "a++". Changes input! */
mp_err mp_incr(mp_int *a) MP_WUR;
/* Decrement "a" by one like "a--". Changes input! */
mp_err mp_decr(mp_int *a) MP_WUR;
/* ---> single digit functions <--- */
/* compare against a single digit */
mp_ord mp_cmp_d(const mp_int *a, mp_digit b) MP_WUR;
/* c = a + b */
mp_err mp_add_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
/* c = a - b */
mp_err mp_sub_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
/* c = a * b */
mp_err mp_mul_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
/* a/b => cb + d == a */
mp_err mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d) MP_WUR;
/* c = a mod b, 0 <= c < b */
mp_err mp_mod_d(const mp_int *a, mp_digit b, mp_digit *c) MP_WUR;
/* ---> number theory <--- */
/* d = a + b (mod c) */
mp_err mp_addmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR;
/* d = a - b (mod c) */
mp_err mp_submod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR;
/* d = a * b (mod c) */
mp_err mp_mulmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR;
/* c = a * a (mod b) */
mp_err mp_sqrmod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
/* c = 1/a (mod b) */
mp_err mp_invmod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
/* c = (a, b) */
mp_err mp_gcd(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
/* produces value such that U1*a + U2*b = U3 */
mp_err mp_exteuclid(const mp_int *a, const mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3) MP_WUR;
/* c = [a, b] or (a*b)/(a, b) */
mp_err mp_lcm(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
/* finds one of the b'th root of a, such that |c|**b <= |a|
*
* returns error if a < 0 and b is even
*/
mp_err mp_root_u32(const mp_int *a, uint32_t b, mp_int *c) MP_WUR;
MP_DEPRECATED(mp_root_u32) mp_err mp_n_root(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
MP_DEPRECATED(mp_root_u32) mp_err mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) MP_WUR;
/* special sqrt algo */
mp_err mp_sqrt(const mp_int *arg, mp_int *ret) MP_WUR;
/* special sqrt (mod prime) */
mp_err mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret) MP_WUR;
/* is number a square? */
mp_err mp_is_square(const mp_int *arg, mp_bool *ret) MP_WUR;
/* computes the jacobi c = (a | n) (or Legendre if b is prime) */
MP_DEPRECATED(mp_kronecker) mp_err mp_jacobi(const mp_int *a, const mp_int *n, int *c) MP_WUR;
/* computes the Kronecker symbol c = (a | p) (like jacobi() but with {a,p} in Z */
mp_err mp_kronecker(const mp_int *a, const mp_int *p, int *c) MP_WUR;
/* used to setup the Barrett reduction for a given modulus b */
mp_err mp_reduce_setup(mp_int *a, const mp_int *b) MP_WUR;
/* Barrett Reduction, computes a (mod b) with a precomputed value c
*
* Assumes that 0 < x <= m*m, note if 0 > x > -(m*m) then you can merely
* compute the reduction as -1 * mp_reduce(mp_abs(x)) [pseudo code].
*/
mp_err mp_reduce(mp_int *x, const mp_int *m, const mp_int *mu) MP_WUR;
/* setups the montgomery reduction */
mp_err mp_montgomery_setup(const mp_int *n, mp_digit *rho) MP_WUR;
/* computes a = B**n mod b without division or multiplication useful for
* normalizing numbers in a Montgomery system.
*/
mp_err mp_montgomery_calc_normalization(mp_int *a, const mp_int *b) MP_WUR;
/* computes x/R == x (mod N) via Montgomery Reduction */
mp_err mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho) MP_WUR;
/* returns 1 if a is a valid DR modulus */
mp_bool mp_dr_is_modulus(const mp_int *a) MP_WUR;
/* sets the value of "d" required for mp_dr_reduce */
void mp_dr_setup(const mp_int *a, mp_digit *d);
/* reduces a modulo n using the Diminished Radix method */
mp_err mp_dr_reduce(mp_int *x, const mp_int *n, mp_digit k) MP_WUR;
/* returns true if a can be reduced with mp_reduce_2k */
mp_bool mp_reduce_is_2k(const mp_int *a) MP_WUR;
/* determines k value for 2k reduction */
mp_err mp_reduce_2k_setup(const mp_int *a, mp_digit *d) MP_WUR;
/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */
mp_err mp_reduce_2k(mp_int *a, const mp_int *n, mp_digit d) MP_WUR;
/* returns true if a can be reduced with mp_reduce_2k_l */
mp_bool mp_reduce_is_2k_l(const mp_int *a) MP_WUR;
/* determines k value for 2k reduction */
mp_err mp_reduce_2k_setup_l(const mp_int *a, mp_int *d) MP_WUR;
/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */
mp_err mp_reduce_2k_l(mp_int *a, const mp_int *n, const mp_int *d) MP_WUR;
/* Y = G**X (mod P) */
mp_err mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y) MP_WUR;
/* ---> Primes <--- */
/* number of primes */
#ifdef MP_8BIT
# define PRIVATE_MP_PRIME_TAB_SIZE 31
#else
# define PRIVATE_MP_PRIME_TAB_SIZE 256
#endif
#define PRIME_SIZE (MP_DEPRECATED_PRAGMA("PRIME_SIZE has been made internal") PRIVATE_MP_PRIME_TAB_SIZE)
/* table of first PRIME_SIZE primes */
MP_DEPRECATED(internal) extern const mp_digit ltm_prime_tab[PRIVATE_MP_PRIME_TAB_SIZE];
/* result=1 if a is divisible by one of the first PRIME_SIZE primes */
MP_DEPRECATED(mp_prime_is_prime) mp_err mp_prime_is_divisible(const mp_int *a, mp_bool *result) MP_WUR;
/* performs one Fermat test of "a" using base "b".
* Sets result to 0 if composite or 1 if probable prime
*/
mp_err mp_prime_fermat(const mp_int *a, const mp_int *b, mp_bool *result) MP_WUR;
/* performs one Miller-Rabin test of "a" using base "b".
* Sets result to 0 if composite or 1 if probable prime
*/
mp_err mp_prime_miller_rabin(const mp_int *a, const mp_int *b, mp_bool *result) MP_WUR;
/* This gives [for a given bit size] the number of trials required
* such that Miller-Rabin gives a prob of failure lower than 2^-96
*/
int mp_prime_rabin_miller_trials(int size) MP_WUR;
/* performs one strong Lucas-Selfridge test of "a".
* Sets result to 0 if composite or 1 if probable prime
*/
mp_err mp_prime_strong_lucas_selfridge(const mp_int *a, mp_bool *result) MP_WUR;
/* performs one Frobenius test of "a" as described by Paul Underwood.
* Sets result to 0 if composite or 1 if probable prime
*/
mp_err mp_prime_frobenius_underwood(const mp_int *N, mp_bool *result) MP_WUR;
/* performs t random rounds of Miller-Rabin on "a" additional to
* bases 2 and 3. Also performs an initial sieve of trial
* division. Determines if "a" is prime with probability
* of error no more than (1/4)**t.
* Both a strong Lucas-Selfridge to complete the BPSW test
* and a separate Frobenius test are available at compile time.
* With t<0 a deterministic test is run for primes up to
* 318665857834031151167461. With t<13 (abs(t)-13) additional
* tests with sequential small primes are run starting at 43.
* Is Fips 186.4 compliant if called with t as computed by
* mp_prime_rabin_miller_trials();
*
* Sets result to 1 if probably prime, 0 otherwise
*/
mp_err mp_prime_is_prime(const mp_int *a, int t, mp_bool *result) MP_WUR;
/* finds the next prime after the number "a" using "t" trials
* of Miller-Rabin.
*
* bbs_style = 1 means the prime must be congruent to 3 mod 4
*/
mp_err mp_prime_next_prime(mp_int *a, int t, int bbs_style) MP_WUR;
/* makes a truly random prime of a given size (bytes),
* call with bbs = 1 if you want it to be congruent to 3 mod 4
*
* You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can
* have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself
* so it can be NULL
*
* The prime generated will be larger than 2^(8*size).
*/
#define mp_prime_random(a, t, size, bbs, cb, dat) (MP_DEPRECATED_PRAGMA("mp_prime_random has been deprecated, use mp_prime_rand instead") mp_prime_random_ex(a, t, ((size) * 8) + 1, (bbs==1)?MP_PRIME_BBS:0, cb, dat))
/* makes a truly random prime of a given size (bits),
*
* Flags are as follows:
*
* MP_PRIME_BBS - make prime congruent to 3 mod 4
* MP_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies MP_PRIME_BBS)
* MP_PRIME_2MSB_ON - make the 2nd highest bit one
*
* You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can
* have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself
* so it can be NULL
*
*/
MP_DEPRECATED(mp_prime_rand) mp_err mp_prime_random_ex(mp_int *a, int t, int size, int flags,
private_mp_prime_callback cb, void *dat) MP_WUR;
mp_err mp_prime_rand(mp_int *a, int t, int size, int flags) MP_WUR;
/* Integer logarithm to integer base */
mp_err mp_log_u32(const mp_int *a, uint32_t base, uint32_t *c) MP_WUR;
/* c = a**b */
mp_err mp_expt_u32(const mp_int *a, uint32_t b, mp_int *c) MP_WUR;
MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) MP_WUR;
/* ---> radix conversion <--- */
int mp_count_bits(const mp_int *a) MP_WUR;
MP_DEPRECATED(mp_ubin_size) int mp_unsigned_bin_size(const mp_int *a) MP_WUR;
MP_DEPRECATED(mp_from_ubin) mp_err mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c) MP_WUR;
MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin(const mp_int *a, unsigned char *b) MP_WUR;
MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) MP_WUR;
MP_DEPRECATED(mp_sbin_size) int mp_signed_bin_size(const mp_int *a) MP_WUR;
MP_DEPRECATED(mp_from_sbin) mp_err mp_read_signed_bin(mp_int *a, const unsigned char *b, int c) MP_WUR;
MP_DEPRECATED(mp_to_sbin) mp_err mp_to_signed_bin(const mp_int *a, unsigned char *b) MP_WUR;
MP_DEPRECATED(mp_to_sbin) mp_err mp_to_signed_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) MP_WUR;
size_t mp_ubin_size(const mp_int *a) MP_WUR;
mp_err mp_from_ubin(mp_int *a, const unsigned char *buf, size_t size) MP_WUR;
mp_err mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR;
size_t mp_sbin_size(const mp_int *a) MP_WUR;
mp_err mp_from_sbin(mp_int *a, const unsigned char *buf, size_t size) MP_WUR;
mp_err mp_to_sbin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR;
mp_err mp_read_radix(mp_int *a, const char *str, int radix) MP_WUR;
MP_DEPRECATED(mp_to_radix) mp_err mp_toradix(const mp_int *a, char *str, int radix) MP_WUR;
MP_DEPRECATED(mp_to_radix) mp_err mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) MP_WUR;
mp_err mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) MP_WUR;
mp_err mp_radix_size(const mp_int *a, int radix, int *size) MP_WUR;
#ifndef MP_NO_FILE
mp_err mp_fread(mp_int *a, int radix, FILE *stream) MP_WUR;
mp_err mp_fwrite(const mp_int *a, int radix, FILE *stream) MP_WUR;
#endif
#define mp_read_raw(mp, str, len) (MP_DEPRECATED_PRAGMA("replaced by mp_read_signed_bin") mp_read_signed_bin((mp), (str), (len)))
#define mp_raw_size(mp) (MP_DEPRECATED_PRAGMA("replaced by mp_signed_bin_size") mp_signed_bin_size(mp))
#define mp_toraw(mp, str) (MP_DEPRECATED_PRAGMA("replaced by mp_to_signed_bin") mp_to_signed_bin((mp), (str)))
#define mp_read_mag(mp, str, len) (MP_DEPRECATED_PRAGMA("replaced by mp_read_unsigned_bin") mp_read_unsigned_bin((mp), (str), (len))
#define mp_mag_size(mp) (MP_DEPRECATED_PRAGMA("replaced by mp_unsigned_bin_size") mp_unsigned_bin_size(mp))
#define mp_tomag(mp, str) (MP_DEPRECATED_PRAGMA("replaced by mp_to_unsigned_bin") mp_to_unsigned_bin((mp), (str)))
#define mp_tobinary(M, S) (MP_DEPRECATED_PRAGMA("replaced by mp_to_binary") mp_toradix((M), (S), 2))
#define mp_tooctal(M, S) (MP_DEPRECATED_PRAGMA("replaced by mp_to_octal") mp_toradix((M), (S), 8))
#define mp_todecimal(M, S) (MP_DEPRECATED_PRAGMA("replaced by mp_to_decimal") mp_toradix((M), (S), 10))
#define mp_tohex(M, S) (MP_DEPRECATED_PRAGMA("replaced by mp_to_hex") mp_toradix((M), (S), 16))
#define mp_to_binary(M, S, N) mp_to_radix((M), (S), (N), NULL, 2)
#define mp_to_octal(M, S, N) mp_to_radix((M), (S), (N), NULL, 8)
#define mp_to_decimal(M, S, N) mp_to_radix((M), (S), (N), NULL, 10)
#define mp_to_hex(M, S, N) mp_to_radix((M), (S), (N), NULL, 16)
#ifdef __cplusplus
}
#endif
#endif
|
Changes to libtommath/tommath_class.h.
|
| | < < < < < < < < | < > | < < < < | > | | | | | | | | > > > | > | | | | | > > > > | | | | | | > | | > | | | | < | < < > > | | | > > > > > | | | | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | | > > > > > > > > > | | | | | | | | | < < < < < < < < < < | < | < < < < < < < < < < < < < < < < | < < < | < < < < | | < < < | | < > | | | | | | | | < | < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 | /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ #if !(defined(LTM1) && defined(LTM2) && defined(LTM3)) #define LTM_INSIDE #if defined(LTM2) # define LTM3 #endif #if defined(LTM1) # define LTM2 #endif #define LTM1 #if defined(LTM_ALL) # define BN_CUTOFFS_C # define BN_DEPRECATED_C # define BN_MP_2EXPT_C # define BN_MP_ABS_C # define BN_MP_ADD_C # define BN_MP_ADD_D_C # define BN_MP_ADDMOD_C # define BN_MP_AND_C # define BN_MP_CLAMP_C # define BN_MP_CLEAR_C # define BN_MP_CLEAR_MULTI_C # define BN_MP_CMP_C # define BN_MP_CMP_D_C # define BN_MP_CMP_MAG_C # define BN_MP_CNT_LSB_C # define BN_MP_COMPLEMENT_C # define BN_MP_COPY_C # define BN_MP_COUNT_BITS_C # define BN_MP_DECR_C # define BN_MP_DIV_C # define BN_MP_DIV_2_C # define BN_MP_DIV_2D_C # define BN_MP_DIV_3_C # define BN_MP_DIV_D_C # define BN_MP_DR_IS_MODULUS_C # define BN_MP_DR_REDUCE_C # define BN_MP_DR_SETUP_C # define BN_MP_ERROR_TO_STRING_C # define BN_MP_EXCH_C # define BN_MP_EXPT_U32_C # define BN_MP_EXPTMOD_C # define BN_MP_EXTEUCLID_C # define BN_MP_FREAD_C # define BN_MP_FROM_SBIN_C # define BN_MP_FROM_UBIN_C # define BN_MP_FWRITE_C # define BN_MP_GCD_C # define BN_MP_GET_DOUBLE_C # define BN_MP_GET_I32_C # define BN_MP_GET_I64_C # define BN_MP_GET_L_C # define BN_MP_GET_LL_C # define BN_MP_GET_MAG_U32_C # define BN_MP_GET_MAG_U64_C # define BN_MP_GET_MAG_UL_C # define BN_MP_GET_MAG_ULL_C # define BN_MP_GROW_C # define BN_MP_INCR_C # define BN_MP_INIT_C # define BN_MP_INIT_COPY_C # define BN_MP_INIT_I32_C # define BN_MP_INIT_I64_C # define BN_MP_INIT_L_C # define BN_MP_INIT_LL_C # define BN_MP_INIT_MULTI_C # define BN_MP_INIT_SET_C # define BN_MP_INIT_SIZE_C # define BN_MP_INIT_U32_C # define BN_MP_INIT_U64_C # define BN_MP_INIT_UL_C # define BN_MP_INIT_ULL_C # define BN_MP_INVMOD_C # define BN_MP_IS_SQUARE_C # define BN_MP_ISEVEN_C # define BN_MP_ISODD_C # define BN_MP_KRONECKER_C # define BN_MP_LCM_C # define BN_MP_LOG_U32_C # define BN_MP_LSHD_C # define BN_MP_MOD_C # define BN_MP_MOD_2D_C # define BN_MP_MOD_D_C # define BN_MP_MONTGOMERY_CALC_NORMALIZATION_C # define BN_MP_MONTGOMERY_REDUCE_C # define BN_MP_MONTGOMERY_SETUP_C # define BN_MP_MUL_C # define BN_MP_MUL_2_C # define BN_MP_MUL_2D_C # define BN_MP_MUL_D_C # define BN_MP_MULMOD_C # define BN_MP_NEG_C # define BN_MP_OR_C # define BN_MP_PACK_C # define BN_MP_PACK_COUNT_C # define BN_MP_PRIME_FERMAT_C # define BN_MP_PRIME_FROBENIUS_UNDERWOOD_C # define BN_MP_PRIME_IS_PRIME_C # define BN_MP_PRIME_MILLER_RABIN_C # define BN_MP_PRIME_NEXT_PRIME_C # define BN_MP_PRIME_RABIN_MILLER_TRIALS_C # define BN_MP_PRIME_RAND_C # define BN_MP_PRIME_STRONG_LUCAS_SELFRIDGE_C # define BN_MP_RADIX_SIZE_C # define BN_MP_RADIX_SMAP_C # define BN_MP_RAND_C # define BN_MP_READ_RADIX_C # define BN_MP_REDUCE_C # define BN_MP_REDUCE_2K_C # define BN_MP_REDUCE_2K_L_C # define BN_MP_REDUCE_2K_SETUP_C # define BN_MP_REDUCE_2K_SETUP_L_C # define BN_MP_REDUCE_IS_2K_C # define BN_MP_REDUCE_IS_2K_L_C # define BN_MP_REDUCE_SETUP_C # define BN_MP_ROOT_U32_C # define BN_MP_RSHD_C # define BN_MP_SBIN_SIZE_C # define BN_MP_SET_C # define BN_MP_SET_DOUBLE_C # define BN_MP_SET_I32_C # define BN_MP_SET_I64_C # define BN_MP_SET_L_C # define BN_MP_SET_LL_C # define BN_MP_SET_U32_C # define BN_MP_SET_U64_C # define BN_MP_SET_UL_C # define BN_MP_SET_ULL_C # define BN_MP_SHRINK_C # define BN_MP_SIGNED_RSH_C # define BN_MP_SQR_C # define BN_MP_SQRMOD_C # define BN_MP_SQRT_C # define BN_MP_SQRTMOD_PRIME_C # define BN_MP_SUB_C # define BN_MP_SUB_D_C # define BN_MP_SUBMOD_C # define BN_MP_TO_RADIX_C # define BN_MP_TO_SBIN_C # define BN_MP_TO_UBIN_C # define BN_MP_UBIN_SIZE_C # define BN_MP_UNPACK_C # define BN_MP_XOR_C # define BN_MP_ZERO_C # define BN_PRIME_TAB_C # define BN_S_MP_ADD_C # define BN_S_MP_BALANCE_MUL_C # define BN_S_MP_EXPTMOD_C # define BN_S_MP_EXPTMOD_FAST_C # define BN_S_MP_GET_BIT_C # define BN_S_MP_INVMOD_FAST_C # define BN_S_MP_INVMOD_SLOW_C # define BN_S_MP_KARATSUBA_MUL_C # define BN_S_MP_KARATSUBA_SQR_C # define BN_S_MP_MONTGOMERY_REDUCE_FAST_C # define BN_S_MP_MUL_DIGS_C # define BN_S_MP_MUL_DIGS_FAST_C # define BN_S_MP_MUL_HIGH_DIGS_C # define BN_S_MP_MUL_HIGH_DIGS_FAST_C # define BN_S_MP_PRIME_IS_DIVISIBLE_C # define BN_S_MP_RAND_JENKINS_C # define BN_S_MP_RAND_PLATFORM_C # define BN_S_MP_REVERSE_C # define BN_S_MP_SQR_C # define BN_S_MP_SQR_FAST_C # define BN_S_MP_SUB_C # define BN_S_MP_TOOM_MUL_C # define BN_S_MP_TOOM_SQR_C #endif #endif #if defined(BN_CUTOFFS_C) #endif #if defined(BN_DEPRECATED_C) # define BN_FAST_MP_INVMOD_C # define BN_FAST_MP_MONTGOMERY_REDUCE_C # define BN_FAST_S_MP_MUL_DIGS_C # define BN_FAST_S_MP_MUL_HIGH_DIGS_C # define BN_FAST_S_MP_SQR_C # define BN_MP_AND_C # define BN_MP_BALANCE_MUL_C # define BN_MP_CMP_D_C # define BN_MP_EXPORT_C # define BN_MP_EXPTMOD_FAST_C # define BN_MP_EXPT_D_C # define BN_MP_EXPT_D_EX_C # define BN_MP_EXPT_U32_C # define BN_MP_FROM_SBIN_C # define BN_MP_FROM_UBIN_C # define BN_MP_GET_BIT_C # define BN_MP_GET_INT_C # define BN_MP_GET_LONG_C # define BN_MP_GET_LONG_LONG_C # define BN_MP_GET_MAG_U32_C # define BN_MP_GET_MAG_ULL_C # define BN_MP_GET_MAG_UL_C # define BN_MP_IMPORT_C # define BN_MP_INIT_SET_INT_C # define BN_MP_INIT_U32_C # define BN_MP_INVMOD_SLOW_C # define BN_MP_JACOBI_C # define BN_MP_KARATSUBA_MUL_C # define BN_MP_KARATSUBA_SQR_C # define BN_MP_KRONECKER_C # define BN_MP_N_ROOT_C # define BN_MP_N_ROOT_EX_C # define BN_MP_OR_C # define BN_MP_PACK_C # define BN_MP_PRIME_IS_DIVISIBLE_C # define BN_MP_PRIME_RANDOM_EX_C # define BN_MP_RAND_DIGIT_C # define BN_MP_READ_SIGNED_BIN_C # define BN_MP_READ_UNSIGNED_BIN_C # define BN_MP_ROOT_U32_C # define BN_MP_SBIN_SIZE_C # define BN_MP_SET_INT_C # define BN_MP_SET_LONG_C # define BN_MP_SET_LONG_LONG_C # define BN_MP_SET_U32_C # define BN_MP_SET_U64_C # define BN_MP_SIGNED_BIN_SIZE_C # define BN_MP_SIGNED_RSH_C # define BN_MP_TC_AND_C # define BN_MP_TC_DIV_2D_C # define BN_MP_TC_OR_C # define BN_MP_TC_XOR_C # define BN_MP_TOOM_MUL_C # define BN_MP_TOOM_SQR_C # define BN_MP_TORADIX_C # define BN_MP_TORADIX_N_C # define BN_MP_TO_RADIX_C # define BN_MP_TO_SBIN_C # define BN_MP_TO_SIGNED_BIN_C # define BN_MP_TO_SIGNED_BIN_N_C # define BN_MP_TO_UBIN_C # define BN_MP_TO_UNSIGNED_BIN_C # define BN_MP_TO_UNSIGNED_BIN_N_C # define BN_MP_UBIN_SIZE_C # define BN_MP_UNPACK_C # define BN_MP_UNSIGNED_BIN_SIZE_C # define BN_MP_XOR_C # define BN_S_MP_BALANCE_MUL_C # define BN_S_MP_EXPTMOD_FAST_C # define BN_S_MP_GET_BIT_C # define BN_S_MP_INVMOD_FAST_C # define BN_S_MP_INVMOD_SLOW_C # define BN_S_MP_KARATSUBA_MUL_C # define BN_S_MP_KARATSUBA_SQR_C # define BN_S_MP_MONTGOMERY_REDUCE_FAST_C # define BN_S_MP_MUL_DIGS_FAST_C # define BN_S_MP_MUL_HIGH_DIGS_FAST_C # define BN_S_MP_PRIME_IS_DIVISIBLE_C # define BN_S_MP_PRIME_RANDOM_EX_C # define BN_S_MP_RAND_SOURCE_C # define BN_S_MP_REVERSE_C # define BN_S_MP_SQR_FAST_C # define BN_S_MP_TOOM_MUL_C # define BN_S_MP_TOOM_SQR_C #endif #if defined(BN_MP_2EXPT_C) # define BN_MP_GROW_C # define BN_MP_ZERO_C #endif #if defined(BN_MP_ABS_C) # define BN_MP_COPY_C #endif #if defined(BN_MP_ADD_C) # define BN_MP_CMP_MAG_C # define BN_S_MP_ADD_C # define BN_S_MP_SUB_C #endif #if defined(BN_MP_ADD_D_C) # define BN_MP_CLAMP_C # define BN_MP_GROW_C # define BN_MP_SUB_D_C #endif #if defined(BN_MP_ADDMOD_C) # define BN_MP_ADD_C # define BN_MP_CLEAR_C # define BN_MP_INIT_C # define BN_MP_MOD_C #endif #if defined(BN_MP_AND_C) # define BN_MP_CLAMP_C # define BN_MP_GROW_C #endif #if defined(BN_MP_CLAMP_C) #endif #if defined(BN_MP_CLEAR_C) #endif |
| ︙ | ︙ | |||
256 257 258 259 260 261 262 | #if defined(BN_MP_CMP_D_C) #endif #if defined(BN_MP_CMP_MAG_C) #endif #if defined(BN_MP_CNT_LSB_C) | < | | | | > | > | | | | | | | | | | | | | | | | | | | | | | | | | > < < | | | | > > > | < < < < < < < < < < < | < < < < < < < < < < < < | | < < < < < | | < < | | < < < < < | | | | | | | > > > > > | > > > | | | | | | | | < | | < < < < > > > | | > > > > > | > | > > > > > > > > > | | | | | | | > | > > > > > > > > > > > > > > > > > > | > > > | | > > > > > > > > > > > | < | | | < < < < < < < < < < < | < < < < < | | < < | < < < | < < < < < < < < < < < < < < < < < < < | | | | | | < > | > > > > > > | > > > | > > > | > < < | < | | | | | | | | | | | | | | | | | > < | | | | < < < < < < < < < < < < < < < < < < < < | > > > > | | | > > > > > | | | | | | | | | | | | | | < < | | < | | | | < < < | | | | | | < < | | | | | | | | | | > | | | | | | | < | | | | | | | | | > > > | | < | | | | | | | | | | | | | | | | | < | | < | | | < | < < < | | | > | < < < < | < < < < < < < < < < | | | | | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < > > > > > > > > > > > > > > > > > > | | > > > | | | > > > | | | > > > | > > > | | | > > > > > > | | > > | | | | | | | | | | | | < | | | | | | | | | | | | | | | | | | < | | | < < < < | < < < | | < < < | < < < < < < < < < | < < < < < < < < < < < | < | < | < < < < < < < < | < | | | < | < < < | < | < < < < < < < < < < < < < | | | < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < | < | > > | | > > > > > > > > > > > > | | | | > > > > > > > > > > > > > > | > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > | > > > | > > > > > > > > > > | | | > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > | | < < < < | 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 | #if defined(BN_MP_CMP_D_C) #endif #if defined(BN_MP_CMP_MAG_C) #endif #if defined(BN_MP_CNT_LSB_C) #endif #if defined(BN_MP_COMPLEMENT_C) # define BN_MP_NEG_C # define BN_MP_SUB_D_C #endif #if defined(BN_MP_COPY_C) # define BN_MP_GROW_C #endif #if defined(BN_MP_COUNT_BITS_C) #endif #if defined(BN_MP_DECR_C) # define BN_MP_INCR_C # define BN_MP_SET_C # define BN_MP_SUB_D_C # define BN_MP_ZERO_C #endif #if defined(BN_MP_DIV_C) # define BN_MP_ADD_C # define BN_MP_CLAMP_C # define BN_MP_CLEAR_C # define BN_MP_CMP_C # define BN_MP_CMP_MAG_C # define BN_MP_COPY_C # define BN_MP_COUNT_BITS_C # define BN_MP_DIV_2D_C # define BN_MP_EXCH_C # define BN_MP_INIT_C # define BN_MP_INIT_COPY_C # define BN_MP_INIT_SIZE_C # define BN_MP_LSHD_C # define BN_MP_MUL_2D_C # define BN_MP_MUL_D_C # define BN_MP_RSHD_C # define BN_MP_SUB_C # define BN_MP_ZERO_C #endif #if defined(BN_MP_DIV_2_C) # define BN_MP_CLAMP_C # define BN_MP_GROW_C #endif #if defined(BN_MP_DIV_2D_C) # define BN_MP_CLAMP_C # define BN_MP_COPY_C # define BN_MP_MOD_2D_C # define BN_MP_RSHD_C # define BN_MP_ZERO_C #endif #if defined(BN_MP_DIV_3_C) # define BN_MP_CLAMP_C # define BN_MP_CLEAR_C # define BN_MP_EXCH_C # define BN_MP_INIT_SIZE_C #endif #if defined(BN_MP_DIV_D_C) # define BN_MP_CLAMP_C # define BN_MP_CLEAR_C # define BN_MP_COPY_C # define BN_MP_DIV_2D_C # define BN_MP_DIV_3_C # define BN_MP_EXCH_C # define BN_MP_INIT_SIZE_C #endif #if defined(BN_MP_DR_IS_MODULUS_C) #endif #if defined(BN_MP_DR_REDUCE_C) # define BN_MP_CLAMP_C # define BN_MP_CMP_MAG_C # define BN_MP_GROW_C # define BN_S_MP_SUB_C #endif #if defined(BN_MP_DR_SETUP_C) #endif #if defined(BN_MP_ERROR_TO_STRING_C) #endif #if defined(BN_MP_EXCH_C) #endif #if defined(BN_MP_EXPT_U32_C) # define BN_MP_CLEAR_C # define BN_MP_INIT_COPY_C # define BN_MP_MUL_C # define BN_MP_SET_C # define BN_MP_SQR_C #endif #if defined(BN_MP_EXPTMOD_C) # define BN_MP_ABS_C # define BN_MP_CLEAR_MULTI_C # define BN_MP_DR_IS_MODULUS_C # define BN_MP_INIT_MULTI_C # define BN_MP_INVMOD_C # define BN_MP_REDUCE_IS_2K_C # define BN_MP_REDUCE_IS_2K_L_C # define BN_S_MP_EXPTMOD_C # define BN_S_MP_EXPTMOD_FAST_C #endif #if defined(BN_MP_EXTEUCLID_C) # define BN_MP_CLEAR_MULTI_C # define BN_MP_COPY_C # define BN_MP_DIV_C # define BN_MP_EXCH_C # define BN_MP_INIT_MULTI_C # define BN_MP_MUL_C # define BN_MP_NEG_C # define BN_MP_SET_C # define BN_MP_SUB_C #endif #if defined(BN_MP_FREAD_C) # define BN_MP_ADD_D_C # define BN_MP_MUL_D_C # define BN_MP_ZERO_C #endif #if defined(BN_MP_FROM_SBIN_C) # define BN_MP_FROM_UBIN_C #endif #if defined(BN_MP_FROM_UBIN_C) # define BN_MP_CLAMP_C # define BN_MP_GROW_C # define BN_MP_MUL_2D_C # define BN_MP_ZERO_C #endif #if defined(BN_MP_FWRITE_C) # define BN_MP_RADIX_SIZE_C # define BN_MP_TO_RADIX_C #endif #if defined(BN_MP_GCD_C) # define BN_MP_ABS_C # define BN_MP_CLEAR_C # define BN_MP_CMP_MAG_C # define BN_MP_CNT_LSB_C # define BN_MP_DIV_2D_C # define BN_MP_EXCH_C # define BN_MP_INIT_COPY_C # define BN_MP_MUL_2D_C # define BN_S_MP_SUB_C #endif #if defined(BN_MP_GET_DOUBLE_C) #endif #if defined(BN_MP_GET_I32_C) # define BN_MP_GET_MAG_U32_C #endif #if defined(BN_MP_GET_I64_C) # define BN_MP_GET_MAG_U64_C #endif #if defined(BN_MP_GET_L_C) # define BN_MP_GET_MAG_UL_C #endif #if defined(BN_MP_GET_LL_C) # define BN_MP_GET_MAG_ULL_C #endif #if defined(BN_MP_GET_MAG_U32_C) #endif #if defined(BN_MP_GET_MAG_U64_C) #endif #if defined(BN_MP_GET_MAG_UL_C) #endif #if defined(BN_MP_GET_MAG_ULL_C) #endif #if defined(BN_MP_GROW_C) #endif #if defined(BN_MP_INCR_C) # define BN_MP_ADD_D_C # define BN_MP_DECR_C # define BN_MP_SET_C #endif #if defined(BN_MP_INIT_C) #endif #if defined(BN_MP_INIT_COPY_C) # define BN_MP_CLEAR_C # define BN_MP_COPY_C # define BN_MP_INIT_SIZE_C #endif #if defined(BN_MP_INIT_I32_C) # define BN_MP_INIT_C # define BN_MP_SET_I32_C #endif #if defined(BN_MP_INIT_I64_C) # define BN_MP_INIT_C # define BN_MP_SET_I64_C #endif #if defined(BN_MP_INIT_L_C) # define BN_MP_INIT_C # define BN_MP_SET_L_C #endif #if defined(BN_MP_INIT_LL_C) # define BN_MP_INIT_C # define BN_MP_SET_LL_C #endif #if defined(BN_MP_INIT_MULTI_C) # define BN_MP_CLEAR_C # define BN_MP_INIT_C #endif #if defined(BN_MP_INIT_SET_C) # define BN_MP_INIT_C # define BN_MP_SET_C #endif #if defined(BN_MP_INIT_SIZE_C) #endif #if defined(BN_MP_INIT_U32_C) # define BN_MP_INIT_C # define BN_MP_SET_U32_C #endif #if defined(BN_MP_INIT_U64_C) # define BN_MP_INIT_C # define BN_MP_SET_U64_C #endif #if defined(BN_MP_INIT_UL_C) # define BN_MP_INIT_C # define BN_MP_SET_UL_C #endif #if defined(BN_MP_INIT_ULL_C) # define BN_MP_INIT_C # define BN_MP_SET_ULL_C #endif #if defined(BN_MP_INVMOD_C) # define BN_MP_CMP_D_C # define BN_S_MP_INVMOD_FAST_C # define BN_S_MP_INVMOD_SLOW_C #endif #if defined(BN_MP_IS_SQUARE_C) # define BN_MP_CLEAR_C # define BN_MP_CMP_MAG_C # define BN_MP_GET_I32_C # define BN_MP_INIT_U32_C # define BN_MP_MOD_C # define BN_MP_MOD_D_C # define BN_MP_SQRT_C # define BN_MP_SQR_C #endif #if defined(BN_MP_ISEVEN_C) #endif #if defined(BN_MP_ISODD_C) #endif #if defined(BN_MP_KRONECKER_C) # define BN_MP_CLEAR_C # define BN_MP_CMP_D_C # define BN_MP_CNT_LSB_C # define BN_MP_COPY_C # define BN_MP_DIV_2D_C # define BN_MP_INIT_C # define BN_MP_INIT_COPY_C # define BN_MP_MOD_C #endif #if defined(BN_MP_LCM_C) # define BN_MP_CLEAR_MULTI_C # define BN_MP_CMP_MAG_C # define BN_MP_DIV_C # define BN_MP_GCD_C # define BN_MP_INIT_MULTI_C # define BN_MP_MUL_C #endif #if defined(BN_MP_LOG_U32_C) # define BN_MP_CLEAR_MULTI_C # define BN_MP_CMP_C # define BN_MP_CMP_D_C # define BN_MP_COPY_C # define BN_MP_COUNT_BITS_C # define BN_MP_EXCH_C # define BN_MP_EXPT_U32_C # define BN_MP_INIT_MULTI_C # define BN_MP_MUL_C # define BN_MP_SET_C # define BN_MP_SQR_C #endif #if defined(BN_MP_LSHD_C) # define BN_MP_GROW_C #endif #if defined(BN_MP_MOD_C) # define BN_MP_ADD_C # define BN_MP_CLEAR_C # define BN_MP_DIV_C # define BN_MP_EXCH_C # define BN_MP_INIT_SIZE_C #endif #if defined(BN_MP_MOD_2D_C) # define BN_MP_CLAMP_C # define BN_MP_COPY_C # define BN_MP_ZERO_C #endif #if defined(BN_MP_MOD_D_C) # define BN_MP_DIV_D_C #endif #if defined(BN_MP_MONTGOMERY_CALC_NORMALIZATION_C) # define BN_MP_2EXPT_C # define BN_MP_CMP_MAG_C # define BN_MP_COUNT_BITS_C # define BN_MP_MUL_2_C # define BN_MP_SET_C # define BN_S_MP_SUB_C #endif #if defined(BN_MP_MONTGOMERY_REDUCE_C) # define BN_MP_CLAMP_C # define BN_MP_CMP_MAG_C # define BN_MP_GROW_C # define BN_MP_RSHD_C # define BN_S_MP_MONTGOMERY_REDUCE_FAST_C # define BN_S_MP_SUB_C #endif #if defined(BN_MP_MONTGOMERY_SETUP_C) #endif #if defined(BN_MP_MUL_C) # define BN_S_MP_BALANCE_MUL_C # define BN_S_MP_KARATSUBA_MUL_C # define BN_S_MP_MUL_DIGS_C # define BN_S_MP_MUL_DIGS_FAST_C # define BN_S_MP_TOOM_MUL_C #endif #if defined(BN_MP_MUL_2_C) # define BN_MP_GROW_C #endif #if defined(BN_MP_MUL_2D_C) # define BN_MP_CLAMP_C # define BN_MP_COPY_C # define BN_MP_GROW_C # define BN_MP_LSHD_C #endif #if defined(BN_MP_MUL_D_C) # define BN_MP_CLAMP_C # define BN_MP_GROW_C #endif #if defined(BN_MP_MULMOD_C) # define BN_MP_CLEAR_C # define BN_MP_INIT_SIZE_C # define BN_MP_MOD_C # define BN_MP_MUL_C #endif #if defined(BN_MP_NEG_C) # define BN_MP_COPY_C #endif #if defined(BN_MP_OR_C) # define BN_MP_CLAMP_C # define BN_MP_GROW_C #endif #if defined(BN_MP_PACK_C) # define BN_MP_CLEAR_C # define BN_MP_DIV_2D_C # define BN_MP_INIT_COPY_C # define BN_MP_PACK_COUNT_C #endif #if defined(BN_MP_PACK_COUNT_C) # define BN_MP_COUNT_BITS_C #endif #if defined(BN_MP_PRIME_FERMAT_C) # define BN_MP_CLEAR_C # define BN_MP_CMP_C # define BN_MP_CMP_D_C # define BN_MP_EXPTMOD_C # define BN_MP_INIT_C #endif #if defined(BN_MP_PRIME_FROBENIUS_UNDERWOOD_C) # define BN_MP_ADD_C # define BN_MP_ADD_D_C # define BN_MP_CLEAR_MULTI_C # define BN_MP_CMP_C # define BN_MP_COUNT_BITS_C # define BN_MP_EXCH_C # define BN_MP_GCD_C # define BN_MP_INIT_MULTI_C # define BN_MP_KRONECKER_C # define BN_MP_MOD_C # define BN_MP_MUL_2_C # define BN_MP_MUL_C # define BN_MP_MUL_D_C # define BN_MP_SET_C # define BN_MP_SET_U32_C # define BN_MP_SQR_C # define BN_MP_SUB_C # define BN_MP_SUB_D_C # define BN_S_MP_GET_BIT_C #endif #if defined(BN_MP_PRIME_IS_PRIME_C) # define BN_MP_CLEAR_C # define BN_MP_CMP_C # define BN_MP_CMP_D_C # define BN_MP_COUNT_BITS_C # define BN_MP_DIV_2D_C # define BN_MP_INIT_SET_C # define BN_MP_IS_SQUARE_C # define BN_MP_PRIME_MILLER_RABIN_C # define BN_MP_PRIME_STRONG_LUCAS_SELFRIDGE_C # define BN_MP_RAND_C # define BN_MP_READ_RADIX_C # define BN_MP_SET_C # define BN_S_MP_PRIME_IS_DIVISIBLE_C #endif #if defined(BN_MP_PRIME_MILLER_RABIN_C) # define BN_MP_CLEAR_C # define BN_MP_CMP_C # define BN_MP_CMP_D_C # define BN_MP_CNT_LSB_C # define BN_MP_DIV_2D_C # define BN_MP_EXPTMOD_C # define BN_MP_INIT_C # define BN_MP_INIT_COPY_C # define BN_MP_SQRMOD_C # define BN_MP_SUB_D_C #endif #if defined(BN_MP_PRIME_NEXT_PRIME_C) # define BN_MP_ADD_D_C # define BN_MP_CLEAR_C # define BN_MP_CMP_D_C # define BN_MP_INIT_C # define BN_MP_MOD_D_C # define BN_MP_PRIME_IS_PRIME_C # define BN_MP_SET_C # define BN_MP_SUB_D_C #endif #if defined(BN_MP_PRIME_RABIN_MILLER_TRIALS_C) #endif #if defined(BN_MP_PRIME_RAND_C) # define BN_MP_ADD_D_C # define BN_MP_DIV_2_C # define BN_MP_FROM_UBIN_C # define BN_MP_MUL_2_C # define BN_MP_PRIME_IS_PRIME_C # define BN_MP_SUB_D_C # define BN_S_MP_PRIME_RANDOM_EX_C # define BN_S_MP_RAND_CB_C # define BN_S_MP_RAND_SOURCE_C #endif #if defined(BN_MP_PRIME_STRONG_LUCAS_SELFRIDGE_C) # define BN_MP_ADD_C # define BN_MP_ADD_D_C # define BN_MP_CLEAR_C # define BN_MP_CLEAR_MULTI_C # define BN_MP_CMP_C # define BN_MP_CMP_D_C # define BN_MP_CNT_LSB_C # define BN_MP_COUNT_BITS_C # define BN_MP_DIV_2D_C # define BN_MP_DIV_2_C # define BN_MP_GCD_C # define BN_MP_INIT_C # define BN_MP_INIT_MULTI_C # define BN_MP_KRONECKER_C # define BN_MP_MOD_C # define BN_MP_MUL_2_C # define BN_MP_MUL_C # define BN_MP_SET_C # define BN_MP_SET_I32_C # define BN_MP_SET_U32_C # define BN_MP_SQR_C # define BN_MP_SUB_C # define BN_MP_SUB_D_C # define BN_S_MP_GET_BIT_C # define BN_S_MP_MUL_SI_C #endif #if defined(BN_MP_RADIX_SIZE_C) # define BN_MP_CLEAR_C # define BN_MP_COUNT_BITS_C # define BN_MP_DIV_D_C # define BN_MP_INIT_COPY_C #endif #if defined(BN_MP_RADIX_SMAP_C) #endif #if defined(BN_MP_RAND_C) # define BN_MP_GROW_C # define BN_MP_RAND_SOURCE_C # define BN_MP_ZERO_C # define BN_S_MP_RAND_PLATFORM_C # define BN_S_MP_RAND_SOURCE_C #endif #if defined(BN_MP_READ_RADIX_C) # define BN_MP_ADD_D_C # define BN_MP_MUL_D_C # define BN_MP_ZERO_C #endif #if defined(BN_MP_REDUCE_C) # define BN_MP_ADD_C # define BN_MP_CLEAR_C # define BN_MP_CMP_C # define BN_MP_CMP_D_C # define BN_MP_INIT_COPY_C # define BN_MP_LSHD_C # define BN_MP_MOD_2D_C # define BN_MP_MUL_C # define BN_MP_RSHD_C # define BN_MP_SET_C # define BN_MP_SUB_C # define BN_S_MP_MUL_DIGS_C # define BN_S_MP_MUL_HIGH_DIGS_C # define BN_S_MP_MUL_HIGH_DIGS_FAST_C # define BN_S_MP_SUB_C #endif #if defined(BN_MP_REDUCE_2K_C) # define BN_MP_CLEAR_C # define BN_MP_CMP_MAG_C # define BN_MP_COUNT_BITS_C # define BN_MP_DIV_2D_C # define BN_MP_INIT_C # define BN_MP_MUL_D_C # define BN_S_MP_ADD_C # define BN_S_MP_SUB_C #endif #if defined(BN_MP_REDUCE_2K_L_C) # define BN_MP_CLEAR_C # define BN_MP_CMP_MAG_C # define BN_MP_COUNT_BITS_C # define BN_MP_DIV_2D_C # define BN_MP_INIT_C # define BN_MP_MUL_C # define BN_S_MP_ADD_C # define BN_S_MP_SUB_C #endif #if defined(BN_MP_REDUCE_2K_SETUP_C) # define BN_MP_2EXPT_C # define BN_MP_CLEAR_C # define BN_MP_COUNT_BITS_C # define BN_MP_INIT_C # define BN_S_MP_SUB_C #endif #if defined(BN_MP_REDUCE_2K_SETUP_L_C) # define BN_MP_2EXPT_C # define BN_MP_CLEAR_C # define BN_MP_COUNT_BITS_C # define BN_MP_INIT_C # define BN_S_MP_SUB_C #endif #if defined(BN_MP_REDUCE_IS_2K_C) # define BN_MP_COUNT_BITS_C #endif #if defined(BN_MP_REDUCE_IS_2K_L_C) #endif #if defined(BN_MP_REDUCE_SETUP_C) # define BN_MP_2EXPT_C # define BN_MP_DIV_C #endif #if defined(BN_MP_ROOT_U32_C) # define BN_MP_2EXPT_C # define BN_MP_ADD_D_C # define BN_MP_CLEAR_MULTI_C # define BN_MP_CMP_C # define BN_MP_COPY_C # define BN_MP_COUNT_BITS_C # define BN_MP_DIV_C # define BN_MP_EXCH_C # define BN_MP_EXPT_U32_C # define BN_MP_INIT_MULTI_C # define BN_MP_MUL_C # define BN_MP_MUL_D_C # define BN_MP_SET_C # define BN_MP_SUB_C # define BN_MP_SUB_D_C #endif #if defined(BN_MP_RSHD_C) # define BN_MP_ZERO_C #endif #if defined(BN_MP_SBIN_SIZE_C) # define BN_MP_UBIN_SIZE_C #endif #if defined(BN_MP_SET_C) #endif #if defined(BN_MP_SET_DOUBLE_C) # define BN_MP_DIV_2D_C # define BN_MP_MUL_2D_C # define BN_MP_SET_U64_C #endif #if defined(BN_MP_SET_I32_C) # define BN_MP_SET_U32_C #endif #if defined(BN_MP_SET_I64_C) # define BN_MP_SET_U64_C #endif #if defined(BN_MP_SET_L_C) # define BN_MP_SET_UL_C #endif #if defined(BN_MP_SET_LL_C) # define BN_MP_SET_ULL_C #endif #if defined(BN_MP_SET_U32_C) #endif #if defined(BN_MP_SET_U64_C) #endif #if defined(BN_MP_SET_UL_C) #endif #if defined(BN_MP_SET_ULL_C) #endif #if defined(BN_MP_SHRINK_C) #endif #if defined(BN_MP_SIGNED_RSH_C) # define BN_MP_ADD_D_C # define BN_MP_DIV_2D_C # define BN_MP_SUB_D_C #endif #if defined(BN_MP_SQR_C) # define BN_S_MP_KARATSUBA_SQR_C # define BN_S_MP_SQR_C # define BN_S_MP_SQR_FAST_C # define BN_S_MP_TOOM_SQR_C #endif #if defined(BN_MP_SQRMOD_C) # define BN_MP_CLEAR_C # define BN_MP_INIT_C # define BN_MP_MOD_C # define BN_MP_SQR_C #endif #if defined(BN_MP_SQRT_C) # define BN_MP_ADD_C # define BN_MP_CLEAR_C # define BN_MP_CMP_MAG_C # define BN_MP_DIV_2_C # define BN_MP_DIV_C # define BN_MP_EXCH_C # define BN_MP_INIT_C # define BN_MP_INIT_COPY_C # define BN_MP_RSHD_C # define BN_MP_ZERO_C #endif #if defined(BN_MP_SQRTMOD_PRIME_C) # define BN_MP_ADD_D_C # define BN_MP_CLEAR_MULTI_C # define BN_MP_CMP_D_C # define BN_MP_COPY_C # define BN_MP_DIV_2_C # define BN_MP_EXPTMOD_C # define BN_MP_INIT_MULTI_C # define BN_MP_KRONECKER_C # define BN_MP_MOD_D_C # define BN_MP_MULMOD_C # define BN_MP_SET_C # define BN_MP_SET_U32_C # define BN_MP_SQRMOD_C # define BN_MP_SUB_D_C # define BN_MP_ZERO_C #endif #if defined(BN_MP_SUB_C) # define BN_MP_CMP_MAG_C # define BN_S_MP_ADD_C # define BN_S_MP_SUB_C #endif #if defined(BN_MP_SUB_D_C) # define BN_MP_ADD_D_C # define BN_MP_CLAMP_C # define BN_MP_GROW_C #endif #if defined(BN_MP_SUBMOD_C) # define BN_MP_CLEAR_C # define BN_MP_INIT_C # define BN_MP_MOD_C # define BN_MP_SUB_C #endif #if defined(BN_MP_TO_RADIX_C) # define BN_MP_CLEAR_C # define BN_MP_DIV_D_C # define BN_MP_INIT_COPY_C # define BN_S_MP_REVERSE_C #endif #if defined(BN_MP_TO_SBIN_C) # define BN_MP_TO_UBIN_C #endif #if defined(BN_MP_TO_UBIN_C) # define BN_MP_CLEAR_C # define BN_MP_DIV_2D_C # define BN_MP_INIT_COPY_C # define BN_MP_UBIN_SIZE_C #endif #if defined(BN_MP_UBIN_SIZE_C) # define BN_MP_COUNT_BITS_C #endif #if defined(BN_MP_UNPACK_C) # define BN_MP_CLAMP_C # define BN_MP_MUL_2D_C # define BN_MP_ZERO_C #endif #if defined(BN_MP_XOR_C) # define BN_MP_CLAMP_C # define BN_MP_GROW_C #endif #if defined(BN_MP_ZERO_C) #endif #if defined(BN_PRIME_TAB_C) #endif #if defined(BN_S_MP_ADD_C) # define BN_MP_CLAMP_C # define BN_MP_GROW_C #endif #if defined(BN_S_MP_BALANCE_MUL_C) # define BN_MP_ADD_C # define BN_MP_CLAMP_C # define BN_MP_CLEAR_C # define BN_MP_CLEAR_MULTI_C # define BN_MP_EXCH_C # define BN_MP_INIT_MULTI_C # define BN_MP_INIT_SIZE_C # define BN_MP_LSHD_C # define BN_MP_MUL_C #endif #if defined(BN_S_MP_EXPTMOD_C) # define BN_MP_CLEAR_C # define BN_MP_COPY_C # define BN_MP_COUNT_BITS_C # define BN_MP_EXCH_C # define BN_MP_INIT_C # define BN_MP_MOD_C # define BN_MP_MUL_C # define BN_MP_REDUCE_2K_L_C # define BN_MP_REDUCE_2K_SETUP_L_C # define BN_MP_REDUCE_C # define BN_MP_REDUCE_SETUP_C # define BN_MP_SET_C # define BN_MP_SQR_C #endif #if defined(BN_S_MP_EXPTMOD_FAST_C) # define BN_MP_CLEAR_C # define BN_MP_COPY_C # define BN_MP_COUNT_BITS_C # define BN_MP_DR_REDUCE_C # define BN_MP_DR_SETUP_C # define BN_MP_EXCH_C # define BN_MP_INIT_SIZE_C # define BN_MP_MOD_C # define BN_MP_MONTGOMERY_CALC_NORMALIZATION_C # define BN_MP_MONTGOMERY_REDUCE_C # define BN_MP_MONTGOMERY_SETUP_C # define BN_MP_MULMOD_C # define BN_MP_MUL_C # define BN_MP_REDUCE_2K_C # define BN_MP_REDUCE_2K_SETUP_C # define BN_MP_SET_C # define BN_MP_SQR_C # define BN_S_MP_MONTGOMERY_REDUCE_FAST_C #endif #if defined(BN_S_MP_GET_BIT_C) #endif #if defined(BN_S_MP_INVMOD_FAST_C) # define BN_MP_ADD_C # define BN_MP_CLEAR_MULTI_C # define BN_MP_CMP_C # define BN_MP_CMP_D_C # define BN_MP_CMP_MAG_C # define BN_MP_COPY_C # define BN_MP_DIV_2_C # define BN_MP_EXCH_C # define BN_MP_INIT_MULTI_C # define BN_MP_MOD_C # define BN_MP_SET_C # define BN_MP_SUB_C #endif #if defined(BN_S_MP_INVMOD_SLOW_C) # define BN_MP_ADD_C # define BN_MP_CLEAR_MULTI_C # define BN_MP_CMP_C # define BN_MP_CMP_D_C # define BN_MP_CMP_MAG_C # define BN_MP_COPY_C # define BN_MP_DIV_2_C # define BN_MP_EXCH_C # define BN_MP_INIT_MULTI_C # define BN_MP_MOD_C # define BN_MP_SET_C # define BN_MP_SUB_C #endif #if defined(BN_S_MP_KARATSUBA_MUL_C) # define BN_MP_ADD_C # define BN_MP_CLAMP_C # define BN_MP_CLEAR_C # define BN_MP_INIT_SIZE_C # define BN_MP_LSHD_C # define BN_MP_MUL_C # define BN_S_MP_ADD_C # define BN_S_MP_SUB_C #endif #if defined(BN_S_MP_KARATSUBA_SQR_C) # define BN_MP_ADD_C # define BN_MP_CLAMP_C # define BN_MP_CLEAR_C # define BN_MP_INIT_SIZE_C # define BN_MP_LSHD_C # define BN_MP_SQR_C # define BN_S_MP_ADD_C # define BN_S_MP_SUB_C #endif #if defined(BN_S_MP_MONTGOMERY_REDUCE_FAST_C) # define BN_MP_CLAMP_C # define BN_MP_CMP_MAG_C # define BN_MP_GROW_C # define BN_S_MP_SUB_C #endif #if defined(BN_S_MP_MUL_DIGS_C) # define BN_MP_CLAMP_C # define BN_MP_CLEAR_C # define BN_MP_EXCH_C # define BN_MP_INIT_SIZE_C # define BN_S_MP_MUL_DIGS_FAST_C #endif #if defined(BN_S_MP_MUL_DIGS_FAST_C) # define BN_MP_CLAMP_C # define BN_MP_GROW_C #endif #if defined(BN_S_MP_MUL_HIGH_DIGS_C) # define BN_MP_CLAMP_C # define BN_MP_CLEAR_C # define BN_MP_EXCH_C # define BN_MP_INIT_SIZE_C # define BN_S_MP_MUL_HIGH_DIGS_FAST_C #endif #if defined(BN_S_MP_MUL_HIGH_DIGS_FAST_C) # define BN_MP_CLAMP_C # define BN_MP_GROW_C #endif #if defined(BN_S_MP_PRIME_IS_DIVISIBLE_C) # define BN_MP_MOD_D_C #endif #if defined(BN_S_MP_RAND_JENKINS_C) # define BN_S_MP_RAND_JENKINS_INIT_C #endif #if defined(BN_S_MP_RAND_PLATFORM_C) #endif #if defined(BN_S_MP_REVERSE_C) #endif #if defined(BN_S_MP_SQR_C) # define BN_MP_CLAMP_C # define BN_MP_CLEAR_C # define BN_MP_EXCH_C # define BN_MP_INIT_SIZE_C #endif #if defined(BN_S_MP_SQR_FAST_C) # define BN_MP_CLAMP_C # define BN_MP_GROW_C #endif #if defined(BN_S_MP_SUB_C) # define BN_MP_CLAMP_C # define BN_MP_GROW_C #endif #if defined(BN_S_MP_TOOM_MUL_C) # define BN_MP_ADD_C # define BN_MP_CLAMP_C # define BN_MP_CLEAR_C # define BN_MP_CLEAR_MULTI_C # define BN_MP_DIV_2_C # define BN_MP_DIV_3_C # define BN_MP_INIT_MULTI_C # define BN_MP_INIT_SIZE_C # define BN_MP_LSHD_C # define BN_MP_MUL_2_C # define BN_MP_MUL_C # define BN_MP_SUB_C #endif #if defined(BN_S_MP_TOOM_SQR_C) # define BN_MP_ADD_C # define BN_MP_CLAMP_C # define BN_MP_CLEAR_C # define BN_MP_DIV_2_C # define BN_MP_INIT_C # define BN_MP_INIT_SIZE_C # define BN_MP_LSHD_C # define BN_MP_MUL_2_C # define BN_MP_MUL_C # define BN_MP_SQR_C # define BN_MP_SUB_C #endif #ifdef LTM_INSIDE #undef LTM_INSIDE #ifdef LTM3 # define LTM_LAST #endif #include "tommath_superclass.h" #include "tommath_class.h" #else # define LTM_LAST #endif |
Added libtommath/tommath_cutoffs.h.
> > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 | /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ /* Current values evaluated on an AMD A8-6600K (64-bit). Type "make tune" to optimize them for your machine but be aware that it may take a long time. It took 2:30 minutes on the aforementioned machine for example. */ #define MP_DEFAULT_KARATSUBA_MUL_CUTOFF 80 #define MP_DEFAULT_KARATSUBA_SQR_CUTOFF 120 #define MP_DEFAULT_TOOM_MUL_CUTOFF 350 #define MP_DEFAULT_TOOM_SQR_CUTOFF 400 |
Changes to libtommath/tommath_private.h.
|
| | > | > > | > > > > > > > > > | > > > < < < > > > < > > | > | > | > | | < > > > > > > | > > | > > > > > | | > | > > > > > > > > | | | > > > > > > > > | | < > | > > > > | < > | < < | > | < > > > > > > > > > > > > > > | > > > | < < > > > > > > | | > | > > | > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > | | | | | | | | | | | | | | | | | | | | > > | > > > | > > > > > | > > > | > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > < < | | | | | | | < < < < < < | < < < < < < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > | > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 |
/* LibTomMath, multiple-precision integer library -- Tom St Denis */
/* SPDX-License-Identifier: Unlicense */
#ifndef TOMMATH_PRIV_H_
#define TOMMATH_PRIV_H_
#ifdef MP_NO_STDINT
#ifdef HAVE_STDINT_H
# include <stdint.h>
#else
# include "../compat/stdint.h"
#endif
#endif
#include "tclTomMath.h"
#include "tommath_class.h"
/*
* Private symbols
* ---------------
*
* On Unix symbols can be marked as hidden if libtommath is compiled
* as a shared object. By default, symbols are visible.
* As of now, this feature is opt-in via the MP_PRIVATE_SYMBOLS define.
*
* On Win32 a .def file must be used to specify the exported symbols.
*/
#if defined (MP_PRIVATE_SYMBOLS) && defined(__GNUC__) && __GNUC__ >= 4
# define MP_PRIVATE __attribute__ ((visibility ("hidden")))
#else
# define MP_PRIVATE
#endif
/* Hardening libtommath
* --------------------
*
* By default memory is zeroed before calling
* MP_FREE to avoid leaking data. This is good
* practice in cryptographical applications.
*
* Note however that memory allocators used
* in cryptographical applications can often
* be configured by itself to clear memory,
* rendering the clearing in tommath unnecessary.
* See for example https://github.com/GrapheneOS/hardened_malloc
* and the option CONFIG_ZERO_ON_FREE.
*
* Furthermore there are applications which
* value performance more and want this
* feature to be disabled. For such applications
* define MP_NO_ZERO_ON_FREE during compilation.
*/
#ifdef MP_NO_ZERO_ON_FREE
# define MP_FREE_BUFFER(mem, size) MP_FREE((mem), (size))
# define MP_FREE_DIGITS(mem, digits) MP_FREE((mem), sizeof (mp_digit) * (size_t)(digits))
#else
# define MP_FREE_BUFFER(mem, size) \
do { \
size_t fs_ = (size); \
void* fm_ = (mem); \
if (fm_ != NULL) { \
MP_ZERO_BUFFER(fm_, fs_); \
MP_FREE(fm_, fs_); \
} \
} while (0)
# define MP_FREE_DIGITS(mem, digits) \
do { \
int fd_ = (digits); \
void* fm_ = (mem); \
if (fm_ != NULL) { \
size_t fs_ = sizeof (mp_digit) * (size_t)fd_; \
MP_ZERO_BUFFER(fm_, fs_); \
MP_FREE(fm_, fs_); \
} \
} while (0)
#endif
#ifdef MP_USE_MEMSET
# include <string.h>
# define MP_ZERO_BUFFER(mem, size) memset((mem), 0, (size))
# define MP_ZERO_DIGITS(mem, digits) \
do { \
int zd_ = (digits); \
if (zd_ > 0) { \
memset((mem), 0, sizeof(mp_digit) * (size_t)zd_); \
} \
} while (0)
#else
# define MP_ZERO_BUFFER(mem, size) \
do { \
size_t zs_ = (size); \
char* zm_ = (char*)(mem); \
while (zs_-- > 0u) { \
*zm_++ = '\0'; \
} \
} while (0)
# define MP_ZERO_DIGITS(mem, digits) \
do { \
int zd_ = (digits); \
mp_digit* zm_ = (mem); \
while (zd_-- > 0) { \
*zm_++ = 0; \
} \
} while (0)
#endif
/* Tunable cutoffs
* ---------------
*
* - In the default settings, a cutoff X can be modified at runtime
* by adjusting the corresponding X_CUTOFF variable.
*
* - Tunability of the library can be disabled at compile time
* by defining the MP_FIXED_CUTOFFS macro.
*
* - There is an additional file tommath_cutoffs.h, which defines
* the default cutoffs. These can be adjusted manually or by the
* autotuner.
*
*/
#ifdef MP_FIXED_CUTOFFS
# include "tommath_cutoffs.h"
# define MP_KARATSUBA_MUL_CUTOFF MP_DEFAULT_KARATSUBA_MUL_CUTOFF
# define MP_KARATSUBA_SQR_CUTOFF MP_DEFAULT_KARATSUBA_SQR_CUTOFF
# define MP_TOOM_MUL_CUTOFF MP_DEFAULT_TOOM_MUL_CUTOFF
# define MP_TOOM_SQR_CUTOFF MP_DEFAULT_TOOM_SQR_CUTOFF
#else
# define MP_KARATSUBA_MUL_CUTOFF KARATSUBA_MUL_CUTOFF
# define MP_KARATSUBA_SQR_CUTOFF KARATSUBA_SQR_CUTOFF
# define MP_TOOM_MUL_CUTOFF TOOM_MUL_CUTOFF
# define MP_TOOM_SQR_CUTOFF TOOM_SQR_CUTOFF
#endif
/* define heap macros */
#ifndef MP_MALLOC
/* default to libc stuff */
# include <stdlib.h>
# define MP_MALLOC(size) malloc(size)
# define MP_REALLOC(mem, oldsize, newsize) realloc((mem), (newsize))
# define MP_CALLOC(nmemb, size) calloc((nmemb), (size))
# define MP_FREE(mem, size) free(mem)
#elif 0
/* prototypes for our heap functions */
extern void *MP_MALLOC(size_t size);
extern void *MP_REALLOC(void *mem, size_t oldsize, size_t newsize);
extern void *MP_CALLOC(size_t nmemb, size_t size);
extern void MP_FREE(void *mem, size_t size);
#endif
/* feature detection macro */
#ifdef _MSC_VER
/* Prevent false positive: not enough arguments for function-like macro invocation */
#pragma warning(disable: 4003)
#endif
#define MP_STRINGIZE(x) MP__STRINGIZE(x)
#define MP__STRINGIZE(x) ""#x""
#define MP_HAS(x) (sizeof(MP_STRINGIZE(BN_##x##_C)) == 1u)
/* TODO: Remove private_mp_word as soon as deprecated mp_word is removed from tommath. */
#if !defined(MP_64BIT) || defined(__GNUC__)
#undef mp_word
typedef private_mp_word mp_word;
#endif
#define MP_MIN(x, y) (((x) < (y)) ? (x) : (y))
#define MP_MAX(x, y) (((x) > (y)) ? (x) : (y))
/* Static assertion */
#define MP_STATIC_ASSERT(msg, cond) typedef char mp_static_assert_##msg[(cond) ? 1 : -1];
/* ---> Basic Manipulations <--- */
#define MP_IS_ZERO(a) ((a)->used == 0)
#define MP_IS_EVEN(a) (((a)->used == 0) || (((a)->dp[0] & 1u) == 0u))
#define MP_IS_ODD(a) (((a)->used > 0) && (((a)->dp[0] & 1u) == 1u))
#define MP_SIZEOF_BITS(type) ((size_t)CHAR_BIT * sizeof(type))
#define MP_MAXFAST (int)(1uL << (MP_SIZEOF_BITS(mp_word) - (2u * (size_t)MP_DIGIT_BIT)))
/* TODO: Remove PRIVATE_MP_WARRAY as soon as deprecated MP_WARRAY is removed from tommath.h */
#undef MP_WARRAY
#define MP_WARRAY PRIVATE_MP_WARRAY
/* TODO: Remove PRIVATE_MP_PREC as soon as deprecated MP_PREC is removed from tommath.h */
#ifdef PRIVATE_MP_PREC
# undef MP_PREC
# define MP_PREC PRIVATE_MP_PREC
#endif
/* Minimum number of available digits in mp_int, MP_PREC >= MP_MIN_PREC */
#define MP_MIN_PREC ((((int)MP_SIZEOF_BITS(uintmax_t) + MP_DIGIT_BIT) - 1) / MP_DIGIT_BIT)
MP_STATIC_ASSERT(prec_geq_min_prec, MP_PREC >= MP_MIN_PREC)
/* random number source */
extern MP_PRIVATE mp_err(*s_mp_rand_source)(void *out, size_t size);
#ifdef __cplusplus
extern "C" {
#endif
/* lowlevel functions, do not call! */
MP_PRIVATE mp_bool s_mp_get_bit(const mp_int *a, unsigned int b);
MP_PRIVATE mp_err s_mp_add(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
MP_PRIVATE mp_err s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
MP_PRIVATE mp_err s_mp_mul_digs_fast(const mp_int *a, const mp_int *b, mp_int *c, int digs) MP_WUR;
MP_PRIVATE mp_err s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) MP_WUR;
MP_PRIVATE mp_err s_mp_mul_high_digs_fast(const mp_int *a, const mp_int *b, mp_int *c, int digs) MP_WUR;
MP_PRIVATE mp_err s_mp_mul_high_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) MP_WUR;
MP_PRIVATE mp_err s_mp_sqr_fast(const mp_int *a, mp_int *b) MP_WUR;
MP_PRIVATE mp_err s_mp_sqr(const mp_int *a, mp_int *b) MP_WUR;
MP_PRIVATE mp_err s_mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
MP_PRIVATE mp_err s_mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
MP_PRIVATE mp_err s_mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
MP_PRIVATE mp_err s_mp_karatsuba_sqr(const mp_int *a, mp_int *b) MP_WUR;
MP_PRIVATE mp_err s_mp_toom_sqr(const mp_int *a, mp_int *b) MP_WUR;
MP_PRIVATE mp_err s_mp_invmod_fast(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
MP_PRIVATE mp_err s_mp_invmod_slow(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
MP_PRIVATE mp_err s_mp_montgomery_reduce_fast(mp_int *x, const mp_int *n, mp_digit rho) MP_WUR;
MP_PRIVATE mp_err s_mp_exptmod_fast(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode) MP_WUR;
MP_PRIVATE mp_err s_mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode) MP_WUR;
MP_PRIVATE mp_err s_mp_rand_platform(void *p, size_t n) MP_WUR;
MP_PRIVATE mp_err s_mp_prime_random_ex(mp_int *a, int t, int size, int flags, private_mp_prime_callback cb, void *dat);
MP_PRIVATE void s_mp_reverse(unsigned char *s, size_t len);
MP_PRIVATE mp_err s_mp_prime_is_divisible(const mp_int *a, mp_bool *result);
/* TODO: jenkins prng is not thread safe as of now */
MP_PRIVATE mp_err s_mp_rand_jenkins(void *p, size_t n) MP_WUR;
MP_PRIVATE void s_mp_rand_jenkins_init(uint64_t seed);
extern MP_PRIVATE const char *const mp_s_rmap;
extern MP_PRIVATE const uint8_t mp_s_rmap_reverse[];
extern MP_PRIVATE const size_t mp_s_rmap_reverse_sz;
extern MP_PRIVATE const mp_digit *s_mp_prime_tab;
/* deprecated functions */
MP_DEPRECATED(s_mp_invmod_fast) mp_err fast_mp_invmod(const mp_int *a, const mp_int *b, mp_int *c);
MP_DEPRECATED(s_mp_montgomery_reduce_fast) mp_err fast_mp_montgomery_reduce(mp_int *x, const mp_int *n,
mp_digit rho);
MP_DEPRECATED(s_mp_mul_digs_fast) mp_err fast_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c,
int digs);
MP_DEPRECATED(s_mp_mul_high_digs_fast) mp_err fast_s_mp_mul_high_digs(const mp_int *a, const mp_int *b,
mp_int *c,
int digs);
MP_DEPRECATED(s_mp_sqr_fast) mp_err fast_s_mp_sqr(const mp_int *a, mp_int *b);
MP_DEPRECATED(s_mp_balance_mul) mp_err mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c);
MP_DEPRECATED(s_mp_exptmod_fast) mp_err mp_exptmod_fast(const mp_int *G, const mp_int *X, const mp_int *P,
mp_int *Y,
int redmode);
MP_DEPRECATED(s_mp_invmod_slow) mp_err mp_invmod_slow(const mp_int *a, const mp_int *b, mp_int *c);
MP_DEPRECATED(s_mp_karatsuba_mul) mp_err mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c);
MP_DEPRECATED(s_mp_karatsuba_sqr) mp_err mp_karatsuba_sqr(const mp_int *a, mp_int *b);
MP_DEPRECATED(s_mp_toom_mul) mp_err mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c);
MP_DEPRECATED(s_mp_toom_sqr) mp_err mp_toom_sqr(const mp_int *a, mp_int *b);
MP_DEPRECATED(s_mp_reverse) void bn_reverse(unsigned char *s, int len);
#ifdef __cplusplus
}
#endif
#ifndef TCL_WITH_EXTERNAL_TOMMATH
#undef mp_sqr
#define mp_sqr TclBN_mp_sqr
#endif
#define MP_GET_ENDIANNESS(x) \
do{\
int16_t n = 0x1; \
char *p = (char *)&n; \
x = (p[0] == '\x01') ? MP_LITTLE_ENDIAN : MP_BIG_ENDIAN; \
} while (0)
/* code-generating macros */
#define MP_SET_UNSIGNED(name, type) \
void name(mp_int * a, type b) \
{ \
int i = 0; \
while (b != 0u) { \
a->dp[i++] = ((mp_digit)b & MP_MASK); \
if (MP_SIZEOF_BITS(type) <= MP_DIGIT_BIT) { break; } \
b >>= ((MP_SIZEOF_BITS(type) <= MP_DIGIT_BIT) ? 0 : MP_DIGIT_BIT); \
} \
a->used = i; \
a->sign = MP_ZPOS; \
MP_ZERO_DIGITS(a->dp + a->used, a->alloc - a->used); \
}
#define MP_SET_SIGNED(name, uname, type, utype) \
void name(mp_int * a, type b) \
{ \
uname(a, (b < 0) ? -(utype)b : (utype)b); \
if (b < 0) { a->sign = MP_NEG; } \
}
#define MP_INIT_INT(name , set, type) \
mp_err name(mp_int * a, type b) \
{ \
mp_err err; \
if ((err = mp_init(a)) != MP_OKAY) { \
return err; \
} \
set(a, b); \
return MP_OKAY; \
}
#define MP_GET_MAG(name, type) \
type name(const mp_int* a) \
{ \
unsigned i = MP_MIN((unsigned)a->used, (unsigned)((MP_SIZEOF_BITS(type) + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT)); \
type res = 0u; \
while (i --> 0u) { \
res <<= ((MP_SIZEOF_BITS(type) <= MP_DIGIT_BIT) ? 0 : MP_DIGIT_BIT); \
res |= (type)a->dp[i]; \
if (MP_SIZEOF_BITS(type) <= MP_DIGIT_BIT) { break; } \
} \
return res; \
}
#define MP_GET_SIGNED(name, mag, type, utype) \
type name(const mp_int* a) \
{ \
utype res = mag(a); \
return (a->sign == MP_NEG) ? (type)-res : (type)res; \
}
#endif
|
Changes to libtommath/tommath_superclass.h.
|
| | < < < < < < < < | < > > > < | > | > > > > > > | | | | | | > > > > > > > > > > > > > | | | | > > > > | > > > > > < < < < < < | > > > | > > > | | > > > > | | | < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 | /* LibTomMath, multiple-precision integer library -- Tom St Denis */ /* SPDX-License-Identifier: Unlicense */ /* super class file for PK algos */ /* default ... include all MPI */ #ifndef LTM_NOTHING #define LTM_ALL #endif /* RSA only (does not support DH/DSA/ECC) */ /* #define SC_RSA_1 */ /* #define SC_RSA_1_WITH_TESTS */ /* For reference.... On an Athlon64 optimizing for speed... LTM's mpi.o with all functions [striped] is 142KiB in size. */ #ifdef SC_RSA_1_WITH_TESTS # define BN_MP_ERROR_TO_STRING_C # define BN_MP_FREAD_C # define BN_MP_FWRITE_C # define BN_MP_INCR_C # define BN_MP_ISEVEN_C # define BN_MP_ISODD_C # define BN_MP_NEG_C # define BN_MP_PRIME_FROBENIUS_UNDERWOOD_C # define BN_MP_RADIX_SIZE_C # define BN_MP_RAND_C # define BN_MP_REDUCE_C # define BN_MP_REDUCE_2K_L_C # define BN_MP_FROM_SBIN_C # define BN_MP_ROOT_U32_C # define BN_MP_SET_L_C # define BN_MP_SET_UL_C # define BN_MP_SBIN_SIZE_C # define BN_MP_TO_RADIX_C # define BN_MP_TO_SBIN_C # define BN_S_MP_RAND_JENKINS_C # define BN_S_MP_RAND_PLATFORM_C #endif /* Works for RSA only, mpi.o is 68KiB */ #if defined(SC_RSA_1) || defined (SC_RSA_1_WITH_TESTS) # define BN_CUTOFFS_C # define BN_MP_ADDMOD_C # define BN_MP_CLEAR_MULTI_C # define BN_MP_EXPTMOD_C # define BN_MP_GCD_C # define BN_MP_INIT_MULTI_C # define BN_MP_INVMOD_C # define BN_MP_LCM_C # define BN_MP_MOD_C # define BN_MP_MOD_D_C # define BN_MP_MULMOD_C # define BN_MP_PRIME_IS_PRIME_C # define BN_MP_PRIME_RABIN_MILLER_TRIALS_C # define BN_MP_PRIME_RAND_C # define BN_MP_RADIX_SMAP_C # define BN_MP_SET_INT_C # define BN_MP_SHRINK_C # define BN_MP_TO_UNSIGNED_BIN_C # define BN_MP_UNSIGNED_BIN_SIZE_C # define BN_PRIME_TAB_C # define BN_S_MP_REVERSE_C /* other modifiers */ # define BN_MP_DIV_SMALL /* Slower division, not critical */ /* here we are on the last pass so we turn things off. The functions classes are still there * but we remove them specifically from the build. This also invokes tweaks in functions * like removing support for even moduli, etc... */ # ifdef LTM_LAST # undef BN_MP_DR_IS_MODULUS_C # undef BN_MP_DR_SETUP_C # undef BN_MP_DR_REDUCE_C # undef BN_MP_DIV_3_C # undef BN_MP_REDUCE_2K_SETUP_C # undef BN_MP_REDUCE_2K_C # undef BN_MP_REDUCE_IS_2K_C # undef BN_MP_REDUCE_SETUP_C # undef BN_S_MP_BALANCE_MUL_C # undef BN_S_MP_EXPTMOD_C # undef BN_S_MP_INVMOD_FAST_C # undef BN_S_MP_KARATSUBA_MUL_C # undef BN_S_MP_KARATSUBA_SQR_C # undef BN_S_MP_MUL_HIGH_DIGS_C # undef BN_S_MP_MUL_HIGH_DIGS_FAST_C # undef BN_S_MP_TOOM_MUL_C # undef BN_S_MP_TOOM_SQR_C # ifndef SC_RSA_1_WITH_TESTS # undef BN_MP_REDUCE_C # endif /* To safely undefine these you have to make sure your RSA key won't exceed the Comba threshold * which is roughly 255 digits [7140 bits for 32-bit machines, 15300 bits for 64-bit machines] * which means roughly speaking you can handle upto 2536-bit RSA keys with these defined without * trouble. */ # undef BN_MP_MONTGOMERY_REDUCE_C # undef BN_S_MP_MUL_DIGS_C # undef BN_S_MP_SQR_C # endif #endif |
Added libtommath/win32/libtommath.dll.
cannot compute difference between binary files
Added libtommath/win32/tommath.lib.
cannot compute difference between binary files
Added libtommath/win64/libtommath.dll.
cannot compute difference between binary files
Added libtommath/win64/libtommath.dll.a.
cannot compute difference between binary files
Added libtommath/win64/tommath.lib.
cannot compute difference between binary files
Changes to macosx/README.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 | http://groups.google.com/group/comp.lang.tcl/ - The Tcl'ers Wiki also has many pages dealing with Tcl & Tk on Mac OS X, see http://wiki.tcl.tk/_/ref?N=3753 http://wiki.tcl.tk/_/ref?N=8361 - Please report bugs with Tcl on Mac OS X to the tracker: | | | | | | 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 | http://groups.google.com/group/comp.lang.tcl/ - The Tcl'ers Wiki also has many pages dealing with Tcl & Tk on Mac OS X, see http://wiki.tcl.tk/_/ref?N=3753 http://wiki.tcl.tk/_/ref?N=8361 - Please report bugs with Tcl on Mac OS X to the tracker: https://core.tcl-lang.org/tcl/reportlist 2. Using Tcl on Mac OS X ------------------------ - At a minimum, Mac OS X 10.3 is required to run Tcl. - Unless weak-linking is used, Tcl built on Mac OS X 10.x will not run on 10.y with y < x; on the other hand Tcl built on 10.y will always run on 10.x with y <= x (but without any of the fixes and optimizations that would be available in a binary built on 10.x). Weak-linking is available on OS X 10.2 or later, it additionally allows Tcl built on 10.x to run on any 10.y with x > y >= z (for a chosen z >= 2). - Tcl extensions can be installed in any of: $HOME/Library/Tcl /Library/Tcl $HOME/Library/Frameworks /Library/Frameworks (searched in that order). Given a potential package directory $pkg, Tcl on OSX checks for the file $pkg/Resources/Scripts/pkgIndex.tcl as well as the usual $pkg/pkgIndex.tcl. This allows building extensions as frameworks with all script files contained in the Resources/Scripts directory of the framework. - [load]able binary extensions can linked as either ordinary shared libraries (.dylib) or as MachO bundles (since 8.4.10/8.5a3); bundles have the advantage that they are [load]ed more efficiently from a tcl VFS (no temporary copy to the native filesystem required), and prior to Mac OS X 10.5, only bundles can be [unload]ed. - The 'deploy' target of macosx/GNUmakefile installs the html manpages into the standard documentation location in the Tcl framework: Tcl.framework/Resources/Documentation/Reference/Tcl No nroff manpages are installed by default by the GNUmakefile. - The Tcl framework can be installed in any of the system's standard framework directories: $HOME/Library/Frameworks /Library/Frameworks 3. Building Tcl on Mac OS X --------------------------- - At least Mac OS X 10.3 is required to build Tcl. Apple's Xcode Developer Tools need to be installed (only the most recent version |
| ︙ | ︙ | |||
109 110 111 112 113 114 115 | ReleaseUniversal10.5SDK: build against the 10.5 SDK (with 10.5 deployment target). Note that the non-SDK configurations have their deployment target set to 10.5 (Tcl.xcode) resp. 10.6 (Tcl.xcodeproj). The Xcode projects refer to the toplevel tcl source directory via the TCL_SRCROOT user build setting, by default this is set to the project-relative path '../../tcl', if your tcl source directory is named differently, e.g. | | | | | 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 |
ReleaseUniversal10.5SDK: build against the 10.5 SDK (with 10.5
deployment target).
Note that the non-SDK configurations have their deployment target set to
10.5 (Tcl.xcode) resp. 10.6 (Tcl.xcodeproj).
The Xcode projects refer to the toplevel tcl source directory via the
TCL_SRCROOT user build setting, by default this is set to the project-relative
path '../../tcl', if your tcl source directory is named differently, e.g.
'../../tcl8.7', you need to manually change the TCL_SRCROOT setting by editing
your ${USER}.pbxuser file (located inside the Tcl.xcodeproj bundle directory)
with a text editor.
- To build universal binaries outside of the Xcode IDE, set CFLAGS as follows:
export CFLAGS="-arch i386 -arch x86_64 -arch ppc"
This requires Mac OS X 10.4 and Xcode 2.4 (or Xcode 2.2 if -arch x86_64 is
omitted, but _not_ Xcode 2.1) and will work on any architecture (on PowerPC
Tiger you need to add "-isysroot /Developer/SDKs/MacOSX10.4u.sdk").
Note that configure requires CFLAGS to contain a least one architecture that can
be run on the build machine (i.e. ppc on G3/G4, ppc or ppc64 on G5, ppc or i386
on Core and ppc, i386 or x86_64 on Core2/Xeon).
Universal builds of Tcl TEA extensions are also possible with CFLAGS set as
above, they will be [load]able by universal as well as thin binaries of Tcl.
Detailed Instructions for building with macosx/GNUmakefile
----------------------------------------------------------
- Unpack the Tcl source release archive.
- The following instructions assume the Tcl source tree is named "tcl${ver}",
(where ${ver} is a shell variable containing the Tcl version number e.g. '8.7').
Setup this shell variable as follows:
ver="8.7"
If you are building from CVS, omit this step (CVS source tree names usually do
not contain a version number).
- Setup environment variables as desired, e.g. for a universal build on 10.5:
CFLAGS="-arch i386 -arch x86_64 -arch ppc -mmacosx-version-min=10.5"
export CFLAGS
|
| ︙ | ︙ |
Changes to macosx/Tcl-Common.xcconfig.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 | PER_ARCH_CFLAGS_ppc = -mcpu=G3 -mtune=G4 $(PER_ARCH_CFLAGS_ppc) PER_ARCH_CFLAGS_ppc64 = -mcpu=G5 -mpowerpc64 $(PER_ARCH_CFLAGS_ppc64) PREFIX = /usr/local TCL_CONFIGURE_ARGS = --enable-dtrace TCL_LIBRARY = $(LIBDIR)/tcl$(VERSION) TCL_PACKAGE_PATH = "$(LIBDIR)" TCL_DEFS = HAVE_TCL_CONFIG_H | | | 30 31 32 33 34 35 36 37 | PER_ARCH_CFLAGS_ppc = -mcpu=G3 -mtune=G4 $(PER_ARCH_CFLAGS_ppc) PER_ARCH_CFLAGS_ppc64 = -mcpu=G5 -mpowerpc64 $(PER_ARCH_CFLAGS_ppc64) PREFIX = /usr/local TCL_CONFIGURE_ARGS = --enable-dtrace TCL_LIBRARY = $(LIBDIR)/tcl$(VERSION) TCL_PACKAGE_PATH = "$(LIBDIR)" TCL_DEFS = HAVE_TCL_CONFIG_H VERSION = 8.7 |
Changes to macosx/Tcl.xcode/project.pbxproj.
| ︙ | ︙ | |||
134 135 136 137 138 139 140 |
F96D493708F272C3004A47F5 /* bn_mp_rshd.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42B908F272B3004A47F5 /* bn_mp_rshd.c */; };
F96D493808F272C3004A47F5 /* bn_mp_set.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42BA08F272B3004A47F5 /* bn_mp_set.c */; };
F96D493C08F272C3004A47F5 /* bn_mp_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42BE08F272B3004A47F5 /* bn_mp_sqr.c */; };
F96D493F08F272C3004A47F5 /* bn_mp_sub.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C108F272B3004A47F5 /* bn_mp_sub.c */; };
F96D494008F272C3004A47F5 /* bn_mp_sub_d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C208F272B3004A47F5 /* bn_mp_sub_d.c */; };
F96D494608F272C3004A47F5 /* bn_mp_toom_mul.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C808F272B3004A47F5 /* bn_mp_toom_mul.c */; };
F96D494708F272C3004A47F5 /* bn_mp_toom_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C908F272B3004A47F5 /* bn_mp_toom_sqr.c */; };
| | < | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 |
F96D493708F272C3004A47F5 /* bn_mp_rshd.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42B908F272B3004A47F5 /* bn_mp_rshd.c */; };
F96D493808F272C3004A47F5 /* bn_mp_set.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42BA08F272B3004A47F5 /* bn_mp_set.c */; };
F96D493C08F272C3004A47F5 /* bn_mp_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42BE08F272B3004A47F5 /* bn_mp_sqr.c */; };
F96D493F08F272C3004A47F5 /* bn_mp_sub.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C108F272B3004A47F5 /* bn_mp_sub.c */; };
F96D494008F272C3004A47F5 /* bn_mp_sub_d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C208F272B3004A47F5 /* bn_mp_sub_d.c */; };
F96D494608F272C3004A47F5 /* bn_mp_toom_mul.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C808F272B3004A47F5 /* bn_mp_toom_mul.c */; };
F96D494708F272C3004A47F5 /* bn_mp_toom_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C908F272B3004A47F5 /* bn_mp_toom_sqr.c */; };
F96D494908F272C3004A47F5 /* bn_mp_to_radix.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CB08F272B3004A47F5 /* bn_mp_to_radix.c */; };
F96D494C08F272C3004A47F5 /* bn_mp_zero.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */; };
F96D494F08F272C3004A47F5 /* bn_s_mp_add.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */; };
F96D495108F272C3004A47F5 /* bn_s_mp_mul_digs.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */; };
F96D495308F272C3004A47F5 /* bn_s_mp_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */; };
F96D495408F272C3004A47F5 /* bn_s_mp_sub.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D608F272B3004A47F5 /* bn_s_mp_sub.c */; };
F96D49A908F272C4004A47F5 /* tclMacOSXBundle.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D433908F272B5004A47F5 /* tclMacOSXBundle.c */; };
F96D49AD08F272C4004A47F5 /* tclMacOSXFCmd.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D433D08F272B5004A47F5 /* tclMacOSXFCmd.c */; };
F96D49AE08F272C4004A47F5 /* tclMacOSXNotify.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D433E08F272B5004A47F5 /* tclMacOSXNotify.c */; };
|
| ︙ | ︙ | |||
160 161 162 163 164 165 166 |
F96D4AD308F272CA004A47F5 /* tclUnixTest.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446808F272B9004A47F5 /* tclUnixTest.c */; };
F96D4AD408F272CA004A47F5 /* tclUnixThrd.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446908F272B9004A47F5 /* tclUnixThrd.c */; };
F96D4AD608F272CA004A47F5 /* tclUnixTime.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446B08F272B9004A47F5 /* tclUnixTime.c */; };
F9E61D28090A481F002B3151 /* bn_mp_cmp_d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427108F272B3004A47F5 /* bn_mp_cmp_d.c */; };
F9E61D29090A486C002B3151 /* bn_mp_neg.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42A208F272B3004A47F5 /* bn_mp_neg.c */; };
F9E61D2A090A4891002B3151 /* bn_mp_sqrt.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C008F272B3004A47F5 /* bn_mp_sqrt.c */; };
F9E61D2B090A48A4002B3151 /* bn_mp_and.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D426C08F272B3004A47F5 /* bn_mp_and.c */; };
| | < | | | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 |
F96D4AD308F272CA004A47F5 /* tclUnixTest.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446808F272B9004A47F5 /* tclUnixTest.c */; };
F96D4AD408F272CA004A47F5 /* tclUnixThrd.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446908F272B9004A47F5 /* tclUnixThrd.c */; };
F96D4AD608F272CA004A47F5 /* tclUnixTime.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446B08F272B9004A47F5 /* tclUnixTime.c */; };
F9E61D28090A481F002B3151 /* bn_mp_cmp_d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427108F272B3004A47F5 /* bn_mp_cmp_d.c */; };
F9E61D29090A486C002B3151 /* bn_mp_neg.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42A208F272B3004A47F5 /* bn_mp_neg.c */; };
F9E61D2A090A4891002B3151 /* bn_mp_sqrt.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C008F272B3004A47F5 /* bn_mp_sqrt.c */; };
F9E61D2B090A48A4002B3151 /* bn_mp_and.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D426C08F272B3004A47F5 /* bn_mp_and.c */; };
F9E61D2C090A48AC002B3151 /* bn_mp_expt_u32.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427F08F272B3004A47F5 /* bn_mp_expt_u32.c */; };
F9E61D2C090A48AC002B3151 /* bn_mp_expt_d_ex.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427F08F272B3004A47F5 /* bn_mp_expt_d_ex.c */; };
F9E61D2D090A48BB002B3151 /* bn_mp_xor.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */; };
F9E61D2E090A48BF002B3151 /* bn_mp_or.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42A308F272B3004A47F5 /* bn_mp_or.c */; };
F9E61D2F090A48C7002B3151 /* bn_mp_shrink.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42BC08F272B3004A47F5 /* bn_mp_shrink.c */; };
F9E61D31090A48F9002B3151 /* bn_mp_to_ubin.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C608F272B3004A47F5 /* bn_mp_to_ubin.c */; };
F9E61D32090A48FA002B3151 /* bn_mp_ubin_size.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CC08F272B3004A47F5 /* bn_mp_ubin_size.c */; };
F9F4415E0C8BAE6F00BCCD67 /* tclDTrace.d in Sources */ = {isa = PBXBuildFile; fileRef = F9F4415D0C8BAE6F00BCCD67 /* tclDTrace.d */; };
F9FC77B80AB29E9100B7077D /* tclUnixCompat.c in Sources */ = {isa = PBXBuildFile; fileRef = F9FC77B70AB29E9100B7077D /* tclUnixCompat.c */; };
/* End PBXBuildFile section */
/* Begin PBXContainerItemProxy section */
F97258D20A868C6F00096C78 /* PBXContainerItemProxy */ = {
isa = PBXContainerItemProxy;
|
| ︙ | ︙ | |||
532 533 534 535 536 537 538 |
F96D3F3008F272A7004A47F5 /* tclTomMath.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclTomMath.h; sourceTree = "<group>"; };
F96D3F3108F272A7004A47F5 /* tclTomMathInterface.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclTomMathInterface.c; sourceTree = "<group>"; };
F96D3F3208F272A7004A47F5 /* tclTrace.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclTrace.c; sourceTree = "<group>"; };
F96D3F3308F272A7004A47F5 /* tclUniData.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUniData.c; sourceTree = "<group>"; };
F96D3F3408F272A7004A47F5 /* tclUtf.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUtf.c; sourceTree = "<group>"; };
F96D3F3508F272A7004A47F5 /* tclUtil.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUtil.c; sourceTree = "<group>"; };
F96D3F3608F272A7004A47F5 /* tclVar.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclVar.c; sourceTree = "<group>"; };
| < | 530 531 532 533 534 535 536 537 538 539 540 541 542 543 |
F96D3F3008F272A7004A47F5 /* tclTomMath.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclTomMath.h; sourceTree = "<group>"; };
F96D3F3108F272A7004A47F5 /* tclTomMathInterface.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclTomMathInterface.c; sourceTree = "<group>"; };
F96D3F3208F272A7004A47F5 /* tclTrace.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclTrace.c; sourceTree = "<group>"; };
F96D3F3308F272A7004A47F5 /* tclUniData.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUniData.c; sourceTree = "<group>"; };
F96D3F3408F272A7004A47F5 /* tclUtf.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUtf.c; sourceTree = "<group>"; };
F96D3F3508F272A7004A47F5 /* tclUtil.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUtil.c; sourceTree = "<group>"; };
F96D3F3608F272A7004A47F5 /* tclVar.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclVar.c; sourceTree = "<group>"; };
F96D3F3908F272A8004A47F5 /* auto.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = auto.tcl; sourceTree = "<group>"; };
F96D3F3A08F272A8004A47F5 /* clock.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = clock.tcl; sourceTree = "<group>"; };
F96D3F3C08F272A8004A47F5 /* pkgIndex.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pkgIndex.tcl; sourceTree = "<group>"; };
F96D3F8C08F272A8004A47F5 /* history.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = history.tcl; sourceTree = "<group>"; };
F96D3F8E08F272A8004A47F5 /* http.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = http.tcl; sourceTree = "<group>"; };
F96D3F8F08F272A8004A47F5 /* pkgIndex.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pkgIndex.tcl; sourceTree = "<group>"; };
F96D3F9108F272A8004A47F5 /* http.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = http.tcl; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
574 575 576 577 578 579 580 |
F96D427508F272B3004A47F5 /* bn_mp_count_bits.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_count_bits.c; sourceTree = "<group>"; };
F96D427608F272B3004A47F5 /* bn_mp_div.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div.c; sourceTree = "<group>"; };
F96D427708F272B3004A47F5 /* bn_mp_div_2.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_2.c; sourceTree = "<group>"; };
F96D427808F272B3004A47F5 /* bn_mp_div_2d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_2d.c; sourceTree = "<group>"; };
F96D427908F272B3004A47F5 /* bn_mp_div_3.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_3.c; sourceTree = "<group>"; };
F96D427A08F272B3004A47F5 /* bn_mp_div_d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_d.c; sourceTree = "<group>"; };
F96D427E08F272B3004A47F5 /* bn_mp_exch.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_exch.c; sourceTree = "<group>"; };
| | | 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 |
F96D427508F272B3004A47F5 /* bn_mp_count_bits.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_count_bits.c; sourceTree = "<group>"; };
F96D427608F272B3004A47F5 /* bn_mp_div.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div.c; sourceTree = "<group>"; };
F96D427708F272B3004A47F5 /* bn_mp_div_2.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_2.c; sourceTree = "<group>"; };
F96D427808F272B3004A47F5 /* bn_mp_div_2d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_2d.c; sourceTree = "<group>"; };
F96D427908F272B3004A47F5 /* bn_mp_div_3.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_3.c; sourceTree = "<group>"; };
F96D427A08F272B3004A47F5 /* bn_mp_div_d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_d.c; sourceTree = "<group>"; };
F96D427E08F272B3004A47F5 /* bn_mp_exch.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_exch.c; sourceTree = "<group>"; };
F96D427F08F272B3004A47F5 /* bn_mp_expt_u32.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_expt_u32.c; sourceTree = "<group>"; };
F96D428708F272B3004A47F5 /* bn_mp_grow.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_grow.c; sourceTree = "<group>"; };
F96D428808F272B3004A47F5 /* bn_mp_init.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init.c; sourceTree = "<group>"; };
F96D428908F272B3004A47F5 /* bn_mp_init_copy.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init_copy.c; sourceTree = "<group>"; };
F96D428A08F272B3004A47F5 /* bn_mp_init_multi.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init_multi.c; sourceTree = "<group>"; };
F96D428B08F272B3004A47F5 /* bn_mp_init_set.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init_set.c; sourceTree = "<group>"; };
F96D428D08F272B3004A47F5 /* bn_mp_init_size.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init_size.c; sourceTree = "<group>"; };
F96D429208F272B3004A47F5 /* bn_mp_karatsuba_mul.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_karatsuba_mul.c; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
602 603 604 605 606 607 608 |
F96D42B908F272B3004A47F5 /* bn_mp_rshd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_rshd.c; sourceTree = "<group>"; };
F96D42BA08F272B3004A47F5 /* bn_mp_set.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_set.c; sourceTree = "<group>"; };
F96D42BC08F272B3004A47F5 /* bn_mp_shrink.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_shrink.c; sourceTree = "<group>"; };
F96D42BE08F272B3004A47F5 /* bn_mp_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sqr.c; sourceTree = "<group>"; };
F96D42C008F272B3004A47F5 /* bn_mp_sqrt.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sqrt.c; sourceTree = "<group>"; };
F96D42C108F272B3004A47F5 /* bn_mp_sub.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sub.c; sourceTree = "<group>"; };
F96D42C208F272B3004A47F5 /* bn_mp_sub_d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sub_d.c; sourceTree = "<group>"; };
| | < | | < | 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 |
F96D42B908F272B3004A47F5 /* bn_mp_rshd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_rshd.c; sourceTree = "<group>"; };
F96D42BA08F272B3004A47F5 /* bn_mp_set.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_set.c; sourceTree = "<group>"; };
F96D42BC08F272B3004A47F5 /* bn_mp_shrink.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_shrink.c; sourceTree = "<group>"; };
F96D42BE08F272B3004A47F5 /* bn_mp_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sqr.c; sourceTree = "<group>"; };
F96D42C008F272B3004A47F5 /* bn_mp_sqrt.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sqrt.c; sourceTree = "<group>"; };
F96D42C108F272B3004A47F5 /* bn_mp_sub.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sub.c; sourceTree = "<group>"; };
F96D42C208F272B3004A47F5 /* bn_mp_sub_d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sub_d.c; sourceTree = "<group>"; };
F96D42C608F272B3004A47F5 /* bn_mp_to_ubin.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_to_ubin.c; sourceTree = "<group>"; };
F96D42C808F272B3004A47F5 /* bn_mp_toom_mul.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_toom_mul.c; sourceTree = "<group>"; };
F96D42C908F272B3004A47F5 /* bn_mp_toom_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_toom_sqr.c; sourceTree = "<group>"; };
F96D42CB08F272B3004A47F5 /* bn_mp_to_radix.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_to_radix.c; sourceTree = "<group>"; };
F96D42CC08F272B3004A47F5 /* bn_mp_ubin_size.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_ubin_size.c; sourceTree = "<group>"; };
F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_xor.c; sourceTree = "<group>"; };
F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_zero.c; sourceTree = "<group>"; };
F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_add.c; sourceTree = "<group>"; };
F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_mul_digs.c; sourceTree = "<group>"; };
F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_sqr.c; sourceTree = "<group>"; };
F96D42D608F272B3004A47F5 /* bn_s_mp_sub.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_sub.c; sourceTree = "<group>"; };
F96D432908F272B4004A47F5 /* tommath_class.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tommath_class.h; sourceTree = "<group>"; };
F96D432A08F272B4004A47F5 /* tommath_superclass.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tommath_superclass.h; sourceTree = "<group>"; };
F96D432B08F272B4004A47F5 /* license.terms */ = {isa = PBXFileReference; explicitFileType = text; fileEncoding = 4; path = license.terms; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
765 766 767 768 769 770 771 |
F96D43CC08F272B7004A47F5 /* winFile.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winFile.test; sourceTree = "<group>"; };
F96D43CD08F272B7004A47F5 /* winNotify.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winNotify.test; sourceTree = "<group>"; };
F96D43CE08F272B7004A47F5 /* winPipe.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winPipe.test; sourceTree = "<group>"; };
F96D43CF08F272B7004A47F5 /* winTime.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winTime.test; sourceTree = "<group>"; };
F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = checkLibraryDoc.tcl; sourceTree = "<group>"; };
F96D43D208F272B8004A47F5 /* configure */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure; sourceTree = "<group>"; };
F96D43D308F272B8004A47F5 /* configure.ac */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.ac; sourceTree = "<group>"; };
| < | 760 761 762 763 764 765 766 767 768 769 770 771 772 773 |
F96D43CC08F272B7004A47F5 /* winFile.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winFile.test; sourceTree = "<group>"; };
F96D43CD08F272B7004A47F5 /* winNotify.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winNotify.test; sourceTree = "<group>"; };
F96D43CE08F272B7004A47F5 /* winPipe.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winPipe.test; sourceTree = "<group>"; };
F96D43CF08F272B7004A47F5 /* winTime.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winTime.test; sourceTree = "<group>"; };
F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = checkLibraryDoc.tcl; sourceTree = "<group>"; };
F96D43D208F272B8004A47F5 /* configure */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure; sourceTree = "<group>"; };
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>"; };
F96D442C08F272B8004A47F5 /* man2help.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2help.tcl; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
1321 1322 1323 1324 1325 1326 1327 | F96D3F3108F272A7004A47F5 /* tclTomMathInterface.c */, F96D3F3208F272A7004A47F5 /* tclTrace.c */, F96D3F3308F272A7004A47F5 /* tclUniData.c */, F96D3F3408F272A7004A47F5 /* tclUtf.c */, F96D3F3508F272A7004A47F5 /* tclUtil.c */, F96D3F3608F272A7004A47F5 /* tclVar.c */, F96437C90EF0D4B2003F468E /* tclZlib.c */, | < > | 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 |
F96D3F3108F272A7004A47F5 /* tclTomMathInterface.c */,
F96D3F3208F272A7004A47F5 /* tclTrace.c */,
F96D3F3308F272A7004A47F5 /* tclUniData.c */,
F96D3F3408F272A7004A47F5 /* tclUtf.c */,
F96D3F3508F272A7004A47F5 /* tclUtil.c */,
F96D3F3608F272A7004A47F5 /* tclVar.c */,
F96437C90EF0D4B2003F468E /* tclZlib.c */,
);
path = generic;
sourceTree = "<group>";
};
F96D3F3808F272A7004A47F5 /* library */ = {
isa = PBXGroup;
children = (
F96D3F3908F272A8004A47F5 /* auto.tcl */,
F96D3F3A08F272A8004A47F5 /* clock.tcl */,
F96D3F3B08F272A8004A47F5 /* dde */,
F96D3F8C08F272A8004A47F5 /* history.tcl */,
F96D3F8D08F272A8004A47F5 /* http */,
F96D3F9008F272A8004A47F5 /* http1.0 */,
F96D3F9308F272A8004A47F5 /* init.tcl */,
F96D3F9408F272A8004A47F5 /* msgcat */,
F96D401708F272AA004A47F5 /* opt */,
F96D401A08F272AA004A47F5 /* package.tcl */,
F96D401B08F272AA004A47F5 /* parray.tcl */,
F9ECB1110B26521500A28025 /* platform */,
F96D401C08F272AA004A47F5 /* reg */,
|
| ︙ | ︙ | |||
1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 |
isa = PBXGroup;
children = (
F96D3F8E08F272A8004A47F5 /* http.tcl */,
F96D3F8F08F272A8004A47F5 /* pkgIndex.tcl */,
);
path = http;
sourceTree = "<group>";
};
F96D3F9408F272A8004A47F5 /* msgcat */ = {
isa = PBXGroup;
children = (
F96D3F9508F272A8004A47F5 /* msgcat.tcl */,
F96D3F9608F272A8004A47F5 /* pkgIndex.tcl */,
);
| > > > > > > > > > | 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 |
isa = PBXGroup;
children = (
F96D3F8E08F272A8004A47F5 /* http.tcl */,
F96D3F8F08F272A8004A47F5 /* pkgIndex.tcl */,
);
path = http;
sourceTree = "<group>";
};
F96D3F9008F272A8004A47F5 /* http1.0 */ = {
isa = PBXGroup;
children = (
F96D3F9108F272A8004A47F5 /* http.tcl */,
F96D3F9208F272A8004A47F5 /* pkgIndex.tcl */,
);
path = http1.0;
sourceTree = "<group>";
};
F96D3F9408F272A8004A47F5 /* msgcat */ = {
isa = PBXGroup;
children = (
F96D3F9508F272A8004A47F5 /* msgcat.tcl */,
F96D3F9608F272A8004A47F5 /* pkgIndex.tcl */,
);
|
| ︙ | ︙ | |||
1424 1425 1426 1427 1428 1429 1430 | F96D427508F272B3004A47F5 /* bn_mp_count_bits.c */, F96D427608F272B3004A47F5 /* bn_mp_div.c */, F96D427708F272B3004A47F5 /* bn_mp_div_2.c */, F96D427808F272B3004A47F5 /* bn_mp_div_2d.c */, F96D427908F272B3004A47F5 /* bn_mp_div_3.c */, F96D427A08F272B3004A47F5 /* bn_mp_div_d.c */, F96D427E08F272B3004A47F5 /* bn_mp_exch.c */, | | | 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 | F96D427508F272B3004A47F5 /* bn_mp_count_bits.c */, F96D427608F272B3004A47F5 /* bn_mp_div.c */, F96D427708F272B3004A47F5 /* bn_mp_div_2.c */, F96D427808F272B3004A47F5 /* bn_mp_div_2d.c */, F96D427908F272B3004A47F5 /* bn_mp_div_3.c */, F96D427A08F272B3004A47F5 /* bn_mp_div_d.c */, F96D427E08F272B3004A47F5 /* bn_mp_exch.c */, F96D427F08F272B3004A47F5 /* bn_mp_expt_u32.c */, F96D427F08F272B3004A47F5 /* bn_mp_expt_d_ex.c */, F96D428708F272B3004A47F5 /* bn_mp_grow.c */, F96D428808F272B3004A47F5 /* bn_mp_init.c */, F96D428908F272B3004A47F5 /* bn_mp_init_copy.c */, F96D428A08F272B3004A47F5 /* bn_mp_init_multi.c */, F96D428B08F272B3004A47F5 /* bn_mp_init_set.c */, F96D428D08F272B3004A47F5 /* bn_mp_init_size.c */, |
| ︙ | ︙ | |||
1453 1454 1455 1456 1457 1458 1459 | F96D42B908F272B3004A47F5 /* bn_mp_rshd.c */, F96D42BA08F272B3004A47F5 /* bn_mp_set.c */, F96D42BC08F272B3004A47F5 /* bn_mp_shrink.c */, F96D42BE08F272B3004A47F5 /* bn_mp_sqr.c */, F96D42C008F272B3004A47F5 /* bn_mp_sqrt.c */, F96D42C108F272B3004A47F5 /* bn_mp_sub.c */, F96D42C208F272B3004A47F5 /* bn_mp_sub_d.c */, | | < | | < | 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 | F96D42B908F272B3004A47F5 /* bn_mp_rshd.c */, F96D42BA08F272B3004A47F5 /* bn_mp_set.c */, F96D42BC08F272B3004A47F5 /* bn_mp_shrink.c */, F96D42BE08F272B3004A47F5 /* bn_mp_sqr.c */, F96D42C008F272B3004A47F5 /* bn_mp_sqrt.c */, F96D42C108F272B3004A47F5 /* bn_mp_sub.c */, F96D42C208F272B3004A47F5 /* bn_mp_sub_d.c */, F96D42C608F272B3004A47F5 /* bn_mp_to_ubin.c */, F96D42C808F272B3004A47F5 /* bn_mp_toom_mul.c */, F96D42C908F272B3004A47F5 /* bn_mp_toom_sqr.c */, F96D42CB08F272B3004A47F5 /* bn_mp_to_radix.c */, F96D42CC08F272B3004A47F5 /* bn_mp_ubin_size.c */, F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */, F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */, F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */, F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */, F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */, F96D42D608F272B3004A47F5 /* bn_s_mp_sub.c */, F96D432908F272B4004A47F5 /* tommath_class.h */, F96D432A08F272B4004A47F5 /* tommath_superclass.h */, ); |
| ︙ | ︙ | |||
1650 1651 1652 1653 1654 1655 1656 |
};
F96D43D008F272B8004A47F5 /* tools */ = {
isa = PBXGroup;
children = (
F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */,
F96D43D208F272B8004A47F5 /* configure */,
F96D43D308F272B8004A47F5 /* configure.ac */,
| < | 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 |
};
F96D43D008F272B8004A47F5 /* tools */ = {
isa = PBXGroup;
children = (
F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */,
F96D43D208F272B8004A47F5 /* configure */,
F96D43D308F272B8004A47F5 /* configure.ac */,
F96D442508F272B8004A47F5 /* genStubs.tcl */,
F96D442708F272B8004A47F5 /* index.tcl */,
F96D442808F272B8004A47F5 /* installData.tcl */,
F96D442908F272B8004A47F5 /* loadICU.tcl */,
F96D442A08F272B8004A47F5 /* Makefile.in */,
F96D442B08F272B8004A47F5 /* makeTestCases.tcl */,
F96D442C08F272B8004A47F5 /* man2help.tcl */,
|
| ︙ | ︙ | |||
2055 2056 2057 2058 2059 2060 2061 | F96D48F308F272C3004A47F5 /* bn_mp_count_bits.c in Sources */, F96D48F408F272C3004A47F5 /* bn_mp_div.c in Sources */, F96D48F508F272C3004A47F5 /* bn_mp_div_2.c in Sources */, F96D48F608F272C3004A47F5 /* bn_mp_div_2d.c in Sources */, F96D48F708F272C3004A47F5 /* bn_mp_div_3.c in Sources */, F96D48F808F272C3004A47F5 /* bn_mp_div_d.c in Sources */, F96D48FC08F272C3004A47F5 /* bn_mp_exch.c in Sources */, | | | 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 | F96D48F308F272C3004A47F5 /* bn_mp_count_bits.c in Sources */, F96D48F408F272C3004A47F5 /* bn_mp_div.c in Sources */, F96D48F508F272C3004A47F5 /* bn_mp_div_2.c in Sources */, F96D48F608F272C3004A47F5 /* bn_mp_div_2d.c in Sources */, F96D48F708F272C3004A47F5 /* bn_mp_div_3.c in Sources */, F96D48F808F272C3004A47F5 /* bn_mp_div_d.c in Sources */, F96D48FC08F272C3004A47F5 /* bn_mp_exch.c in Sources */, F9E61D2C090A48AC002B3151 /* bn_mp_expt_u32.c in Sources */, F9E61D2C090A48AC002B3151 /* bn_mp_expt_d_ex.c in Sources */, F96D490508F272C3004A47F5 /* bn_mp_grow.c in Sources */, F96D490608F272C3004A47F5 /* bn_mp_init.c in Sources */, F96D490708F272C3004A47F5 /* bn_mp_init_copy.c in Sources */, F96D490808F272C3004A47F5 /* bn_mp_init_multi.c in Sources */, F96D490908F272C3004A47F5 /* bn_mp_init_set.c in Sources */, F96D490B08F272C3004A47F5 /* bn_mp_init_size.c in Sources */, |
| ︙ | ︙ | |||
2084 2085 2086 2087 2088 2089 2090 | F96D493708F272C3004A47F5 /* bn_mp_rshd.c in Sources */, F96D493808F272C3004A47F5 /* bn_mp_set.c in Sources */, F9E61D2F090A48C7002B3151 /* bn_mp_shrink.c in Sources */, F96D493C08F272C3004A47F5 /* bn_mp_sqr.c in Sources */, F9E61D2A090A4891002B3151 /* bn_mp_sqrt.c in Sources */, F96D493F08F272C3004A47F5 /* bn_mp_sub.c in Sources */, F96D494008F272C3004A47F5 /* bn_mp_sub_d.c in Sources */, | < | | | < | 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 | F96D493708F272C3004A47F5 /* bn_mp_rshd.c in Sources */, F96D493808F272C3004A47F5 /* bn_mp_set.c in Sources */, F9E61D2F090A48C7002B3151 /* bn_mp_shrink.c in Sources */, F96D493C08F272C3004A47F5 /* bn_mp_sqr.c in Sources */, F9E61D2A090A4891002B3151 /* bn_mp_sqrt.c in Sources */, F96D493F08F272C3004A47F5 /* bn_mp_sub.c in Sources */, F96D494008F272C3004A47F5 /* bn_mp_sub_d.c in Sources */, F9E61D31090A48F9002B3151 /* bn_mp_to_ubin.c in Sources */, F96D494608F272C3004A47F5 /* bn_mp_toom_mul.c in Sources */, F96D494708F272C3004A47F5 /* bn_mp_toom_sqr.c in Sources */, F96D494908F272C3004A47F5 /* bn_mp_to_radix.c in Sources */, F9E61D32090A48FA002B3151 /* bn_mp_ubin_size.c in Sources */, F9E61D2D090A48BB002B3151 /* bn_mp_xor.c in Sources */, F96D494C08F272C3004A47F5 /* bn_mp_zero.c in Sources */, F96D494F08F272C3004A47F5 /* bn_s_mp_add.c in Sources */, F96D495108F272C3004A47F5 /* bn_s_mp_mul_digs.c in Sources */, F96D495308F272C3004A47F5 /* bn_s_mp_sqr.c in Sources */, F96D495408F272C3004A47F5 /* bn_s_mp_sub.c in Sources */, F96D49A908F272C4004A47F5 /* tclMacOSXBundle.c in Sources */, F96D49AD08F272C4004A47F5 /* tclMacOSXFCmd.c in Sources */, F96D49AE08F272C4004A47F5 /* tclMacOSXNotify.c in Sources */, |
| ︙ | ︙ |
Changes to macosx/Tcl.xcodeproj/project.pbxproj.
| ︙ | ︙ | |||
134 135 136 137 138 139 140 |
F96D493708F272C3004A47F5 /* bn_mp_rshd.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42B908F272B3004A47F5 /* bn_mp_rshd.c */; };
F96D493808F272C3004A47F5 /* bn_mp_set.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42BA08F272B3004A47F5 /* bn_mp_set.c */; };
F96D493C08F272C3004A47F5 /* bn_mp_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42BE08F272B3004A47F5 /* bn_mp_sqr.c */; };
F96D493F08F272C3004A47F5 /* bn_mp_sub.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C108F272B3004A47F5 /* bn_mp_sub.c */; };
F96D494008F272C3004A47F5 /* bn_mp_sub_d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C208F272B3004A47F5 /* bn_mp_sub_d.c */; };
F96D494608F272C3004A47F5 /* bn_mp_toom_mul.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C808F272B3004A47F5 /* bn_mp_toom_mul.c */; };
F96D494708F272C3004A47F5 /* bn_mp_toom_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C908F272B3004A47F5 /* bn_mp_toom_sqr.c */; };
| | < | 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 |
F96D493708F272C3004A47F5 /* bn_mp_rshd.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42B908F272B3004A47F5 /* bn_mp_rshd.c */; };
F96D493808F272C3004A47F5 /* bn_mp_set.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42BA08F272B3004A47F5 /* bn_mp_set.c */; };
F96D493C08F272C3004A47F5 /* bn_mp_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42BE08F272B3004A47F5 /* bn_mp_sqr.c */; };
F96D493F08F272C3004A47F5 /* bn_mp_sub.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C108F272B3004A47F5 /* bn_mp_sub.c */; };
F96D494008F272C3004A47F5 /* bn_mp_sub_d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C208F272B3004A47F5 /* bn_mp_sub_d.c */; };
F96D494608F272C3004A47F5 /* bn_mp_toom_mul.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C808F272B3004A47F5 /* bn_mp_toom_mul.c */; };
F96D494708F272C3004A47F5 /* bn_mp_toom_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C908F272B3004A47F5 /* bn_mp_toom_sqr.c */; };
F96D494908F272C3004A47F5 /* bn_mp_to_radix.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CB08F272B3004A47F5 /* bn_mp_to_radix.c */; };
F96D494C08F272C3004A47F5 /* bn_mp_zero.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */; };
F96D494F08F272C3004A47F5 /* bn_s_mp_add.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */; };
F96D495108F272C3004A47F5 /* bn_s_mp_mul_digs.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */; };
F96D495308F272C3004A47F5 /* bn_s_mp_sqr.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */; };
F96D495408F272C3004A47F5 /* bn_s_mp_sub.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42D608F272B3004A47F5 /* bn_s_mp_sub.c */; };
F96D49A908F272C4004A47F5 /* tclMacOSXBundle.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D433908F272B5004A47F5 /* tclMacOSXBundle.c */; };
F96D49AD08F272C4004A47F5 /* tclMacOSXFCmd.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D433D08F272B5004A47F5 /* tclMacOSXFCmd.c */; };
F96D49AE08F272C4004A47F5 /* tclMacOSXNotify.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D433E08F272B5004A47F5 /* tclMacOSXNotify.c */; };
|
| ︙ | ︙ | |||
160 161 162 163 164 165 166 |
F96D4AD308F272CA004A47F5 /* tclUnixTest.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446808F272B9004A47F5 /* tclUnixTest.c */; };
F96D4AD408F272CA004A47F5 /* tclUnixThrd.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446908F272B9004A47F5 /* tclUnixThrd.c */; };
F96D4AD608F272CA004A47F5 /* tclUnixTime.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446B08F272B9004A47F5 /* tclUnixTime.c */; };
F9E61D28090A481F002B3151 /* bn_mp_cmp_d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427108F272B3004A47F5 /* bn_mp_cmp_d.c */; };
F9E61D29090A486C002B3151 /* bn_mp_neg.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42A208F272B3004A47F5 /* bn_mp_neg.c */; };
F9E61D2A090A4891002B3151 /* bn_mp_sqrt.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C008F272B3004A47F5 /* bn_mp_sqrt.c */; };
F9E61D2B090A48A4002B3151 /* bn_mp_and.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D426C08F272B3004A47F5 /* bn_mp_and.c */; };
| | < < | | | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 |
F96D4AD308F272CA004A47F5 /* tclUnixTest.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446808F272B9004A47F5 /* tclUnixTest.c */; };
F96D4AD408F272CA004A47F5 /* tclUnixThrd.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446908F272B9004A47F5 /* tclUnixThrd.c */; };
F96D4AD608F272CA004A47F5 /* tclUnixTime.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D446B08F272B9004A47F5 /* tclUnixTime.c */; };
F9E61D28090A481F002B3151 /* bn_mp_cmp_d.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427108F272B3004A47F5 /* bn_mp_cmp_d.c */; };
F9E61D29090A486C002B3151 /* bn_mp_neg.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42A208F272B3004A47F5 /* bn_mp_neg.c */; };
F9E61D2A090A4891002B3151 /* bn_mp_sqrt.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C008F272B3004A47F5 /* bn_mp_sqrt.c */; };
F9E61D2B090A48A4002B3151 /* bn_mp_and.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D426C08F272B3004A47F5 /* bn_mp_and.c */; };
F9E61D2C090A48AC002B3151 /* bn_mp_expt_u32.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D427F08F272B3004A47F5 /* bn_mp_expt_u32.c */; };
F9E61D2D090A48BB002B3151 /* bn_mp_xor.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */; };
F9E61D2E090A48BF002B3151 /* bn_mp_or.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42A308F272B3004A47F5 /* bn_mp_or.c */; };
F9E61D2F090A48C7002B3151 /* bn_mp_shrink.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42BC08F272B3004A47F5 /* bn_mp_shrink.c */; };
F9E61D31090A48F9002B3151 /* bn_mp_to_ubin.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42C608F272B3004A47F5 /* bn_mp_to_ubin.c */; };
F9E61D32090A48FA002B3151 /* bn_mp_ubin_size.c in Sources */ = {isa = PBXBuildFile; fileRef = F96D42CC08F272B3004A47F5 /* bn_mp_ubin_size.c */; };
F9F4415E0C8BAE6F00BCCD67 /* tclDTrace.d in Sources */ = {isa = PBXBuildFile; fileRef = F9F4415D0C8BAE6F00BCCD67 /* tclDTrace.d */; };
F9FC77B80AB29E9100B7077D /* tclUnixCompat.c in Sources */ = {isa = PBXBuildFile; fileRef = F9FC77B70AB29E9100B7077D /* tclUnixCompat.c */; };
/* End PBXBuildFile section */
/* Begin PBXContainerItemProxy section */
F97258D20A868C6F00096C78 /* PBXContainerItemProxy */ = {
isa = PBXContainerItemProxy;
|
| ︙ | ︙ | |||
532 533 534 535 536 537 538 |
F96D3F3008F272A7004A47F5 /* tclTomMath.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclTomMath.h; sourceTree = "<group>"; };
F96D3F3108F272A7004A47F5 /* tclTomMathInterface.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclTomMathInterface.c; sourceTree = "<group>"; };
F96D3F3208F272A7004A47F5 /* tclTrace.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclTrace.c; sourceTree = "<group>"; };
F96D3F3308F272A7004A47F5 /* tclUniData.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUniData.c; sourceTree = "<group>"; };
F96D3F3408F272A7004A47F5 /* tclUtf.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUtf.c; sourceTree = "<group>"; };
F96D3F3508F272A7004A47F5 /* tclUtil.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUtil.c; sourceTree = "<group>"; };
F96D3F3608F272A7004A47F5 /* tclVar.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclVar.c; sourceTree = "<group>"; };
| < | 529 530 531 532 533 534 535 536 537 538 539 540 541 542 |
F96D3F3008F272A7004A47F5 /* tclTomMath.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclTomMath.h; sourceTree = "<group>"; };
F96D3F3108F272A7004A47F5 /* tclTomMathInterface.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclTomMathInterface.c; sourceTree = "<group>"; };
F96D3F3208F272A7004A47F5 /* tclTrace.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclTrace.c; sourceTree = "<group>"; };
F96D3F3308F272A7004A47F5 /* tclUniData.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUniData.c; sourceTree = "<group>"; };
F96D3F3408F272A7004A47F5 /* tclUtf.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUtf.c; sourceTree = "<group>"; };
F96D3F3508F272A7004A47F5 /* tclUtil.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUtil.c; sourceTree = "<group>"; };
F96D3F3608F272A7004A47F5 /* tclVar.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclVar.c; sourceTree = "<group>"; };
F96D3F3908F272A8004A47F5 /* auto.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = auto.tcl; sourceTree = "<group>"; };
F96D3F3A08F272A8004A47F5 /* clock.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = clock.tcl; sourceTree = "<group>"; };
F96D3F3C08F272A8004A47F5 /* pkgIndex.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pkgIndex.tcl; sourceTree = "<group>"; };
F96D3F8C08F272A8004A47F5 /* history.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = history.tcl; sourceTree = "<group>"; };
F96D3F8E08F272A8004A47F5 /* http.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = http.tcl; sourceTree = "<group>"; };
F96D3F8F08F272A8004A47F5 /* pkgIndex.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = pkgIndex.tcl; sourceTree = "<group>"; };
F96D3F9108F272A8004A47F5 /* http.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = http.tcl; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
574 575 576 577 578 579 580 |
F96D427508F272B3004A47F5 /* bn_mp_count_bits.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_count_bits.c; sourceTree = "<group>"; };
F96D427608F272B3004A47F5 /* bn_mp_div.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div.c; sourceTree = "<group>"; };
F96D427708F272B3004A47F5 /* bn_mp_div_2.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_2.c; sourceTree = "<group>"; };
F96D427808F272B3004A47F5 /* bn_mp_div_2d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_2d.c; sourceTree = "<group>"; };
F96D427908F272B3004A47F5 /* bn_mp_div_3.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_3.c; sourceTree = "<group>"; };
F96D427A08F272B3004A47F5 /* bn_mp_div_d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_d.c; sourceTree = "<group>"; };
F96D427E08F272B3004A47F5 /* bn_mp_exch.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_exch.c; sourceTree = "<group>"; };
| | | 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 |
F96D427508F272B3004A47F5 /* bn_mp_count_bits.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_count_bits.c; sourceTree = "<group>"; };
F96D427608F272B3004A47F5 /* bn_mp_div.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div.c; sourceTree = "<group>"; };
F96D427708F272B3004A47F5 /* bn_mp_div_2.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_2.c; sourceTree = "<group>"; };
F96D427808F272B3004A47F5 /* bn_mp_div_2d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_2d.c; sourceTree = "<group>"; };
F96D427908F272B3004A47F5 /* bn_mp_div_3.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_3.c; sourceTree = "<group>"; };
F96D427A08F272B3004A47F5 /* bn_mp_div_d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_div_d.c; sourceTree = "<group>"; };
F96D427E08F272B3004A47F5 /* bn_mp_exch.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_exch.c; sourceTree = "<group>"; };
F96D427F08F272B3004A47F5 /* bn_mp_expt_u32.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_expt_u32.c; sourceTree = "<group>"; };
F96D427F08F272B3004A47F5 /* bn_mp_expt_d_ex.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_expt_d_ex.c; sourceTree = "<group>"; };
F96D428708F272B3004A47F5 /* bn_mp_grow.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_grow.c; sourceTree = "<group>"; };
F96D428808F272B3004A47F5 /* bn_mp_init.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init.c; sourceTree = "<group>"; };
F96D428908F272B3004A47F5 /* bn_mp_init_copy.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init_copy.c; sourceTree = "<group>"; };
F96D428A08F272B3004A47F5 /* bn_mp_init_multi.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init_multi.c; sourceTree = "<group>"; };
F96D428B08F272B3004A47F5 /* bn_mp_init_set.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init_set.c; sourceTree = "<group>"; };
F96D428D08F272B3004A47F5 /* bn_mp_init_size.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_init_size.c; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
603 604 605 606 607 608 609 |
F96D42B908F272B3004A47F5 /* bn_mp_rshd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_rshd.c; sourceTree = "<group>"; };
F96D42BA08F272B3004A47F5 /* bn_mp_set.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_set.c; sourceTree = "<group>"; };
F96D42BC08F272B3004A47F5 /* bn_mp_shrink.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_shrink.c; sourceTree = "<group>"; };
F96D42BE08F272B3004A47F5 /* bn_mp_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sqr.c; sourceTree = "<group>"; };
F96D42C008F272B3004A47F5 /* bn_mp_sqrt.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sqrt.c; sourceTree = "<group>"; };
F96D42C108F272B3004A47F5 /* bn_mp_sub.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sub.c; sourceTree = "<group>"; };
F96D42C208F272B3004A47F5 /* bn_mp_sub_d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sub_d.c; sourceTree = "<group>"; };
| | < | | < | 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 |
F96D42B908F272B3004A47F5 /* bn_mp_rshd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_rshd.c; sourceTree = "<group>"; };
F96D42BA08F272B3004A47F5 /* bn_mp_set.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_set.c; sourceTree = "<group>"; };
F96D42BC08F272B3004A47F5 /* bn_mp_shrink.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_shrink.c; sourceTree = "<group>"; };
F96D42BE08F272B3004A47F5 /* bn_mp_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sqr.c; sourceTree = "<group>"; };
F96D42C008F272B3004A47F5 /* bn_mp_sqrt.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sqrt.c; sourceTree = "<group>"; };
F96D42C108F272B3004A47F5 /* bn_mp_sub.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sub.c; sourceTree = "<group>"; };
F96D42C208F272B3004A47F5 /* bn_mp_sub_d.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_sub_d.c; sourceTree = "<group>"; };
F96D42C608F272B3004A47F5 /* bn_mp_to_ubin.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_to_ubin.c; sourceTree = "<group>"; };
F96D42C808F272B3004A47F5 /* bn_mp_toom_mul.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_toom_mul.c; sourceTree = "<group>"; };
F96D42C908F272B3004A47F5 /* bn_mp_toom_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_toom_sqr.c; sourceTree = "<group>"; };
F96D42CB08F272B3004A47F5 /* bn_mp_to_radix.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_to_radix.c; sourceTree = "<group>"; };
F96D42CC08F272B3004A47F5 /* bn_mp_ubin_size.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_ubin_size.c; sourceTree = "<group>"; };
F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_xor.c; sourceTree = "<group>"; };
F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_mp_zero.c; sourceTree = "<group>"; };
F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_add.c; sourceTree = "<group>"; };
F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_mul_digs.c; sourceTree = "<group>"; };
F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_sqr.c; sourceTree = "<group>"; };
F96D42D608F272B3004A47F5 /* bn_s_mp_sub.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = bn_s_mp_sub.c; sourceTree = "<group>"; };
F96D432908F272B4004A47F5 /* tommath_class.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tommath_class.h; sourceTree = "<group>"; };
F96D432A08F272B4004A47F5 /* tommath_superclass.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tommath_superclass.h; sourceTree = "<group>"; };
F96D432B08F272B4004A47F5 /* license.terms */ = {isa = PBXFileReference; explicitFileType = text; fileEncoding = 4; path = license.terms; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
766 767 768 769 770 771 772 |
F96D43CC08F272B7004A47F5 /* winFile.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winFile.test; sourceTree = "<group>"; };
F96D43CD08F272B7004A47F5 /* winNotify.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winNotify.test; sourceTree = "<group>"; };
F96D43CE08F272B7004A47F5 /* winPipe.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winPipe.test; sourceTree = "<group>"; };
F96D43CF08F272B7004A47F5 /* winTime.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winTime.test; sourceTree = "<group>"; };
F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = checkLibraryDoc.tcl; sourceTree = "<group>"; };
F96D43D208F272B8004A47F5 /* configure */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure; sourceTree = "<group>"; };
F96D43D308F272B8004A47F5 /* configure.ac */ = {isa = PBXFileReference; explicitFileType = text.script.sh; fileEncoding = 4; path = configure.ac; sourceTree = "<group>"; };
| < | 760 761 762 763 764 765 766 767 768 769 770 771 772 773 |
F96D43CC08F272B7004A47F5 /* winFile.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winFile.test; sourceTree = "<group>"; };
F96D43CD08F272B7004A47F5 /* winNotify.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winNotify.test; sourceTree = "<group>"; };
F96D43CE08F272B7004A47F5 /* winPipe.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winPipe.test; sourceTree = "<group>"; };
F96D43CF08F272B7004A47F5 /* winTime.test */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = winTime.test; sourceTree = "<group>"; };
F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = checkLibraryDoc.tcl; sourceTree = "<group>"; };
F96D43D208F272B8004A47F5 /* configure */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = text.script.sh; path = configure; sourceTree = "<group>"; };
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>"; };
F96D442C08F272B8004A47F5 /* man2help.tcl */ = {isa = PBXFileReference; explicitFileType = text.script; fileEncoding = 4; path = man2help.tcl; sourceTree = "<group>"; };
|
| ︙ | ︙ | |||
1322 1323 1324 1325 1326 1327 1328 | F96D3F3108F272A7004A47F5 /* tclTomMathInterface.c */, F96D3F3208F272A7004A47F5 /* tclTrace.c */, F96D3F3308F272A7004A47F5 /* tclUniData.c */, F96D3F3408F272A7004A47F5 /* tclUtf.c */, F96D3F3508F272A7004A47F5 /* tclUtil.c */, F96D3F3608F272A7004A47F5 /* tclVar.c */, F96437C90EF0D4B2003F468E /* tclZlib.c */, | < > | 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 |
F96D3F3108F272A7004A47F5 /* tclTomMathInterface.c */,
F96D3F3208F272A7004A47F5 /* tclTrace.c */,
F96D3F3308F272A7004A47F5 /* tclUniData.c */,
F96D3F3408F272A7004A47F5 /* tclUtf.c */,
F96D3F3508F272A7004A47F5 /* tclUtil.c */,
F96D3F3608F272A7004A47F5 /* tclVar.c */,
F96437C90EF0D4B2003F468E /* tclZlib.c */,
);
path = generic;
sourceTree = "<group>";
};
F96D3F3808F272A7004A47F5 /* library */ = {
isa = PBXGroup;
children = (
F96D3F3908F272A8004A47F5 /* auto.tcl */,
F96D3F3A08F272A8004A47F5 /* clock.tcl */,
F96D3F3B08F272A8004A47F5 /* dde */,
F96D3F8C08F272A8004A47F5 /* history.tcl */,
F96D3F8D08F272A8004A47F5 /* http */,
F96D3F9008F272A8004A47F5 /* http1.0 */,
F96D3F9308F272A8004A47F5 /* init.tcl */,
F96D3F9408F272A8004A47F5 /* msgcat */,
F96D401708F272AA004A47F5 /* opt */,
F96D401A08F272AA004A47F5 /* package.tcl */,
F96D401B08F272AA004A47F5 /* parray.tcl */,
F9ECB1110B26521500A28025 /* platform */,
F96D401C08F272AA004A47F5 /* reg */,
|
| ︙ | ︙ | |||
1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 |
isa = PBXGroup;
children = (
F96D3F8E08F272A8004A47F5 /* http.tcl */,
F96D3F8F08F272A8004A47F5 /* pkgIndex.tcl */,
);
path = http;
sourceTree = "<group>";
};
F96D3F9408F272A8004A47F5 /* msgcat */ = {
isa = PBXGroup;
children = (
F96D3F9508F272A8004A47F5 /* msgcat.tcl */,
F96D3F9608F272A8004A47F5 /* pkgIndex.tcl */,
);
| > > > > > > > > > | 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 |
isa = PBXGroup;
children = (
F96D3F8E08F272A8004A47F5 /* http.tcl */,
F96D3F8F08F272A8004A47F5 /* pkgIndex.tcl */,
);
path = http;
sourceTree = "<group>";
};
F96D3F9008F272A8004A47F5 /* http1.0 */ = {
isa = PBXGroup;
children = (
F96D3F9108F272A8004A47F5 /* http.tcl */,
F96D3F9208F272A8004A47F5 /* pkgIndex.tcl */,
);
path = http1.0;
sourceTree = "<group>";
};
F96D3F9408F272A8004A47F5 /* msgcat */ = {
isa = PBXGroup;
children = (
F96D3F9508F272A8004A47F5 /* msgcat.tcl */,
F96D3F9608F272A8004A47F5 /* pkgIndex.tcl */,
);
|
| ︙ | ︙ | |||
1425 1426 1427 1428 1429 1430 1431 | F96D427508F272B3004A47F5 /* bn_mp_count_bits.c */, F96D427608F272B3004A47F5 /* bn_mp_div.c */, F96D427708F272B3004A47F5 /* bn_mp_div_2.c */, F96D427808F272B3004A47F5 /* bn_mp_div_2d.c */, F96D427908F272B3004A47F5 /* bn_mp_div_3.c */, F96D427A08F272B3004A47F5 /* bn_mp_div_d.c */, F96D427E08F272B3004A47F5 /* bn_mp_exch.c */, | | | 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 | F96D427508F272B3004A47F5 /* bn_mp_count_bits.c */, F96D427608F272B3004A47F5 /* bn_mp_div.c */, F96D427708F272B3004A47F5 /* bn_mp_div_2.c */, F96D427808F272B3004A47F5 /* bn_mp_div_2d.c */, F96D427908F272B3004A47F5 /* bn_mp_div_3.c */, F96D427A08F272B3004A47F5 /* bn_mp_div_d.c */, F96D427E08F272B3004A47F5 /* bn_mp_exch.c */, F96D427F08F272B3004A47F5 /* bn_mp_expt_u32.c */, F96D427F08F272B3004A47F5 /* bn_mp_expt_d_ex.c */, F96D428708F272B3004A47F5 /* bn_mp_grow.c */, F96D428808F272B3004A47F5 /* bn_mp_init.c */, F96D428908F272B3004A47F5 /* bn_mp_init_copy.c */, F96D428A08F272B3004A47F5 /* bn_mp_init_multi.c */, F96D428B08F272B3004A47F5 /* bn_mp_init_set.c */, F96D428D08F272B3004A47F5 /* bn_mp_init_size.c */, |
| ︙ | ︙ | |||
1454 1455 1456 1457 1458 1459 1460 | F96D42B908F272B3004A47F5 /* bn_mp_rshd.c */, F96D42BA08F272B3004A47F5 /* bn_mp_set.c */, F96D42BC08F272B3004A47F5 /* bn_mp_shrink.c */, F96D42BE08F272B3004A47F5 /* bn_mp_sqr.c */, F96D42C008F272B3004A47F5 /* bn_mp_sqrt.c */, F96D42C108F272B3004A47F5 /* bn_mp_sub.c */, F96D42C208F272B3004A47F5 /* bn_mp_sub_d.c */, | | < | | < | 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 | F96D42B908F272B3004A47F5 /* bn_mp_rshd.c */, F96D42BA08F272B3004A47F5 /* bn_mp_set.c */, F96D42BC08F272B3004A47F5 /* bn_mp_shrink.c */, F96D42BE08F272B3004A47F5 /* bn_mp_sqr.c */, F96D42C008F272B3004A47F5 /* bn_mp_sqrt.c */, F96D42C108F272B3004A47F5 /* bn_mp_sub.c */, F96D42C208F272B3004A47F5 /* bn_mp_sub_d.c */, F96D42C608F272B3004A47F5 /* bn_mp_to_ubin.c */, F96D42C808F272B3004A47F5 /* bn_mp_toom_mul.c */, F96D42C908F272B3004A47F5 /* bn_mp_toom_sqr.c */, F96D42CB08F272B3004A47F5 /* bn_mp_to_radix.c */, F96D42CC08F272B3004A47F5 /* bn_mp_ubin_size.c */, F96D42CD08F272B3004A47F5 /* bn_mp_xor.c */, F96D42CE08F272B3004A47F5 /* bn_mp_zero.c */, F96D42D108F272B3004A47F5 /* bn_s_mp_add.c */, F96D42D308F272B3004A47F5 /* bn_s_mp_mul_digs.c */, F96D42D508F272B3004A47F5 /* bn_s_mp_sqr.c */, F96D42D608F272B3004A47F5 /* bn_s_mp_sub.c */, F96D432908F272B4004A47F5 /* tommath_class.h */, F96D432A08F272B4004A47F5 /* tommath_superclass.h */, ); |
| ︙ | ︙ | |||
1651 1652 1653 1654 1655 1656 1657 |
};
F96D43D008F272B8004A47F5 /* tools */ = {
isa = PBXGroup;
children = (
F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */,
F96D43D208F272B8004A47F5 /* configure */,
F96D43D308F272B8004A47F5 /* configure.ac */,
| < | 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 |
};
F96D43D008F272B8004A47F5 /* tools */ = {
isa = PBXGroup;
children = (
F96D43D108F272B8004A47F5 /* checkLibraryDoc.tcl */,
F96D43D208F272B8004A47F5 /* configure */,
F96D43D308F272B8004A47F5 /* configure.ac */,
F96D442508F272B8004A47F5 /* genStubs.tcl */,
F96D442708F272B8004A47F5 /* index.tcl */,
F96D442808F272B8004A47F5 /* installData.tcl */,
F96D442908F272B8004A47F5 /* loadICU.tcl */,
F96D442A08F272B8004A47F5 /* Makefile.in */,
F96D442B08F272B8004A47F5 /* makeTestCases.tcl */,
F96D442C08F272B8004A47F5 /* man2help.tcl */,
|
| ︙ | ︙ | |||
2056 2057 2058 2059 2060 2061 2062 | F96D48F308F272C3004A47F5 /* bn_mp_count_bits.c in Sources */, F96D48F408F272C3004A47F5 /* bn_mp_div.c in Sources */, F96D48F508F272C3004A47F5 /* bn_mp_div_2.c in Sources */, F96D48F608F272C3004A47F5 /* bn_mp_div_2d.c in Sources */, F96D48F708F272C3004A47F5 /* bn_mp_div_3.c in Sources */, F96D48F808F272C3004A47F5 /* bn_mp_div_d.c in Sources */, F96D48FC08F272C3004A47F5 /* bn_mp_exch.c in Sources */, | | | 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 | F96D48F308F272C3004A47F5 /* bn_mp_count_bits.c in Sources */, F96D48F408F272C3004A47F5 /* bn_mp_div.c in Sources */, F96D48F508F272C3004A47F5 /* bn_mp_div_2.c in Sources */, F96D48F608F272C3004A47F5 /* bn_mp_div_2d.c in Sources */, F96D48F708F272C3004A47F5 /* bn_mp_div_3.c in Sources */, F96D48F808F272C3004A47F5 /* bn_mp_div_d.c in Sources */, F96D48FC08F272C3004A47F5 /* bn_mp_exch.c in Sources */, F9E61D2C090A48AC002B3151 /* bn_mp_expt_u32.c in Sources */, F9E61D2C090A48AC002B3151 /* bn_mp_expt_d_ex.c in Sources */, F96D490508F272C3004A47F5 /* bn_mp_grow.c in Sources */, F96D490608F272C3004A47F5 /* bn_mp_init.c in Sources */, F96D490708F272C3004A47F5 /* bn_mp_init_copy.c in Sources */, F96D490808F272C3004A47F5 /* bn_mp_init_multi.c in Sources */, F96D490908F272C3004A47F5 /* bn_mp_init_set.c in Sources */, F96D490B08F272C3004A47F5 /* bn_mp_init_size.c in Sources */, |
| ︙ | ︙ | |||
2085 2086 2087 2088 2089 2090 2091 | F96D493708F272C3004A47F5 /* bn_mp_rshd.c in Sources */, F96D493808F272C3004A47F5 /* bn_mp_set.c in Sources */, F9E61D2F090A48C7002B3151 /* bn_mp_shrink.c in Sources */, F96D493C08F272C3004A47F5 /* bn_mp_sqr.c in Sources */, F9E61D2A090A4891002B3151 /* bn_mp_sqrt.c in Sources */, F96D493F08F272C3004A47F5 /* bn_mp_sub.c in Sources */, F96D494008F272C3004A47F5 /* bn_mp_sub_d.c in Sources */, | < | | | < | 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 | F96D493708F272C3004A47F5 /* bn_mp_rshd.c in Sources */, F96D493808F272C3004A47F5 /* bn_mp_set.c in Sources */, F9E61D2F090A48C7002B3151 /* bn_mp_shrink.c in Sources */, F96D493C08F272C3004A47F5 /* bn_mp_sqr.c in Sources */, F9E61D2A090A4891002B3151 /* bn_mp_sqrt.c in Sources */, F96D493F08F272C3004A47F5 /* bn_mp_sub.c in Sources */, F96D494008F272C3004A47F5 /* bn_mp_sub_d.c in Sources */, F9E61D31090A48F9002B3151 /* bn_mp_to_ubin.c in Sources */, F96D494608F272C3004A47F5 /* bn_mp_toom_mul.c in Sources */, F96D494708F272C3004A47F5 /* bn_mp_toom_sqr.c in Sources */, F96D494908F272C3004A47F5 /* bn_mp_to_radix.c in Sources */, F9E61D32090A48FA002B3151 /* bn_mp_ubin_size.c in Sources */, F9E61D2D090A48BB002B3151 /* bn_mp_xor.c in Sources */, F96D494C08F272C3004A47F5 /* bn_mp_zero.c in Sources */, F96D494F08F272C3004A47F5 /* bn_s_mp_add.c in Sources */, F96D495108F272C3004A47F5 /* bn_s_mp_mul_digs.c in Sources */, F96D495308F272C3004A47F5 /* bn_s_mp_sqr.c in Sources */, F96D495408F272C3004A47F5 /* bn_s_mp_sub.c in Sources */, F96D49A908F272C4004A47F5 /* tclMacOSXBundle.c in Sources */, F96D49AD08F272C4004A47F5 /* tclMacOSXFCmd.c in Sources */, F96D49AE08F272C4004A47F5 /* tclMacOSXNotify.c in Sources */, |
| ︙ | ︙ |
Changes to macosx/tclMacOSXBundle.c.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 15 16 17 18 19 20 21 | * Copyright (c) 2003-2009 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclPort.h" #ifdef HAVE_COREFOUNDATION #include <CoreFoundation/CoreFoundation.h> #ifndef TCL_DYLD_USE_DLFCN /* * Use preferred dlfcn API on 10.4 and later | > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | * Copyright (c) 2003-2009 Daniel A. Steffen <das@users.sourceforge.net> * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclPort.h" #include "tclInt.h" #ifdef HAVE_COREFOUNDATION #include <CoreFoundation/CoreFoundation.h> #ifndef TCL_DYLD_USE_DLFCN /* * Use preferred dlfcn API on 10.4 and later |
| ︙ | ︙ | |||
102 103 104 105 106 107 108 |
if (!initialized) {
#if TCL_DYLD_USE_DLFCN
#if MAC_OS_X_VERSION_MIN_REQUIRED < 1040
if (tclMacOSXDarwinRelease >= 8)
#endif
{
| | | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 |
if (!initialized) {
#if TCL_DYLD_USE_DLFCN
#if MAC_OS_X_VERSION_MIN_REQUIRED < 1040
if (tclMacOSXDarwinRelease >= 8)
#endif
{
openresourcemap = (short (*)(CFBundleRef))dlsym(RTLD_NEXT,
"CFBundleOpenBundleResourceMap");
#ifdef TCL_DEBUG_LOAD
if (!openresourcemap) {
const char *errMsg = dlerror();
TclLoadDbgMsg("dlsym() failed: %s", errMsg);
}
|
| ︙ | ︙ | |||
158 159 160 161 162 163 164 165 166 167 168 169 |
*
* Side effects:
* libraryVariableName may be set, and the resource file opened.
*
*----------------------------------------------------------------------
*/
int
Tcl_MacOSXOpenBundleResources(
Tcl_Interp *interp,
const char *bundleName,
int hasResourceFile,
| > > | > | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 |
*
* Side effects:
* libraryVariableName may be set, and the resource file opened.
*
*----------------------------------------------------------------------
*/
#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9)
#undef Tcl_MacOSXOpenBundleResources
int
Tcl_MacOSXOpenBundleResources(
Tcl_Interp *interp,
const char *bundleName,
int hasResourceFile,
int maxPathLen,
char *libraryPath)
{
return Tcl_MacOSXOpenVersionedBundleResources(interp, bundleName, NULL,
hasResourceFile, maxPathLen, libraryPath);
}
#endif
/*
*----------------------------------------------------------------------
*
* Tcl_MacOSXOpenVersionedBundleResources --
*
* Given the bundle and version name for a shared library (version name
|
| ︙ | ︙ | |||
193 194 195 196 197 198 199 | * libraryVariableName may be set, and the resource file opened. * *---------------------------------------------------------------------- */ int Tcl_MacOSXOpenVersionedBundleResources( | | | | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 |
* libraryVariableName may be set, and the resource file opened.
*
*----------------------------------------------------------------------
*/
int
Tcl_MacOSXOpenVersionedBundleResources(
TCL_UNUSED(Tcl_Interp *),
const char *bundleName,
const char *bundleVersion,
int hasResourceFile,
int maxPathLen,
char *libraryPath)
{
#ifdef HAVE_COREFOUNDATION
CFBundleRef bundleRef, versionedBundleRef = NULL;
CFStringRef bundleNameRef;
CFURLRef libURL;
|
| ︙ | ︙ |
Changes to macosx/tclMacOSXFCmd.c.
| ︙ | ︙ | |||
168 169 170 171 172 173 174 |
bzero(&alist, sizeof(struct attrlist));
alist.bitmapcount = ATTR_BIT_MAP_COUNT;
if (objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) {
alist.fileattr = ATTR_FILE_RSRCLENGTH;
} else {
alist.commonattr = ATTR_CMN_FNDRINFO;
}
| | | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 |
bzero(&alist, sizeof(struct attrlist));
alist.bitmapcount = ATTR_BIT_MAP_COUNT;
if (objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) {
alist.fileattr = ATTR_FILE_RSRCLENGTH;
} else {
alist.commonattr = ATTR_CMN_FNDRINFO;
}
native = (const char *)Tcl_FSGetNativePath(fileName);
result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0);
if (result != 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read attributes of \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
return TCL_ERROR;
|
| ︙ | ︙ | |||
264 265 266 267 268 269 270 |
bzero(&alist, sizeof(struct attrlist));
alist.bitmapcount = ATTR_BIT_MAP_COUNT;
if (objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) {
alist.fileattr = ATTR_FILE_RSRCLENGTH;
} else {
alist.commonattr = ATTR_CMN_FNDRINFO;
}
| | | 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 |
bzero(&alist, sizeof(struct attrlist));
alist.bitmapcount = ATTR_BIT_MAP_COUNT;
if (objIndex == MACOSX_RSRCLENGTH_ATTRIBUTE) {
alist.fileattr = ATTR_FILE_RSRCLENGTH;
} else {
alist.commonattr = ATTR_CMN_FNDRINFO;
}
native = (const char *)Tcl_FSGetNativePath(fileName);
result = getattrlist(native, &alist, &finfo, sizeof(fileinfobuf), 0);
if (result != 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read attributes of \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
return TCL_ERROR;
|
| ︙ | ︙ | |||
343 344 345 346 347 348 349 | * Construct path to resource fork. */ Tcl_DStringInit(&ds); Tcl_DStringAppend(&ds, native, -1); Tcl_DStringAppend(&ds, _PATH_RSRCFORKSPEC, -1); | | | 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 |
* Construct path to resource fork.
*/
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, native, -1);
Tcl_DStringAppend(&ds, _PATH_RSRCFORKSPEC, -1);
result = truncate(Tcl_DStringValue(&ds), 0);
if (result != 0) {
/*
* truncate() on a valid resource fork path may fail with a
* permission error in some OS releases, try truncating with
* open() instead:
*/
|
| ︙ | ︙ | |||
635 636 637 638 639 640 641 |
Tcl_Interp *interp, /* Tcl interpreter */
Tcl_Obj *objPtr) /* Pointer to the object to convert */
{
const char *string;
int result = TCL_OK;
Tcl_DString ds;
Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman");
| < | | | 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 |
Tcl_Interp *interp, /* Tcl interpreter */
Tcl_Obj *objPtr) /* Pointer to the object to convert */
{
const char *string;
int result = TCL_OK;
Tcl_DString ds;
Tcl_Encoding encoding = Tcl_GetEncoding(NULL, "macRoman");
string = TclGetString(objPtr);
Tcl_UtfToExternalDString(encoding, string, objPtr->length, &ds);
if (Tcl_DStringLength(&ds) > 4) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected Macintosh OS type but got \"%s\": ", string));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "MAC_OSTYPE", NULL);
}
|
| ︙ | ︙ | |||
686 687 688 689 690 691 692 | * OSType-to-string conversion. * *---------------------------------------------------------------------- */ static void UpdateStringOfOSType( | | | 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 |
* OSType-to-string conversion.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfOSType(
Tcl_Obj *objPtr) /* OSType object whose string rep to
* update. */
{
const int size = TCL_UTF_MAX * 4;
char *dst = Tcl_InitStringRep(objPtr, NULL, size);
OSType osType = (OSType) objPtr->internalRep.wideValue;
int written = 0;
Tcl_Encoding encoding;
|
| ︙ | ︙ |
Changes to macosx/tclMacOSXNotify.c.
| ︙ | ︙ | |||
751 752 753 754 755 756 757 | * notifier instance. * *---------------------------------------------------------------------- */ void Tcl_FinalizeNotifier( | | | 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 |
* notifier instance.
*
*----------------------------------------------------------------------
*/
void
Tcl_FinalizeNotifier(
ClientData clientData)
{
ThreadSpecificData *tsdPtr;
if (tclNotifierHooks.finalizeNotifierProc) {
tclNotifierHooks.finalizeNotifierProc(clientData);
return;
}
|
| ︙ | ︙ | |||
854 855 856 857 858 859 860 |
*----------------------------------------------------------------------
*/
void
Tcl_AlertNotifier(
ClientData clientData)
{
| | | 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 |
*----------------------------------------------------------------------
*/
void
Tcl_AlertNotifier(
ClientData clientData)
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)clientData;
if (tclNotifierHooks.alertNotifierProc) {
tclNotifierHooks.alertNotifierProc(clientData);
return;
}
LOCK_NOTIFIER_TSD;
|
| ︙ | ︙ | |||
938 939 940 941 942 943 944 | * None. * *---------------------------------------------------------------------- */ static void TimerWakeUp( | | | | 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 |
* None.
*
*----------------------------------------------------------------------
*/
static void
TimerWakeUp(
TCL_UNUSED(CFRunLoopTimerRef),
TCL_UNUSED(ClientData))
{
}
/*
*----------------------------------------------------------------------
*
* Tcl_ServiceModeHook --
|
| ︙ | ︙ | |||
1032 1033 1034 1035 1036 1037 1038 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
| | | 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
filePtr = (FileHandler *)ckalloc(sizeof(FileHandler));
filePtr->fd = fd;
filePtr->readyMask = 0;
filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
tsdPtr->firstFileHandlerPtr = filePtr;
}
filePtr->proc = proc;
filePtr->clientData = clientData;
|
| ︙ | ︙ | |||
1160 1161 1162 1163 1164 1165 1166 |
*/
if (prevPtr == NULL) {
tsdPtr->firstFileHandlerPtr = filePtr->nextPtr;
} else {
prevPtr->nextPtr = filePtr->nextPtr;
}
| | | 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 |
*/
if (prevPtr == NULL) {
tsdPtr->firstFileHandlerPtr = filePtr->nextPtr;
} else {
prevPtr->nextPtr = filePtr->nextPtr;
}
ckfree(filePtr);
}
/*
*----------------------------------------------------------------------
*
* FileHandlerEventProc --
*
|
| ︙ | ︙ | |||
1376 1377 1378 1379 1380 1381 1382 |
static void
QueueFileEvents(
void *info)
{
SelectMasks readyMasks;
FileHandler *filePtr;
| | | 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 |
static void
QueueFileEvents(
void *info)
{
SelectMasks readyMasks;
FileHandler *filePtr;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)info;
/*
* Queue all detected file events.
*/
LOCK_NOTIFIER_TSD;
FD_COPY(&tsdPtr->readyMasks.readable, &readyMasks.readable);
|
| ︙ | ︙ | |||
1415 1416 1417 1418 1419 1420 1421 |
/*
* Don't bother to queue an event if the mask was previously non-zero
* since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
| | | 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 |
/*
* Don't bother to queue an event if the mask was previously non-zero
* since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)ckalloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
}
filePtr->readyMask = mask;
}
|
| ︙ | ︙ | |||
1444 1445 1446 1447 1448 1449 1450 | * None. * *---------------------------------------------------------------------- */ static void UpdateWaitingListAndServiceEvents( | | | | 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 |
* None.
*
*----------------------------------------------------------------------
*/
static void
UpdateWaitingListAndServiceEvents(
TCL_UNUSED(CFRunLoopObserverRef),
CFRunLoopActivity activity,
void *info)
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)info;
if (tsdPtr->sleeping) {
return;
}
switch (activity) {
case kCFRunLoopEntry:
tsdPtr->runLoopNestingLevel++;
|
| ︙ | ︙ | |||
1823 1824 1825 1826 1827 1828 1829 | * the notifier thread first starts. * *---------------------------------------------------------------------- */ static TCL_NORETURN void NotifierThreadProc( | | | 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 |
* the notifier thread first starts.
*
*----------------------------------------------------------------------
*/
static TCL_NORETURN void
NotifierThreadProc(
TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr;
fd_set readableMask, writableMask, exceptionalMask;
int i, numFdBits = 0, polling;
struct timeval poll = {0., 0.}, *timePtr;
char buf[2];
|
| ︙ | ︙ |
Changes to tests-perf/clock.perf.tcl.
| ︙ | ︙ | |||
118 119 120 121 122 123 124 |
{clock format 1482525936 -format "%%a = %a | %%A = %A | %%b = %b | %%h = %h | %%B = %B | %%C = %C | %%d = %d | %%e = %e | %%g = %g | %%G = %G | %%H = %H | %%I = %I | %%j = %j | %%J = %J | %%k = %k | %%l = %l | %%m = %m | %%M = %M | %%N = %N | %%p = %p | %%P = %P | %%Q = %Q | %%s = %s | %%S = %S | %%t = %t | %%u = %u | %%U = %U | %%V = %V | %%w = %w | %%W = %W | %%y = %y | %%Y = %Y | %%z = %z | %%Z = %Z | %%n = %n | %%EE = %EE | %%EC = %EC | %%Ey = %Ey | %%n = %n | %%Od = %Od | %%Oe = %Oe | %%OH = %OH | %%Ok = %Ok | %%OI = %OI | %%Ol = %Ol | %%Om = %Om | %%OM = %OM | %%OS = %OS | %%Ou = %Ou | %%Ow = %Ow | %%Oy = %Oy" -gmt 1 -locale en}
# Format : all (in CET, locale de)
{clock format 1482525936 -format "%%a = %a | %%A = %A | %%b = %b | %%h = %h | %%B = %B | %%C = %C | %%d = %d | %%e = %e | %%g = %g | %%G = %G | %%H = %H | %%I = %I | %%j = %j | %%J = %J | %%k = %k | %%l = %l | %%m = %m | %%M = %M | %%N = %N | %%p = %p | %%P = %P | %%Q = %Q | %%s = %s | %%S = %S | %%t = %t | %%u = %u | %%U = %U | %%V = %V | %%w = %w | %%W = %W | %%y = %y | %%Y = %Y | %%z = %z | %%Z = %Z | %%n = %n | %%EE = %EE | %%EC = %EC | %%Ey = %Ey | %%n = %n | %%Od = %Od | %%Oe = %Oe | %%OH = %OH | %%Ok = %Ok | %%OI = %OI | %%Ol = %Ol | %%Om = %Om | %%OM = %OM | %%OS = %OS | %%Ou = %Ou | %%Ow = %Ow | %%Oy = %Oy" -timezone :CET -locale de}
}
}
proc test-scan {{reptime 1000}} {
| | | 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 |
{clock format 1482525936 -format "%%a = %a | %%A = %A | %%b = %b | %%h = %h | %%B = %B | %%C = %C | %%d = %d | %%e = %e | %%g = %g | %%G = %G | %%H = %H | %%I = %I | %%j = %j | %%J = %J | %%k = %k | %%l = %l | %%m = %m | %%M = %M | %%N = %N | %%p = %p | %%P = %P | %%Q = %Q | %%s = %s | %%S = %S | %%t = %t | %%u = %u | %%U = %U | %%V = %V | %%w = %w | %%W = %W | %%y = %y | %%Y = %Y | %%z = %z | %%Z = %Z | %%n = %n | %%EE = %EE | %%EC = %EC | %%Ey = %Ey | %%n = %n | %%Od = %Od | %%Oe = %Oe | %%OH = %OH | %%Ok = %Ok | %%OI = %OI | %%Ol = %Ol | %%Om = %Om | %%OM = %OM | %%OS = %OS | %%Ou = %Ou | %%Ow = %Ow | %%Oy = %Oy" -gmt 1 -locale en}
# Format : all (in CET, locale de)
{clock format 1482525936 -format "%%a = %a | %%A = %A | %%b = %b | %%h = %h | %%B = %B | %%C = %C | %%d = %d | %%e = %e | %%g = %g | %%G = %G | %%H = %H | %%I = %I | %%j = %j | %%J = %J | %%k = %k | %%l = %l | %%m = %m | %%M = %M | %%N = %N | %%p = %p | %%P = %P | %%Q = %Q | %%s = %s | %%S = %S | %%t = %t | %%u = %u | %%U = %U | %%V = %V | %%w = %w | %%W = %W | %%y = %y | %%Y = %Y | %%z = %z | %%Z = %Z | %%n = %n | %%EE = %EE | %%EC = %EC | %%Ey = %Ey | %%n = %n | %%Od = %Od | %%Oe = %Oe | %%OH = %OH | %%Ok = %Ok | %%OI = %OI | %%Ol = %Ol | %%Om = %Om | %%OM = %OM | %%OS = %OS | %%Ou = %Ou | %%Ow = %Ow | %%Oy = %Oy" -timezone :CET -locale de}
}
}
proc test-scan {{reptime 1000}} {
_test_run -convert-result {clock format $_(r) -locale en} $reptime {
# Scan : date (in gmt)
{clock scan "25.11.2015" -format "%d.%m.%Y" -base 0 -gmt 1}
# Scan : date (system time zone, with base)
{clock scan "25.11.2015" -format "%d.%m.%Y" -base 0}
# Scan : date (system time zone, without base)
{clock scan "25.11.2015" -format "%d.%m.%Y"}
# Scan : greedy match
|
| ︙ | ︙ | |||
194 195 196 197 198 199 200 |
break
# # Scan : long format test (allock chain)
# {clock scan "25.11.2015" -format "%d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y" -base 0 -gmt 1}
# # Scan : dynamic, very long format test (create obj representation, allock chain, GC, etc):
# {clock scan "25.11.2015" -format [string repeat "[incr i] %d.%m.%Y %d.%m.%Y" 10] -base 0 -gmt 1}
# # Scan : again:
# {clock scan "25.11.2015" -format [string repeat "[incr i -1] %d.%m.%Y %d.%m.%Y" 10] -base 0 -gmt 1}
| < > | | 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 |
break
# # Scan : long format test (allock chain)
# {clock scan "25.11.2015" -format "%d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y %d.%m.%Y" -base 0 -gmt 1}
# # Scan : dynamic, very long format test (create obj representation, allock chain, GC, etc):
# {clock scan "25.11.2015" -format [string repeat "[incr i] %d.%m.%Y %d.%m.%Y" 10] -base 0 -gmt 1}
# # Scan : again:
# {clock scan "25.11.2015" -format [string repeat "[incr i -1] %d.%m.%Y %d.%m.%Y" 10] -base 0 -gmt 1}
}
}
proc test-freescan {{reptime 1000}} {
_test_run -convert-result {clock format $_(r) -locale en} $reptime {
# FreeScan : relative date
{clock scan "5 years 18 months 385 days" -base 0 -gmt 1}
# FreeScan : relative date with relative weekday
{clock scan "5 years 18 months 385 days Fri" -base 0 -gmt 1}
# FreeScan : relative date with ordinal month
{clock scan "5 years 18 months 385 days next 1 January" -base 0 -gmt 1}
# FreeScan : relative date with ordinal month and relative weekday
|
| ︙ | ︙ | |||
235 236 237 238 239 240 241 |
{clock scan "20:18:30 -0500" -base 148863600 -gmt 1}
# FreeScan : time only, zone in string (exchange zones between system / gmt)
{clock scan "19:18:30 GMT" -base 148863600}
# FreeScan : fast switch of zones in cycle - GMT, MST, CET (system) and EST
{clock scan "19:18:30 MST" -base 148863600 -gmt 1
clock scan "19:18:30 EST" -base 148863600
}
| < > | 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 |
{clock scan "20:18:30 -0500" -base 148863600 -gmt 1}
# FreeScan : time only, zone in string (exchange zones between system / gmt)
{clock scan "19:18:30 GMT" -base 148863600}
# FreeScan : fast switch of zones in cycle - GMT, MST, CET (system) and EST
{clock scan "19:18:30 MST" -base 148863600 -gmt 1
clock scan "19:18:30 EST" -base 148863600
}
}
}
proc test-add {{reptime 1000}} {
set tests {
# Add : years
{clock add 1246379415 5 years -gmt 1}
# Add : months
|
| ︙ | ︙ | |||
278 279 280 281 282 283 284 |
{clock add 1246379415 4 years 18 months 50 weeks 378 days 3 weekdays 5 hours 30 minutes 10 seconds -timezone :CET}
}
# if does not support add of weekdays:
if {[catch {clock add 0 3 weekdays -gmt 1}]} {
regsub -all {\mweekdays\M} $tests "days" tests
}
| | | 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 |
{clock add 1246379415 4 years 18 months 50 weeks 378 days 3 weekdays 5 hours 30 minutes 10 seconds -timezone :CET}
}
# if does not support add of weekdays:
if {[catch {clock add 0 3 weekdays -gmt 1}]} {
regsub -all {\mweekdays\M} $tests "days" tests
}
_test_run -convert-result {clock format $_(r) -locale en} $reptime $tests
}
proc test-convert {{reptime 1000}} {
_test_run $reptime {
# Convert locale (en -> de):
{clock format [clock scan "Tue May 30 2017" -format "%a %b %d %Y" -gmt 1 -locale en] -format "%a %b %d %Y" -gmt 1 -locale de}
# Convert locale (de -> en):
|
| ︙ | ︙ |
Changes to tests-perf/test-performance.tcl.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 |
set tcnt [llength $_(itm)]
if {!$tcnt} {
puts ""
return
}
| | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 |
set tcnt [llength $_(itm)]
if {!$tcnt} {
puts ""
return
}
set mintm 0x7FFFFFFF
set maxtm 0
set nettm 0
set wtm 0
set wcnt 0
set i 0
foreach tm $_(itm) {
if {[llength $tm] > 6} {
|
| ︙ | ︙ | |||
123 124 125 126 127 128 129 |
lappend reptime $maxcount
}
}
proc _test_run {args} {
upvar _ _
# parse args:
| | | > | | > > > | > > > > | | 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 |
lappend reptime $maxcount
}
}
proc _test_run {args} {
upvar _ _
# parse args:
array set _ {-no-result 0 -uplevel 0 -convert-result {}}
while {[llength $args] > 2} {
if {![info exists _([set o [lindex $args 0]])]} {
break
}
if {[string is boolean -strict $_($o)]} {
set _($o) [expr {! $_($o)}]
set args [lrange $args 1 end]
} else {
if {[llength $args] <= 2} {
return -code error "value expected for option $o"
}
set _($o) [lindex $args 1]
set args [lrange $args 2 end]
}
}
unset -nocomplain o
if {[llength $args] < 2 || [llength $args] > 3} {
return -code error "wrong # args: should be \"[lindex [info level [info level]] 0] ?-no-result? reptime lst ?outcmd?\""
}
set _(outcmd) {puts}
set args [lassign $args reptime lst]
if {[llength $args]} {
set _(outcmd) [lindex $args 0]
|
| ︙ | ︙ | |||
169 170 171 172 173 174 175 |
if {$_(-uplevel)} {
set _(c) [list uplevel 1 $_(c)]
}
set _(ittime) $_(reptime)
# if output result (and not once):
if {!$_(-no-result)} {
set _(r) [if 1 $_(c)]
| > | | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 |
if {$_(-uplevel)} {
set _(c) [list uplevel 1 $_(c)]
}
set _(ittime) $_(reptime)
# if output result (and not once):
if {!$_(-no-result)} {
set _(r) [if 1 $_(c)]
if {$_(-convert-result) ne ""} { set _(r) [if 1 $_(-convert-result)] }
{*}$_(outcmd) $_(r)
if {[llength $_(ittime)] > 1} { # decrement max-count
lset _(ittime) 1 [expr {[lindex $_(ittime) 1] - 1}]
}
}
{*}$_(outcmd) [set _(m) [timerate $_(c) {*}$_(ittime)]]
lappend _(itm) $_(m)
{*}$_(outcmd) ""
|
| ︙ | ︙ |
Changes to tests/all.tcl.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | # Copyright (c) 2000 by 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- | | > > > > | > | 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 |
# Copyright (c) 2000 by 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
namespace import ::tcltest::*
configure {*}$argv -testdir [file dirname [file dirname [file normalize [
info script]/...]]]
if {[singleProcess]} {
interp debug {} -frame 1
}
set ErrorOnFailures [info exists env(ERROR_ON_FAILURES)]
unset -nocomplain env(ERROR_ON_FAILURES)
if {[runAllTests] && $ErrorOnFailures} {exit 1}
# if calling direct only (avoid rewrite exit if inlined or interactive):
if { [info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]
&& !([info exists ::tcl_interactive] && $::tcl_interactive)
} {
proc exit args {}
}
|
Changes to tests/assemble.test.
| ︙ | ︙ | |||
527 528 529 530 531 532 533 534 535 536 537 538 539 540 |
push a; push 7; incrStk
}
}
x
}
-result 12
-cleanup {rename x {}}
}
test assemble-7.18 {lappendArrayStk} {
-body {
proc x {} {
set able(baker) charlie
assemble {
push able
| > > > > > > > > > > > > | 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 |
push a; push 7; incrStk
}
}
x
}
-result 12
-cleanup {rename x {}}
}
test assemble-7.17 {land/lor} {
-body {
proc x {a b} {
list \
[assemble {load a; load b; land}] \
[assemble {load a; load b; lor}]
}
list [x 0 0] [x 0 23] [x 35 0] [x 47 59]
}
-result {{0 0} {0 1} {0 1} {1 1}}
-cleanup {rename x {}}
}
test assemble-7.18 {lappendArrayStk} {
-body {
proc x {} {
set able(baker) charlie
assemble {
push able
|
| ︙ | ︙ | |||
765 766 767 768 769 770 771 |
test assemble-7.43 {uplus} {
-body {
assemble {
push NaN; uplus
}
}
-returnCodes error
| | | 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 |
test assemble-7.43 {uplus} {
-body {
assemble {
push NaN; uplus
}
}
-returnCodes error
-result {can't use non-numeric floating-point value as operand of "+"}
}
test assemble-7.43.1 {tryCvtToNumeric} {
-body {
assemble {
push NaN; tryCvtToNumeric
}
}
|
| ︙ | ︙ | |||
1520 1521 1522 1523 1524 1525 1526 |
}
-result 8
-cleanup {rename x {}}
}
# assemble-15 - listIndexImm
| | < | < | < < < | < | < | < < < | < | | > | < < | < | < < < | < | < | < | < | < | < | < | < | < | < | | | | | 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 |
}
-result 8
-cleanup {rename x {}}
}
# assemble-15 - listIndexImm
test assemble-15.1 {listIndexImm - wrong # args} -body {
assemble {listIndexImm}
} -returnCodes error -match glob -result {wrong # args*}
test assemble-15.2 {listIndexImm - wrong # args} -body {
assemble {listIndexImm too many}
} -returnCodes error -match glob -result {wrong # args*}
test assemble-15.3 {listIndexImm - bad substitution} -body {
list [catch {assemble {listIndexImm $foo}} result] $result $::errorCode
} -cleanup {
unset result
} -result {1 {assembly code may not contain substitutions} {TCL ASSEM NOSUBST}}
test assemble-15.4 {listIndexImm - invalid index} -body {
assemble {listIndexImm rubbish}
} -returnCodes error -match glob -result {bad index "rubbish"*}
test assemble-15.5 {listIndexImm} -body {
assemble {push {a b c}; listIndexImm 2}
} -result c
test assemble-15.6 {listIndexImm} -body {
assemble {push {a b c}; listIndexImm end-1}
} -result b
test assemble-15.7 {listIndexImm} -body {
assemble {push {a b c}; listIndexImm end}
} -result c
test assemble-15.8 {listIndexImm} -body {
assemble {push {a b c}; listIndexImm end+2}
} -result {}
test assemble-15.9 {listIndexImm} -body {
assemble {push {a b c}; listIndexImm -1-1}
} -result {}
# assemble-16 - invokeStk
test assemble-16.1 {invokeStk - wrong # args} {
-body {
assemble {invokeStk}
}
|
| ︙ | ︙ |
Changes to tests/async.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testasync [llength [info commands testasync]]
proc async1 {result code} {
global aresult acode
set aresult $result
set acode $code
return "new result"
}
| > | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
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(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
proc async1 {result code} {
global aresult acode
set aresult $result
set acode $code
return "new result"
}
|
| ︙ | ︙ | |||
198 199 200 201 202 203 204 |
} -result {test pattern} -cleanup {
# give other threads some time to go way so that valgrind doesn't pick up
# "still reachable" cases from early thread termination
after 100
testasync delete $hm
}
test async-4.3 {async interrupting loop-less bytecode sequence} -constraints {
| | | 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 |
} -result {test pattern} -cleanup {
# give other threads some time to go way so that valgrind doesn't pick up
# "still reachable" cases from early thread termination
after 100
testasync delete $hm
}
test async-4.3 {async interrupting loop-less bytecode sequence} -constraints {
testasync knownMsvcBug
} -setup {
set hm [testasync create async3]
} -body {
apply [list {handle} [concat {
global aresult
set aresult {Async event not delivered}
testasync marklater $handle
|
| ︙ | ︙ |
Changes to tests/basic.test.
| ︙ | ︙ | |||
960 961 962 963 964 965 966 |
test basic-48.24.$noComp {expansion: empty not canonical list, regression test, bug [cc1e91552c]} -constraints $constraints -setup {
unset -nocomplain a
} -body {
run {list [list {*}{ }] [list {*}[format %c 32]] [list {*}[set a { }]]}
} -result [lrepeat 3 {}] -cleanup {unset -nocomplain a}
| | | 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 |
test basic-48.24.$noComp {expansion: empty not canonical list, regression test, bug [cc1e91552c]} -constraints $constraints -setup {
unset -nocomplain a
} -body {
run {list [list {*}{ }] [list {*}[format %c 32]] [list {*}[set a { }]]}
} -result [lrepeat 3 {}] -cleanup {unset -nocomplain a}
test basic-48.25.$noComp {Bug cc191552c: expansion: empty non-canonical list} -constraints $constraints -setup {
unset -nocomplain ::CRLF
set ::CRLF "\r\n"
} -body {
# Force variant that turned up in Bug 2c154a40be as that's externally
# noticeable in an important downstream project.
run {scan [list {*}$::CRLF]x %c%c%c}
} -cleanup {
|
| ︙ | ︙ |
Changes to tests/binary.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}]
testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}]
# Big test for correct ordering of data in [expr]
proc testIEEE {} {
variable ieeeValues
binary scan [binary format dd -1.0 1.0] c* c
switch -exact -- $c {
{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
| > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}]
testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}]
testConstraint testbytestring [llength [info commands testbytestring]]
# Big test for correct ordering of data in [expr]
proc testIEEE {} {
variable ieeeValues
binary scan [binary format dd -1.0 1.0] c* c
switch -exact -- $c {
{0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} {
|
| ︙ | ︙ | |||
2506 2507 2508 2509 2510 2511 2512 |
} -result "\0\1\2\3\4\0\1\2\3\4"
test binary-71.6 {binary decode hex} -body {
binary decode hex "61 61"
} -result {aa}
test binary-71.7 {binary decode hex} -body {
binary decode hex "61\n\n\n61"
} -result {aa}
| | | | 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 |
} -result "\0\1\2\3\4\0\1\2\3\4"
test binary-71.6 {binary decode hex} -body {
binary decode hex "61 61"
} -result {aa}
test binary-71.7 {binary decode hex} -body {
binary decode hex "61\n\n\n61"
} -result {aa}
test binary-71.8 {binary decode hex} -match glob -body {
binary decode hex -strict "61 61"
} -returnCodes error -result {invalid hexadecimal digit " " * at position 2}
test binary-71.9 {binary decode hex} -body {
set r [binary decode hex "6"]
list [string length $r] $r
} -result {0 {}}
test binary-71.10 {binary decode hex} -body {
string length [binary decode hex " "]
} -result 0
|
| ︙ | ︙ | |||
2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 |
} -result {YWJjYW-*-JjYWJj}
test binary-72.27 {binary encode base64} -body {
binary encode base64 -maxlen 4 -wrapchar -*- abcabcabc
} -result {YWJj-*-YWJj-*-YWJj}
test binary-72.28 {binary encode base64} -body {
binary encode base64 -maxlen 6 -wrapchar 0123456789 abcabcabc
} -result {YWJjYW0123456789JjYWJj}
test binary-73.1 {binary decode base64} -body {
binary decode base64
} -returnCodes error -match glob -result "wrong # args: *"
test binary-73.2 {binary decode base64} -body {
binary decode base64 YWJj
} -result {abc}
test binary-73.3 {binary decode base64} -body {
binary decode base64 {}
} -result {}
test binary-73.4 {binary decode base64} -body {
binary decode base64 [string repeat YWJj 20]
} -result [string repeat abc 20]
| > > > | | | | | | | | 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 |
} -result {YWJjYW-*-JjYWJj}
test binary-72.27 {binary encode base64} -body {
binary encode base64 -maxlen 4 -wrapchar -*- abcabcabc
} -result {YWJj-*-YWJj-*-YWJj}
test binary-72.28 {binary encode base64} -body {
binary encode base64 -maxlen 6 -wrapchar 0123456789 abcabcabc
} -result {YWJjYW0123456789JjYWJj}
test binary-72.29 {binary encode base64} {
string length [binary encode base64 -maxlen 3 -wrapchar \xca abc]
} 5
test binary-73.1 {binary decode base64} -body {
binary decode base64
} -returnCodes error -match glob -result "wrong # args: *"
test binary-73.2 {binary decode base64} -body {
binary decode base64 YWJj
} -result {abc}
test binary-73.3 {binary decode base64} -body {
binary decode base64 {}
} -result {}
test binary-73.4 {binary decode base64} -body {
binary decode base64 [string repeat YWJj 20]
} -result [string repeat abc 20]
test binary-73.5 {binary decode base64} -body {
binary decode base64 AAECAwQAAQID
} -result "\0\1\2\3\4\0\1\2\3"
test binary-73.6 {binary decode base64} -body {
binary decode base64 AA==
} -result "\0"
test binary-73.7 {binary decode base64} -body {
binary decode base64 AAA=
} -result "\0\0"
test binary-73.8 {binary decode base64} -body {
binary decode base64 AAAA
} -result "\0\0\0"
test binary-73.9 {binary decode base64} -body {
binary decode base64 AAAAAA==
} -result "\0\0\0\0"
test binary-73.10 {binary decode base64} -body {
set s "[string repeat YWJj 10]\n[string repeat YWJj 10]"
binary decode base64 $s
} -result [string repeat abc 20]
test binary-73.11 {binary decode base64} -body {
set s "[string repeat YWJj 10]\n [string repeat YWJj 10]"
binary decode base64 $s
} -result [string repeat abc 20]
test binary-73.12 {binary decode base64} -body {
binary decode base64 -strict ":YWJj"
} -returnCodes error -match glob -result {invalid base64 character ":" * at position 0}
test binary-73.13 {binary decode base64} -body {
set s "[string repeat YWJj 10]:[string repeat YWJj 10]"
binary decode base64 -strict $s
} -returnCodes error -match glob -result {invalid base64 character ":" * at position 40}
test binary-73.14 {binary decode base64} -body {
set s "[string repeat YWJj 10]\n [string repeat YWJj 10]"
binary decode base64 -strict $s
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.20 {binary decode base64} -body {
set r [binary decode base64 Y]
list [string length $r] $r
|
| ︙ | ︙ | |||
2714 2715 2716 2717 2718 2719 2720 |
test binary-73.29 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WFk=\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.30 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WFla\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.31 {binary decode base64} -body {
| | | 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 |
test binary-73.29 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WFk=\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.30 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WFla\n]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.31 {binary decode base64} -body {
list [string length [set r [binary decode base64 -strict WA==WFla]]] $r
} -returnCodes error -match glob -result {invalid base64 character *}
test binary-73.32 {binary decode base64, bug [00d04c4f12]} -body {
list \
[string length [binary decode base64 =]] \
[string length [binary decode base64 " ="]] \
[string length [binary decode base64 " ="]] \
[string length [binary decode base64 "\r\n\t="]] \
|
| ︙ | ︙ | |||
2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 |
if {[set a [binary decode base64 [set x [binary encode base64 $c]]]] ne $c} {
lappend r "encode & decode is wrong on string `$c` (encoded: $x): `$a` != `$c`"
}
}
}
join $r \n
} -result {}
test binary-74.1 {binary encode uuencode} -body {
binary encode uuencode
} -returnCodes error -match glob -result "wrong # args: *"
test binary-74.2 {binary encode uuencode} -body {
binary encode uuencode abc
} -result {#86)C
| > > > | 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 |
if {[set a [binary decode base64 [set x [binary encode base64 $c]]]] ne $c} {
lappend r "encode & decode is wrong on string `$c` (encoded: $x): `$a` != `$c`"
}
}
}
join $r \n
} -result {}
test binary-73.37 {binary decode base64: Bug ffeb2097af} {
binary decode base64 [binary encode base64 -maxlen 3 -wrapchar : abc]
} abc
test binary-74.1 {binary encode uuencode} -body {
binary encode uuencode
} -returnCodes error -match glob -result "wrong # args: *"
test binary-74.2 {binary encode uuencode} -body {
binary encode uuencode abc
} -result {#86)C
|
| ︙ | ︙ | |||
2793 2794 2795 2796 2797 2798 2799 |
binary encode uuencode \0\0\0\0
} -result {$``````
}
test binary-74.10 {binary encode uuencode} -returnCodes error -body {
binary encode uuencode -foo 30 abcabcabc
} -result {bad option "-foo": must be -maxlen or -wrapchar}
test binary-74.11 {binary encode uuencode} -returnCodes error -body {
| | > > > > > > | | | 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 |
binary encode uuencode \0\0\0\0
} -result {$``````
}
test binary-74.10 {binary encode uuencode} -returnCodes error -body {
binary encode uuencode -foo 30 abcabcabc
} -result {bad option "-foo": must be -maxlen or -wrapchar}
test binary-74.11 {binary encode uuencode} -returnCodes error -body {
binary encode uuencode -maxlen 4 abcabcabc
} -result {line length out of range}
test binary-74.12 {binary encode uuencode} -body {
binary encode uuencode -maxlen 5 -wrapchar \t abcabcabc
} -result #86)C\t#86)C\t#86)C\t
test binary-74.13 {binary encode uuencode} -body {
binary encode uuencode -maxlen 85 -wrapchar \t abcabcabc
} -result )86)C86)C86)C\t
test binary-74.14 {binary encode uuencode} -returnCodes error -body {
binary encode uuencode -maxlen 86 abcabcabc
} -result {line length out of range}
test binary-75.1 {binary decode uuencode} -body {
binary decode uuencode
} -returnCodes error -match glob -result "wrong # args: *"
test binary-75.2 {binary decode uuencode} -body {
binary decode uuencode "#86)C\n"
} -result {abc}
|
| ︙ | ︙ | |||
2839 2840 2841 2842 2843 2844 2845 |
} -result [string repeat abc 20]
test binary-75.11 {binary decode uuencode} -body {
set s ">[string repeat 86)C 10]\n\t>\t[string repeat 86)C 10]\r"
binary decode uuencode $s
} -result [string repeat abc 20]
test binary-75.12 {binary decode uuencode} -body {
binary decode uuencode -strict "|86)C"
| | | | 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 |
} -result [string repeat abc 20]
test binary-75.11 {binary decode uuencode} -body {
set s ">[string repeat 86)C 10]\n\t>\t[string repeat 86)C 10]\r"
binary decode uuencode $s
} -result [string repeat abc 20]
test binary-75.12 {binary decode uuencode} -body {
binary decode uuencode -strict "|86)C"
} -returnCodes error -match glob -result {invalid uuencode character "|" * at position 0}
test binary-75.13 {binary decode uuencode} -body {
set s ">[string repeat 86)C 10]|[string repeat 86)C 10]"
binary decode uuencode -strict $s
} -returnCodes error -match glob -result {invalid uuencode character "|" * at position 41}
test binary-75.14 {binary decode uuencode} -body {
set s ">[string repeat 86)C 10]\na[string repeat 86)C 10]"
binary decode uuencode -strict $s
} -returnCodes error -match glob -result {invalid uuencode character *}
test binary-75.20 {binary decode uuencode} -body {
set r [binary decode uuencode " 8"]
list [string length $r] $r
|
| ︙ | ︙ | |||
2871 2872 2873 2874 2875 2876 2877 |
test binary-75.24 {binary decode uuencode} -body {
set s "#04)\# "
binary decode uuencode $s
} -result ABC
test binary-75.25 {binary decode uuencode} -body {
set s "#04)\#z"
binary decode uuencode $s
| | | 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 |
test binary-75.24 {binary decode uuencode} -body {
set s "#04)\# "
binary decode uuencode $s
} -result ABC
test binary-75.25 {binary decode uuencode} -body {
set s "#04)\#z"
binary decode uuencode $s
} -returnCodes error -match glob -result {invalid uuencode character "z" * at position 5}
test binary-75.26 {binary decode uuencode} -body {
string length [binary decode uuencode " "]
} -result 0
test binary-76.1 {binary string appending growth algorithm} unix {
# Create zero-length byte array first
set f [open /dev/null rb]
|
| ︙ | ︙ | |||
2908 2909 2910 2911 2912 2913 2914 |
apply {{a b} {
set one [binary format H* $a]
return $one[binary format H* $b]
}} ab cd
} [binary format H* abcd]
test binary-78.1 {unicode (out of BMP) to byte-array conversion, bug-[bd94500678]} -body {
| | > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
apply {{a b} {
set one [binary format H* $a]
return $one[binary format H* $b]
}} ab cd
} [binary format H* abcd]
test binary-78.1 {unicode (out of BMP) to byte-array conversion, bug-[bd94500678]} -body {
# just test for BO-segfault (high surrogate w/o advance source pointer for out of BMP char if TCL_UTF_MAX == 3):
binary encode hex \U0001f415
binary scan \U0001f415 a* v; set v
set str {}
} -result {}
testConstraint testsetbytearraylength \
[expr {"testsetbytearraylength" in [info commands]}]
test binary-79.1 {Tcl_SetByteArrayLength} testsetbytearraylength {
testsetbytearraylength [string cat A B C] 1
} A
test binary-79.2 {Tcl_SetByteArrayLength} testsetbytearraylength {
testsetbytearraylength [string cat \u0141 B C] 1
} A
test binary-80.1 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body {
testbytestring "\u4E4E"
} -result "expected byte sequence but character 0 was '\u4E4E' (U+004E4E)"
test binary-80.2 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body {
testbytestring [testbytestring "\x00\xA0\xA0\xA0\xE4\xB9\x8E"]
} -result "expected byte sequence but character 4 was '\u4E4E' (U+004E4E)"
test binary-80.3 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body {
testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xE4\xB9\x8E"]
} -result "expected byte sequence but character 4 was '\u4E4E' (U+004E4E)"
test binary-80.4 {TclGetBytesFromObj} -constraints testbytestring -returnCodes 1 -body {
testbytestring [testbytestring "\xC0\x80\xA0\xA0\xA0\xF0\x9F\x98\x81"]
} -result "expected byte sequence but character 4 was '\U01F601' (U+01F601)"
# ----------------------------------------------------------------------
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Added tests/case.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 |
# 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 (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by 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 {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
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} {
case b a {format 1} b {format 2} c {format 3} default {format 4}
} 2
test case-1.3 {simple pattern} {
case x in a {format 1} b {format 2} c {format 3} default {format 4}
} 4
test case-1.4 {simple pattern} {
case x a {format 1} b {format 2} c {format 3}
} {}
test case-1.5 {simple pattern matches many times} {
case b a {format 1} b {format 2} b {format 3} b {format 4}
} 2
test case-1.6 {fancier pattern} {
case cx a {format 1} *c {format 2} *x {format 3} default {format 4}
} 3
test case-1.7 {list of patterns} {
case abc in {a b c} {format 1} {def abc ghi} {format 2}
} 2
test case-2.1 {error in executed command} {
list [catch {case a in a {error "Just a test"} default {format 1}} msg] \
$msg $::errorInfo
} {1 {Just a test} {Just a test
while executing
"error "Just a test""
("a" arm line 1)
invoked from within
"case a in a {error "Just a test"} default {format 1}"}}
test case-2.2 {error: not enough args} {
list [catch {case} msg] $msg
} {1 {wrong # args: should be "case string ?in? ?pattern body ...? ?default body?"}}
test case-2.3 {error: pattern with no body} {
list [catch {case a b} msg] $msg
} {1 {extra case pattern with no body}}
test case-2.4 {error: pattern with no body} {
list [catch {case a in b {format 1} c} msg] $msg
} {1 {extra case pattern with no body}}
test case-2.5 {error in default command} {
list [catch {case foo in a {error case1} default {error case2} \
b {error case 3}} msg] $msg $::errorInfo
} {1 case2 {case2
while executing
"error case2"
("default" arm line 1)
invoked from within
"case foo in a {error case1} default {error case2} b {error case 3}"}}
test case-3.1 {single-argument form for pattern/command pairs} {
case b in {
a {format 1}
b {format 2}
default {format 6}
}
} {2}
test case-3.2 {single-argument form for pattern/command pairs} {
case b {
a {format 1}
b {format 2}
default {format 6}
}
} {2}
test case-3.3 {single-argument form for pattern/command pairs} {
list [catch {case z in {a 2 b}} msg] $msg
} {1 {extra case pattern with no body}}
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/chanio.test.
| ︙ | ︙ | |||
39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testchannel [llength [info commands testchannel]]
testConstraint openpipe 1
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
# 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.
| > | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testchannel [llength [info commands testchannel]]
testConstraint openpipe 1
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
# 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.
|
| ︙ | ︙ | |||
884 885 886 887 888 889 890 |
} -result {bbbbbbbbbbbbbbb 15 123456789abcdef 1 4 abcd 0 3 efg}
test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} -setup {
set x ""
} -constraints {stdio testchannel openpipe fileevent} -body {
# Tcl_ExternalToUtf()
set f [openpipe w+ $path(cat)]
chan configure $f -translation {auto lf} -buffering none
| | | 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 |
} -result {bbbbbbbbbbbbbbb 15 123456789abcdef 1 4 abcd 0 3 efg}
test chan-io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} -setup {
set x ""
} -constraints {stdio testchannel openpipe fileevent} -body {
# Tcl_ExternalToUtf()
set f [openpipe w+ $path(cat)]
chan configure $f -translation {auto lf} -buffering none
chan configure $f -encoding utf-16
chan puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
chan configure $f -buffersize 16
chan gets $f
chan configure $f -blocking 0
lappend x [chan gets $f line] $line [testchannel queuedcr $f]
chan configure $f -blocking 1
chan puts -nonewline $f "\nabcd\refg"
|
| ︙ | ︙ | |||
1125 1126 1127 1128 1129 1130 1131 |
# not (bufPtr->nextPtr == NULL)
set f [openpipe w+ $path(cat)]
chan configure $f -translation lf -encoding ascii -buffering none
chan puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz"
chan event $f read [namespace code {
lappend x [chan gets $f line] $line [testchannel inputbuffered $f]
}]
| | | 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 |
# not (bufPtr->nextPtr == NULL)
set f [openpipe w+ $path(cat)]
chan configure $f -translation lf -encoding ascii -buffering none
chan puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz"
chan event $f read [namespace code {
lappend x [chan gets $f line] $line [testchannel inputbuffered $f]
}]
chan configure $f -encoding utf-16 -buffersize 16 -blocking 0
vwait [namespace which -variable x]
chan configure $f -translation auto -encoding ascii -blocking 1
# here
vwait [namespace which -variable x]
return $x
} -cleanup {
chan close $f
|
| ︙ | ︙ | |||
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]
| | | 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 |
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 openpipe knownMsvcBug} -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
|
| ︙ | ︙ | |||
2020 2021 2022 2023 2024 2025 2026 |
lappend l [file size $path(test1)]
} -cleanup {
chan close $f
} -result {0 60 72}
test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan close} -setup {
file delete $path(test1)
set l ""
| | | 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 |
lappend l [file size $path(test1)]
} -cleanup {
chan close $f
} -result {0 60 72}
test chan-io-27.5 {FlushChannel, implicit flush when buffer fills and on chan close} -setup {
file delete $path(test1)
set l ""
} -constraints {unixOrWin} -body {
set f [open $path(test1) w]
chan configure $f -translation lf -buffersize 60 -eofchar {}
lappend l [file size $path(test1)]
for {set i 0} {$i < 12} {incr i} {
chan puts $f hello
}
lappend l [file size $path(test1)]
|
| ︙ | ︙ | |||
2719 2720 2721 2722 2723 2724 2725 |
}
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
# allow a little time for the background process to chan close.
| | | 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 |
}
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
# allow a little time for the background process to chan close.
# otherwise, the following test fails on the [file delete $path(output)]
# on Windows because a process still has the file open.
after 100 set v 1; vwait v
return $result
} -result ok
test chan-io-29.32 {Tcl_WriteChars, background flush to slow reader} -setup {
file delete $path(pipe)
file delete $path(output)
|
| ︙ | ︙ | |||
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
}
}
| | | 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 |
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 knownMsvcBug} -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} {
|
| ︙ | ︙ | |||
2812 2813 2814 2815 2816 2817 2818 |
set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]]
vwait [namespace which -variable x]
chan configure $cs -blocking off
writelots $cs $l
chan close $cs
chan close $ss
vwait [namespace which -variable x]
| | | 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 |
set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]]
vwait [namespace which -variable x]
chan configure $cs -blocking off
writelots $cs $l
chan close $cs
chan close $ss
vwait [namespace which -variable x]
set c
} -result 2000
test chan-io-29.35 {Tcl_Chan Close vs chan event vs multiple interpreters} -setup {
catch {interp delete x}
catch {interp delete y}
} -constraints {socket tempNotMac fileevent} -body {
# On Mac, this test screws up sockets such that subsequent tests using
# port 2828 either cause errors or panic().
|
| ︙ | ︙ | |||
7028 7029 7030 7031 7032 7033 7034 |
set token [after 1000 {
lappend ::RES {bgerror/FAIL timeout}
set ::forever has-been-reached
}]
vwait ::forever
catch {after cancel $token}
# Report
| | | 7029 7030 7031 7032 7033 7034 7035 7036 7037 7038 7039 7040 7041 7042 7043 |
set token [after 1000 {
lappend ::RES {bgerror/FAIL timeout}
set ::forever has-been-reached
}]
vwait ::forever
catch {after cancel $token}
# Report
set ::RES
} -cleanup {
chan close $f
chan close $g
catch {unset ::RES}
catch {unset ::forever}
rename ::bgerror {}
removeFile foo
|
| ︙ | ︙ | |||
7228 7229 7230 7231 7232 7233 7234 |
set ss [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
# We need to delay on some systems until the creation of the server socket
# completes.
set done 0
for {set i 0} {$i < 10} {incr i} {
if {![catch {
set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]]
| | | 7229 7230 7231 7232 7233 7234 7235 7236 7237 7238 7239 7240 7241 7242 7243 |
set ss [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
# We need to delay on some systems until the creation of the server socket
# completes.
set done 0
for {set i 0} {$i < 10} {incr i} {
if {![catch {
set cs [socket 127.0.0.1 [lindex [chan configure $ss -sockname] 2]]
}]} {
set done 1
break
}
after 100
}
if {$done == 0} {
chan close $ss
|
| ︙ | ︙ | |||
7300 7301 7302 7303 7304 7305 7306 |
chan flush $writer
}
producer
vwait [namespace which -variable done]
chan close $writer
chan close $s
after cancel $after
| | | 7301 7302 7303 7304 7305 7306 7307 7308 7309 7310 7311 7312 7313 7314 7315 |
chan flush $writer
}
producer
vwait [namespace which -variable done]
chan close $writer
chan close $s
after cancel $after
set counter
} -cleanup {
if {$accept ne {}} {chan close $accept}
} -result 1
set path(fooBar) [makeFile {} fooBar]
test chan-io-55.1 {ChannelEventScriptInvoker: deletion} -constraints {
|
| ︙ | ︙ | |||
7327 7328 7329 7330 7331 7332 7333 |
set handler [interp bgerror {}]
interp bgerror {} [namespace which myHandler]
} -body {
set f [open $path(fooBar) w]
chan event $f writable [namespace code [list eventScript $f]]
variable x not_done
vwait [namespace which -variable x]
| | | 7328 7329 7330 7331 7332 7333 7334 7335 7336 7337 7338 7339 7340 7341 7342 |
set handler [interp bgerror {}]
interp bgerror {} [namespace which myHandler]
} -body {
set f [open $path(fooBar) w]
chan event $f writable [namespace code [list eventScript $f]]
variable x not_done
vwait [namespace which -variable x]
set x
} -cleanup {
interp bgerror {} $handler
} -result {got_error}
test chan-io-56.1 {ChannelTimerProc} {testchannelevent} {
set f [open $path(fooBar) w]
chan puts $f "this is a test"
|
| ︙ | ︙ | |||
7372 7373 7374 7375 7376 7377 7378 |
chan puts $s "12\n34567890"
chan flush $s
variable result [chan gets $s2]
after 1000 [namespace code {lappend result timer}]
vwait [namespace which -variable result]
lappend result [chan gets $s2]
vwait [namespace which -variable result]
| | | 7373 7374 7375 7376 7377 7378 7379 7380 7381 7382 7383 7384 7385 7386 7387 |
chan puts $s "12\n34567890"
chan flush $s
variable result [chan gets $s2]
after 1000 [namespace code {lappend result timer}]
vwait [namespace which -variable result]
lappend result [chan gets $s2]
vwait [namespace which -variable result]
set result
} -cleanup {
chan close $s
chan close $s2
chan close $server
} -result {12 readable 34567890 timer}
test chan-io-57.2 {buffered data and file events, read} -setup {
variable s2
|
| ︙ | ︙ | |||
7397 7398 7399 7400 7401 7402 7403 |
chan puts -nonewline $s "1234567890"
chan flush $s
variable result [chan read $s2 1]
after 1000 [namespace code {lappend result timer}]
vwait [namespace which -variable result]
lappend result [chan read $s2 9]
vwait [namespace which -variable result]
| | | | 7398 7399 7400 7401 7402 7403 7404 7405 7406 7407 7408 7409 7410 7411 7412 7413 7414 7415 7416 7417 7418 7419 |
chan puts -nonewline $s "1234567890"
chan flush $s
variable result [chan read $s2 1]
after 1000 [namespace code {lappend result timer}]
vwait [namespace which -variable result]
lappend result [chan read $s2 9]
vwait [namespace which -variable result]
set result
} -cleanup {
chan close $s
chan close $s2
chan close $server
} -result {1 readable 234567890 timer}
test chan-io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin openpipe fileevent} {
set out [open $path(script) w]
chan puts $out {
chan puts "normal message from pipe"
chan puts stderr "error message from pipe"
exit 1
}
proc readit {pipe} {
|
| ︙ | ︙ |
Changes to tests/clock.test.
| ︙ | ︙ | |||
246 247 248 249 250 251 252 |
}
if { ![dict exists $reg $path $key] } {
return -code error "test case attempts to read unknown registry entry $path $key"
}
return [dict get $reg $path $key]
}
| < < < < < < < < < < < | 246 247 248 249 250 251 252 253 254 255 256 257 258 259 |
}
if { ![dict exists $reg $path $key] } {
return -code error "test case attempts to read unknown registry entry $path $key"
}
return [dict get $reg $path $key]
}
# Test some of the basics of [clock format]
test clock-1.0 "clock format - wrong # args" {
list [catch {clock format} msg] $msg $::errorCode
} {1 {wrong # args: should be "clock format clockval ?-format string? ?-gmt boolean? ?-locale LOCALE? ?-timezone ZONE?"} {CLOCK wrongNumArgs}}
|
| ︙ | ︙ | |||
35032 35033 35034 35035 35036 35037 35038 35039 35040 35041 35042 35043 35044 35045 |
set f4 [clock add $t -4 month -timezone :UTC]
set x1 [clock format $f1 -format %Y-%m-%d -timezone :UTC]
set x2 [clock format $f2 -format %Y-%m-%d -timezone :UTC]
set x3 [clock format $f3 -format %Y-%m-%d -timezone :UTC]
set x4 [clock format $f4 -format %Y-%m-%d -timezone :UTC]
list $x1 $x2 $x3 $x4
} {2000-02-29 2000-01-31 1999-12-31 1999-11-30}
test clock-30.9 {clock add days} {
set t [clock scan {2000-01-01 12:34:56} -format {%Y-%m-%d %H:%M:%S} \
-timezone :UTC]
set f1 [clock add $t 1 day -timezone :UTC]
set f2 [clock add $t -1 day -timezone :UTC]
set x1 [clock format $f1 -format {%Y-%m-%d %H:%M:%S} -timezone :UTC]
set x2 [clock format $f2 -format {%Y-%m-%d %H:%M:%S} -timezone :UTC]
| > > > > > > > > > > > > > > > > > > | 35021 35022 35023 35024 35025 35026 35027 35028 35029 35030 35031 35032 35033 35034 35035 35036 35037 35038 35039 35040 35041 35042 35043 35044 35045 35046 35047 35048 35049 35050 35051 35052 |
set f4 [clock add $t -4 month -timezone :UTC]
set x1 [clock format $f1 -format %Y-%m-%d -timezone :UTC]
set x2 [clock format $f2 -format %Y-%m-%d -timezone :UTC]
set x3 [clock format $f3 -format %Y-%m-%d -timezone :UTC]
set x4 [clock format $f4 -format %Y-%m-%d -timezone :UTC]
list $x1 $x2 $x3 $x4
} {2000-02-29 2000-01-31 1999-12-31 1999-11-30}
test clock-30.8a {clock add months, negative, over threshold of a year} {
set t [clock scan 2019-01-31 -format %Y-%m-%d -gmt 1]
list [clock format [clock add $t -1 month -gmt 1] -format %Y-%m-%d -gmt 1] \
[clock format [clock add $t -2 month -gmt 1] -format %Y-%m-%d -gmt 1] \
[clock format [clock add $t -3 month -gmt 1] -format %Y-%m-%d -gmt 1] \
[clock format [clock add $t -4 month -gmt 1] -format %Y-%m-%d -gmt 1]
} {2018-12-31 2018-11-30 2018-10-31 2018-09-30}
test clock-30.8b {clock add months, negative, over threshold of a year} {
set t [clock scan 2000-01-28 -format %Y-%m-%d -gmt 1]
for {set i 1} {$i < 24} {incr i 1} {
set f1 [clock add $t -$i month -gmt 1]
set f2 [clock add $f1 $i month -gmt 1]
if {$f2 != $t} {
error "\[clock add $t -$i month -gmt 1\] does not consider\
\[clock add $f1 $i month -gmt 1\] != $t"
}
}
} {}
test clock-30.9 {clock add days} {
set t [clock scan {2000-01-01 12:34:56} -format {%Y-%m-%d %H:%M:%S} \
-timezone :UTC]
set f1 [clock add $t 1 day -timezone :UTC]
set f2 [clock add $t -1 day -timezone :UTC]
set x1 [clock format $f1 -format {%Y-%m-%d %H:%M:%S} -timezone :UTC]
set x2 [clock format $f2 -format {%Y-%m-%d %H:%M:%S} -timezone :UTC]
|
| ︙ | ︙ | |||
35447 35448 35449 35450 35451 35452 35453 |
concat {}
} {}
test clock-33.4a {clock milliseconds} {
expr { [clock milliseconds] + 1 }
concat {}
} {}
test clock-33.5 {clock clicks tests, millisecond timing test} {
| | > | | > | < | > > > | > > > < > > | | > | < | > > > | > > > | > | | > | < | > > | | < > > | | > | < | > > | | | 35454 35455 35456 35457 35458 35459 35460 35461 35462 35463 35464 35465 35466 35467 35468 35469 35470 35471 35472 35473 35474 35475 35476 35477 35478 35479 35480 35481 35482 35483 35484 35485 35486 35487 35488 35489 35490 35491 35492 35493 35494 35495 35496 35497 35498 35499 35500 35501 35502 35503 35504 35505 35506 35507 35508 35509 35510 35511 35512 35513 35514 35515 35516 35517 35518 35519 35520 35521 35522 35523 35524 35525 35526 35527 35528 35529 |
concat {}
} {}
test clock-33.4a {clock milliseconds} {
expr { [clock milliseconds] + 1 }
concat {}
} {}
test clock-33.5 {clock clicks tests, millisecond timing test} {
# This test can fail on a system that is so heavily loaded that
# the test takes >60 ms to run.
if {[lindex [timerate {
set start [clock clicks -milli]
timerate {} 10; # short but precise busy wait
set end [clock clicks -milli]
} 1 1] 0] > 60000} {
::tcltest::Skip "timing issue"
}
# 60 msecs seems to be the max time slice under Windows 95/98
expr {
($end > $start) && (($end - $start) <= 60) ?
"ok" :
"test should have taken 0-60 ms, actually took [expr $end - $start]"}
} {ok}
test clock-33.5a {clock tests, millisecond timing test} {
# This test can fail on a system that is so heavily loaded that
# the test takes >60 ms to run.
if {[lindex [timerate {
set start [clock milliseconds]
timerate {} 10; # short but precise busy wait
set end [clock milliseconds]
} 1 1] 0] > 60000} {
::tcltest::Skip "timing issue"
}
# 60 msecs seems to be the max time slice under Windows 95/98
expr {
($end > $start) && (($end - $start) <= 60) ?
"ok" :
"test should have taken 0-60 ms, actually took [expr $end - $start]"}
} {ok}
test clock-33.6 {clock clicks, milli with too much abbreviation} {
list [catch { clock clicks ? } msg] $msg
} {1 {bad option "?": must be -milliseconds or -microseconds}}
test clock-33.7 {clock clicks, milli with too much abbreviation} {
list [catch { clock clicks - } msg] $msg
} {1 {ambiguous option "-": must be -milliseconds or -microseconds}}
test clock-33.8 {clock clicks test, microsecond timing test} {
# This test can fail on a system that is so heavily loaded that
# the test takes >60 ms to run.
if {[lindex [timerate {
set start [clock clicks -micro]
timerate {} 10; # short but precise busy wait
set end [clock clicks -micro]
} 1 1] 0] > 60000} {
::tcltest::Skip "timing issue"
}
expr {($end > $start) && (($end - $start) <= 60000)}
} {1}
test clock-33.8a {clock test, microsecond timing test} {
# This test can fail on a system that is so heavily loaded that
# the test takes >60 ms to run.
if {[lindex [timerate {
set start [clock microseconds]
timerate {} 10; # short but precise busy wait
set end [clock microseconds]
} 1 1] 0] > 60000} {
::tcltest::Skip "timing issue"
}
expr {($end > $start) && (($end - $start) <= 60000)}
} {1}
test clock-33.9 {clock clicks test, millis align with seconds} {
set t1 [clock seconds]
while { 1 } {
set t2 [clock clicks -millis]
set t3 [clock seconds]
if { $t3 == $t1 } break
|
| ︙ | ︙ |
Changes to tests/cmdAH.test.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
::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 linkDirectory [expr {
![testConstraint win] ||
($::tcl_platform(osVersion) >= 5.0
&& [lindex [file system [temporaryDirectory]] 1] eq "NTFS")
}]
global env
| > > > > | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
::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")
}]
global env
|
| ︙ | ︙ | |||
54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
test cmdAH-0.1 {Tcl_BreakObjCmd, errors} -body {
break foo
} -returnCodes error -result {wrong # args: should be "break"}
test cmdAH-0.2 {Tcl_BreakObjCmd, success} {
list [catch {break} msg] $msg
} {3 {}}
test cmdAH-1.1 {Tcl_CatchObjCmd, errors} -returnCodes error -body {
catch
} -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}
test cmdAH-1.2 {Tcl_CatchObjCmd, errors} {
list [catch {catch foo bar baz} msg] $msg
} {0 1}
| > > | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 |
test cmdAH-0.1 {Tcl_BreakObjCmd, errors} -body {
break foo
} -returnCodes error -result {wrong # args: should be "break"}
test cmdAH-0.2 {Tcl_BreakObjCmd, success} {
list [catch {break} msg] $msg
} {3 {}}
# Tcl_CaseObjCmd is tested in case.test
test cmdAH-1.1 {Tcl_CatchObjCmd, errors} -returnCodes error -body {
catch
} -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}
test cmdAH-1.2 {Tcl_CatchObjCmd, errors} {
list [catch {catch foo bar baz} msg] $msg
} {0 1}
|
| ︙ | ︙ | |||
882 883 884 885 886 887 888 |
test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unix testchmod} {
# Only on unix will setting the execute bit on a regular file cause that
# file to be executable.
testchmod 0o775 $gorpfile
file exe $gorpfile
} 1
test cmdAH-18.5 {Tcl_FileObjCmd: executable} -constraints {win} -body {
| | | 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 |
test cmdAH-18.3 {Tcl_FileObjCmd: executable} {unix testchmod} {
# Only on unix will setting the execute bit on a regular file cause that
# file to be executable.
testchmod 0o775 $gorpfile
file exe $gorpfile
} 1
test cmdAH-18.5 {Tcl_FileObjCmd: executable} -constraints {win} -body {
# On windows, must be a .exe, .com, etc.
set x {}
set gorpexes {}
foreach ext {exe com cmd bat} {
lappend x [file exe nosuchfile.$ext]
set gorpexe [makeFile foo gorp.$ext]
lappend gorpexes $gorpexe
lappend x [file exe $gorpexe] [file exe [string toupper $gorpexe]]
|
| ︙ | ︙ | |||
1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 |
} -result "could not get modification time for file \"con\"" -returnCodes error
test cmdAH-24.14.1 {
Tcl_FileObjCmd: mtime (built-in Windows names with dir path and extension)
} -constraints {win} -body {
file mtime [file join [temporaryDirectory] CON.txt]
} -match regexp -result {could not (?:get modification time|read)} -returnCodes error
# owned
test cmdAH-25.1 {Tcl_FileObjCmd: owned} -returnCodes error -body {
file owned a b
} -result {wrong # args: should be "file owned name"}
| > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > | > > > > > > > | > | 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 |
} -result "could not get modification time for file \"con\"" -returnCodes error
test cmdAH-24.14.1 {
Tcl_FileObjCmd: mtime (built-in Windows names with dir path and extension)
} -constraints {win} -body {
file mtime [file join [temporaryDirectory] CON.txt]
} -match regexp -result {could not (?:get modification time|read)} -returnCodes error
# 3155760000 is 64-bit unix time, Wed Jan 01 00:00:00 GMT 2070:
test cmdAH-24.20.1 {Tcl_FileObjCmd: atime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit} -setup {
set filename [makeFile "" foo.text]
} -body {
list [file atime $filename 3155760000] [file atime $filename]
} -cleanup {
removeFile $filename
} -result {3155760000 3155760000}
test cmdAH-24.20.2 {Tcl_FileObjCmd: mtime 64-bit time_t, bug [4718b41c56]} -constraints {time64bit} -setup {
set filename [makeFile "" foo.text]
} -body {
list [file mtime $filename 3155760000] [file mtime $filename]
} -cleanup {
file delete -force $filename
} -result {3155760000 3155760000}
# owned
test cmdAH-25.1 {Tcl_FileObjCmd: owned} -returnCodes error -body {
file owned a b
} -result {wrong # args: should be "file owned name"}
test cmdAH-25.2 {Tcl_FileObjCmd: owned} -constraints win -setup {
set fn $gorpfile
# prefer temp file to check owner (try to avoid bug [7de2d722bd]):
if {
[info exists ::env(TEMP)] && [file isdirectory $::env(TEMP)] &&
[file dirname $fn] ne [file normalize $::env(TEMP)]
} {
set fn [file join $::env(TEMP)/test-owner-from-tcl.txt]
set fn [makeFile "data" test-owner-from-tcl.txt $::env(TEMP)]
}
# be sure we have really owned this file before trying to check that
# (avoid dependency on admin with UAC and the setting "System objects:
# Default owner for objects created by members of the Administrators group"):
catch {
exec takeown /F [file nativename $fn]
}
} -body {
file owned $fn
} -cleanup {
if {$fn ne $gorpfile} {
removeFile $fn
}
} -result 1
test cmdAH-25.2.1 {Tcl_FileObjCmd: owned} -constraints unix -setup {
# Avoid problems with AFS
set tmpfile [makeFile "data" touch.me /tmp]
} -body {
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 -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 {
file owned nosuchfile
} -result 0
# readlink
test cmdAH-26.1 {Tcl_FileObjCmd: readlink} -returnCodes error -body {
|
| ︙ | ︙ |
Changes to tests/cmdIL.test.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
testConstraint testobj [llength [info commands testobj]]
test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
lsort
} -result {wrong # args: should be "lsort ?-option value ...? list"}
test cmdIL-1.2 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
lsort -foo {1 3 2 5}
} -result {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -nocase, -real, -stride, or -unique}
| > > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
::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]]
source [file join [file dirname [info script]] internals.tcl]
namespace import -force ::tcltest::internals::*
test cmdIL-1.1 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
lsort
} -result {wrong # args: should be "lsort ?-option value ...? list"}
test cmdIL-1.2 {Tcl_LsortObjCmd procedure} -returnCodes error -body {
lsort -foo {1 3 2 5}
} -result {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -nocase, -real, -stride, or -unique}
|
| ︙ | ︙ | |||
157 158 159 160 161 162 163 |
lsort -ascii [list \0 \x7f \x80 \U01ffff \uffff]
} [list \0 \x7f \x80 \uffff \U01ffff]
test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
lsort -ascii -nocase [list \0 \x7f \x80 \U01ffff \uffff]
} [list \0 \x7f \x80 \uffff \U01ffff]
test cmdIL-1.41 {lsort -stride and -index} -body {
lsort -stride 2 -index -2 {a 2 b 1}
| | | | 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 |
lsort -ascii [list \0 \x7f \x80 \U01ffff \uffff]
} [list \0 \x7f \x80 \uffff \U01ffff]
test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} {
lsort -ascii -nocase [list \0 \x7f \x80 \U01ffff \uffff]
} [list \0 \x7f \x80 \uffff \U01ffff]
test cmdIL-1.41 {lsort -stride and -index} -body {
lsort -stride 2 -index -2 {a 2 b 1}
} -returnCodes error -result {index "-2" out of range}
test cmdIL-1.42 {lsort -stride and-index} -body {
lsort -stride 2 -index -1-1 {a 2 b 1}
} -returnCodes error -result {index "-1-1" out of range}
# Can't think of any good tests for the MergeSort and MergeLists procedures,
# except a bunch of random lists to sort.
test cmdIL-2.1 {MergeSort and MergeLists procedures} -setup {
set result {}
set r 1435753299
|
| ︙ | ︙ | |||
222 223 224 225 226 227 228 |
lsort -integer -index 2 {{20 10 13} {15}}
} -returnCodes error -result {element 2 missing from sublist "15"}
test cmdIL-3.5.1 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index 1+3 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {element 4 missing from sublist "1 . c"}
test cmdIL-3.5.2 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index -1-1 {{1 . c} {2 . b} {3 . a}}
| | | | | | | 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 |
lsort -integer -index 2 {{20 10 13} {15}}
} -returnCodes error -result {element 2 missing from sublist "15"}
test cmdIL-3.5.1 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index 1+3 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {element 4 missing from sublist "1 . c"}
test cmdIL-3.5.2 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index -1-1 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {index "-1-1" out of range}
test cmdIL-3.5.3 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index -2 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {index "-2" out of range}
test cmdIL-3.5.4 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index end-4 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {element end-4 missing from sublist "1 . c"}
test cmdIL-3.5.5 {SortCompare procedure, -index option} {
lsort -index {} {a b}
} {a b}
test cmdIL-3.5.6 {SortCompare procedure, -index option} {
lsort -index {} [list a \{]
} {a \{}
test cmdIL-3.5.7 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index end--1 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {index "end--1" out of range}
test cmdIL-3.5.8 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index end+1 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {index "end+1" out of range}
test cmdIL-3.5.9 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index end+2 {{1 . c} {2 . b} {3 . a}}
} -returnCodes error -result {index "end+2" out of range}
test cmdIL-3.5.10 {SortCompare procedure, -index option (out of range, calculated index)} -body {
lsort -index 0 {{}}
} -returnCodes error -result {element 0 missing from sublist ""}
test cmdIL-3.6 {SortCompare procedure, -index option} {
lsort -integer -index 2 {{1 15 30} {2 5 25} {3 25 20}}
} {{3 25 20} {2 5 25} {1 15 30}}
test cmdIL-3.7 {SortCompare procedure, -ascii option} {
|
| ︙ | ︙ | |||
515 516 517 518 519 520 521 522 523 524 525 526 527 528 |
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}}
# Compiled version
test cmdIL-6.1 {lassign command syntax} -returnCodes error -body {
apply {{} { lassign }}
} -result {wrong # args: should be "lassign list ?varName ...?"}
test cmdIL-6.2 {lassign command syntax} {
apply {{} { lassign x }}
| > > > > > > > > > > > > > > > | 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 |
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}}
test cmdIL-5.7 {lsort memory exhaustion} -constraints {testWithLimit} -body {
# test it in child process (with limited address space) ca. 80MB extra memory
# on x64 system it would be not enough to sort 4M items (the half 2M only),
# warn and skip if no error (enough memory) or error by list creation:
testWithLimit \
-warn-on-code 0 -warn-on-alloc-error 1 \
-addmem [expr {$tcl_platform(pointerSize)*4000000 + $tcl_platform(pointerSize)*3*2000000}] \
{
# create list and get length (avoid too long output in interactive shells):
llength [set l [lrepeat 4000000 ""]]
# test OOM:
llength [lsort $l]
}
# expecting error no memory by sort
} -returnCodes 1 -result {no enough memory to proccess sort of 4000000 items}
# Compiled version
test cmdIL-6.1 {lassign command syntax} -returnCodes error -body {
apply {{} { lassign }}
} -result {wrong # args: should be "lassign list ?varName ...?"}
test cmdIL-6.2 {lassign command syntax} {
apply {{} { lassign x }}
|
| ︙ | ︙ |
Changes to tests/cmdMZ.test.
| ︙ | ︙ | |||
18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
namespace eval ::tcl::test::cmdMZ {
namespace import ::tcltest::cleanupTests
namespace import ::tcltest::customMatch
namespace import ::tcltest::makeFile
namespace import ::tcltest::removeFile
namespace import ::tcltest::temporaryDirectory
namespace import ::tcltest::test
proc ListGlobMatch {expected actual} {
if {[llength $expected] != [llength $actual]} {
return 0
}
foreach e $expected a $actual {
| > | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
namespace eval ::tcl::test::cmdMZ {
namespace import ::tcltest::cleanupTests
namespace import ::tcltest::customMatch
namespace import ::tcltest::makeFile
namespace import ::tcltest::removeFile
namespace import ::tcltest::temporaryDirectory
namespace import ::tcltest::testConstraint
namespace import ::tcltest::test
proc ListGlobMatch {expected actual} {
if {[llength $expected] != [llength $actual]} {
return 0
}
foreach e $expected a $actual {
|
| ︙ | ︙ | |||
223 224 225 226 227 228 229 |
# The tests for Tcl_ScanObjCmd are in scan.test
# Tcl_SourceObjCmd
# More tests of Tcl_SourceObjCmd are in source.test
test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints {
| | | | 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 |
# The tests for Tcl_ScanObjCmd are in scan.test
# Tcl_SourceObjCmd
# More tests of Tcl_SourceObjCmd are in source.test
test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} -constraints {
unixOrWin
} -returnCodes error -body {
source
} -match glob -result {wrong # args: should be "source*fileName"}
test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints {
unixOrWin
} -returnCodes error -body {
source a b c d e f
} -match glob -result {wrong # args: should be "source*fileName"}
test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body {
set file [makeFile {
set x 146
error "error in sourced file"
|
| ︙ | ︙ | |||
317 318 319 320 321 322 323 |
# The tests for Tcl_SwitchObjCmd are in switch.test
# todo: rewrite this if monotonic clock is provided resp. command "after"
# gets microsecond accuracy (RFE [fdfbd5e10] gets merged):
proc _nrt_sleep {msec} {
set usec [expr {$msec * 1000}]
set stime [clock microseconds]
| | > > | > > | > | | > > > > > > > > > > > > > > > > > > > > > | 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 |
# The tests for Tcl_SwitchObjCmd are in switch.test
# todo: rewrite this if monotonic clock is provided resp. command "after"
# gets microsecond accuracy (RFE [fdfbd5e10] gets merged):
proc _nrt_sleep {msec} {
set usec [expr {$msec * 1000}]
set stime [clock microseconds]
while {abs([clock microseconds] - $stime) < $usec} {
# don't use after 0 unless it's NRT-capable, so yes - busy-wait (but it's more precise):
# after 0
}
}
_nrt_sleep 0; # warm up (clock, compile, etc)
test cmdMZ-5.1 {Tcl_TimeObjCmd: basic format of command} -body {
time
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
test cmdMZ-5.2 {Tcl_TimeObjCmd: basic format of command} -body {
time a b c
} -returnCodes error -result {wrong # args: should be "time command ?count?"}
test cmdMZ-5.3 {Tcl_TimeObjCmd: basic format of command} -body {
time a b
} -returnCodes error -result {expected integer but got "b"}
test cmdMZ-5.4 {Tcl_TimeObjCmd: nothing happens with negative iteration counts} {
time bogusCmd -12456
} {0 microseconds per iteration}
test cmdMZ-5.5 {Tcl_TimeObjCmd: result format} -body {
time {format 1}
} -match regexp -result {^\d+ microseconds per iteration}
test cmdMZ-5.6 {Tcl_TimeObjCmd: slower commands take longer} -body {
set m1 [lindex [time {_nrt_sleep 0.01}] 0]
set m2 [lindex [time {_nrt_sleep 10.0}] 0]
list \
[expr {$m1 < $m2}] \
$m1 $m2; # interesting only in error case.
} -match glob -result [list 1 *]
test cmdMZ-5.7 {Tcl_TimeObjCmd: errors generate right trace} {
list [catch {time {error foo}} msg] $msg $::errorInfo
} {1 foo {foo
while executing
"error foo"
invoked from within
"time {error foo}"}}
test cmdMZ-5.7.1 {Tcl_TimeObjCmd: return from time} {
set x 0
proc r1 {} {upvar x x; time {incr x; return "r1"; incr x} 10}
list [r1] $x
} {r1 1}
test cmdMZ-5.8 {Tcl_TimeObjCmd: done optimization: nested call of self inside time (if compiled)} {
set x [set y 0]
set m1 {
if {[incr x] <= 5} {
# nested call should return result, so covering that:
if {![string is integer -strict [eval $m1]]} {error unexpected}
}
# increase again (no "continue" from nested call):
incr x
}
time {incr y; eval $m1} 5
list $y $x
} {5 20}
test cmdMZ-6.1 {Tcl_TimeRateObjCmd: basic format of command} {
list [catch {timerate} msg] $msg
} {1 {wrong # args: should be "timerate ?-direct? ?-calibrate? ?-overhead double? command ?time ?max-count??"}}
test cmdMZ-6.2.1 {Tcl_TimeRateObjCmd: basic format of command} {
list [catch {timerate a b c d} msg] $msg
} {1 {wrong # args: should be "timerate ?-direct? ?-calibrate? ?-overhead double? command ?time ?max-count??"}}
|
| ︙ | ︙ | |||
370 371 372 373 374 375 376 |
} {1 {missing close-brace}}
test cmdMZ-6.5a {Tcl_TimeRateObjCmd: result format and one iteration} {
regexp {^\d+(?:\.\d+)? \ws/# 1 # \d+(?:\.\d+)? #/sec \d+(?:\.\d+)? net-ms$} [timerate {} 0]
} 1
test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} {
regexp {^0 \ws/# 0 # 0 #/sec 0 net-ms$} [timerate {} 0 0]
} 1
| | | | | | | | | | | > | > > > > > | | | > | | | | | | | > | | | | > | > > > > > > > > > > > > | 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 |
} {1 {missing close-brace}}
test cmdMZ-6.5a {Tcl_TimeRateObjCmd: result format and one iteration} {
regexp {^\d+(?:\.\d+)? \ws/# 1 # \d+(?:\.\d+)? #/sec \d+(?:\.\d+)? net-ms$} [timerate {} 0]
} 1
test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} {
regexp {^0 \ws/# 0 # 0 #/sec 0 net-ms$} [timerate {} 0 0]
} 1
test cmdMZ-6.6 {Tcl_TimeRateObjCmd: slower commands take longer, but it remains almost the same time of measument} -body {
set m1 [timerate {_nrt_sleep 0.01} 50]
set m2 [timerate {_nrt_sleep 1.00} 50]
list [list \
[expr {[lindex $m1 0] < [lindex $m2 0]}] \
[expr {[lindex $m1 0] < 100}] \
[expr {[lindex $m2 0] > 100}] \
[expr {[lindex $m1 2] > 500}] \
[expr {[lindex $m2 2] < 500}] \
[expr {[lindex $m1 4] > 10000}] \
[expr {[lindex $m2 4] < 10000}] \
[expr {[lindex $m1 6] > 5 && [lindex $m1 6] < 100}] \
[expr {[lindex $m2 6] > 5 && [lindex $m2 6] < 100}] \
] $m1 $m2; # interesting only in error case.
} -match glob -result [list [lrepeat 9 1] *]
test cmdMZ-6.7 {Tcl_TimeRateObjCmd: errors generate right trace} {
list [catch {timerate {error foo} 1} msg] $msg $::errorInfo
} {1 foo {foo
while executing
"error foo"
invoked from within
"timerate {error foo} 1"}}
test cmdMZ-6.7.1 {Tcl_TimeRateObjCmd: return from timerate} {
set x 0
proc r1 {} {upvar x x; timerate {incr x; return "r1"; incr x} 1000 10}
list [r1] $x
} {r1 1}
test cmdMZ-6.8 {Tcl_TimeRateObjCmd: allow (conditional) break from timerate} -body {
set m1 [timerate {break}]
list [list \
[expr {[lindex $m1 0] < 1000}] \
[expr {[lindex $m1 2] == 1}] \
[expr {[lindex $m1 4] > 1000}] \
[expr {[lindex $m1 6] < 10}] \
] $m1; # interesting only in error case.
} -match glob -result [list {1 1 1 1} *]
test cmdMZ-6.8.1 {Tcl_TimeRateObjCmd: allow (conditional) continue in timerate} -body {
set m1 [timerate {continue; return -code error "unexpected"} 1000 10]
list [list \
[expr {[lindex $m1 0] < 1000}] \
[expr {[lindex $m1 2] == 10}] \
[expr {[lindex $m1 4] > 1000}] \
[expr {[lindex $m1 6] < 100}] \
] $m1; # interesting only in error case.
} -match glob -result [list {1 1 1 1} *]
test cmdMZ-6.9 {Tcl_TimeRateObjCmd: max count of iterations} {
set m1 [timerate {} 1000 5]; # max-count wins
set m2 [timerate {_nrt_sleep 20} 1 5]; # max-time wins
list [lindex $m1 2] [lindex $m2 2]
} {5 1}
test cmdMZ-6.10 {Tcl_TimeRateObjCmd: huge overhead cause 0us result} -body {
set m1 [timerate -overhead 1e6 {_nrt_sleep 10} 100 1]
list [list \
[expr {[lindex $m1 0] == 0.0}] \
[expr {[lindex $m1 2] == 1}] \
[expr {[lindex $m1 4] == 1000000}] \
[expr {[lindex $m1 6] <= 0.001}] \
] $m1; # interesting only in error case.
} -match glob -result [list {1 1 1 1} *]
test cmdMZ-6.11 {Tcl_TimeRateObjCmd: done/continue optimization rollback} {
set m1 {set m2 ok}
if 1 $m1
timerate $m1 1000 10
if 1 $m1; # if rollback is missing throws an error: invoked "continue" outside of a loop
} ok
test cmdMZ-6.12 {Tcl_TimeRateObjCmd: done optimization: nested call of self inside timerate} {
set x 0
set m1 {
if {[incr x] <= 5} {
# nested call should return result, so covering that:
if {![string is integer -strict [eval $m1]]} {error unexpected}
}
# increase again (no "continue" from nested call):
incr x
}
list [lindex [timerate $m1 1000 5] 2] $x
} {5 20}
test cmdMZ-try-1.0 {
fix for issue 45b9faf103f2
[try] interaction with local variable names produces segmentation violation
|
| ︙ | ︙ |
Changes to tests/compExpr-old.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
# Big test for correct ordering of data in [expr]
proc testIEEE {} {
variable ieeeValues
binary scan [binary format dd -1.0 1.0] c* c
switch -exact -- $c {
| > | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
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 {} {
variable ieeeValues
binary scan [binary format dd -1.0 1.0] c* c
switch -exact -- $c {
|
| ︙ | ︙ | |||
274 275 276 277 278 279 280 |
expr 2***3|6
} -returnCodes error -match glob -result *
test compExpr-old-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body {
expr 2^x
} -returnCodes error -match glob -result *
test compExpr-old-6.9 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {24.0^3}} msg] $msg
| | | | | | 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 |
expr 2***3|6
} -returnCodes error -match glob -result *
test compExpr-old-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body {
expr 2^x
} -returnCodes error -match glob -result *
test compExpr-old-6.9 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {24.0^3}} msg] $msg
} {1 {can't use floating-point value as operand of "^"}}
test compExpr-old-6.10 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {"a"^"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "^"}}
test compExpr-old-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0
test compExpr-old-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1
test compExpr-old-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1
test compExpr-old-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0
test compExpr-old-7.5 {CompileBitAndExpr: error in equality expr} -body {
expr x==3
} -returnCodes error -match glob -result *
test compExpr-old-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3
test compExpr-old-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82
test compExpr-old-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2
test compExpr-old-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7
test compExpr-old-7.10 {CompileBitAndExpr: error compiling bitand arm} -body {
expr 2***3&6
} -returnCodes error -match glob -result *
test compExpr-old-7.11 {CompileBitAndExpr: error compiling bitand arm} -body {
expr 2&x
} -returnCodes error -match glob -result *
test compExpr-old-7.12 {CompileBitAndExpr: runtime error in bitand arm} {
list [catch {expr {24.0&3}} msg] $msg
} {1 {can't use floating-point value as operand of "&"}}
test compExpr-old-7.13 {CompileBitAndExpr: runtime error in bitand arm} {
list [catch {expr {"a"&"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "&"}}
test compExpr-old-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1
test compExpr-old-8.2 {CompileEqualityExpr: just relational expr} {expr 2<=2.1} 1
test compExpr-old-8.3 {CompileEqualityExpr: just relational expr} {expr 3.2>"2.2"} 1
test compExpr-old-8.4 {CompileEqualityExpr: just relational expr} {expr {"0y"<"0x12"}} 0
test compExpr-old-8.5 {CompileEqualityExpr: error in relational expr} -body {
expr x>3
|
| ︙ | ︙ | |||
359 360 361 362 363 364 365 |
expr 2***3>>6
} -returnCodes error -match glob -result *
test compExpr-old-10.9 {CompileShiftExpr: error compiling shift arm} -body {
expr 2<<x
} -returnCodes error -match glob -result *
test compExpr-old-10.10 {CompileShiftExpr: runtime error} {
list [catch {expr {24.0>>43}} msg] $msg
| | | | | | 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 |
expr 2***3>>6
} -returnCodes error -match glob -result *
test compExpr-old-10.9 {CompileShiftExpr: error compiling shift arm} -body {
expr 2<<x
} -returnCodes error -match glob -result *
test compExpr-old-10.10 {CompileShiftExpr: runtime error} {
list [catch {expr {24.0>>43}} msg] $msg
} {1 {can't use floating-point value as operand of ">>"}}
test compExpr-old-10.11 {CompileShiftExpr: runtime error} {
list [catch {expr {"a"<<"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "<<"}}
test compExpr-old-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8
test compExpr-old-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1
test compExpr-old-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1
test compExpr-old-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0o123} 6
test compExpr-old-11.5 {CompileAddExpr: error in multiply expr} -body {
expr x*3
} -returnCodes error -match glob -result *
test compExpr-old-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258
test compExpr-old-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239
test compExpr-old-11.8 {CompileAddExpr: error compiling add arm} -body {
expr 2***3+6
} -returnCodes error -match glob -result *
test compExpr-old-11.9 {CompileAddExpr: error compiling add arm} -body {
expr 2-x
} -returnCodes error -match glob -result *
test compExpr-old-11.10 {CompileAddExpr: runtime error} {
list [catch {expr {24.0+"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test compExpr-old-11.11 {CompileAddExpr: runtime error} {
list [catch {expr {"a"-"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "-"}}
test compExpr-old-11.12 {CompileAddExpr: runtime error} {
list [catch {expr {3/0}} msg] $msg
} {1 {divide by zero}}
test compExpr-old-11.13a {CompileAddExpr: runtime error} ieeeFloatingPoint {
list [catch {expr {2.3/0.0}} msg] $msg
} {0 Inf}
test compExpr-old-11.13b {CompileAddExpr: runtime error} !ieeeFloatingPoint {
|
| ︙ | ︙ | |||
412 413 414 415 416 417 418 |
expr 2*3%%6
} -returnCodes error -match glob -result *
test compExpr-old-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body {
expr 2*x
} -returnCodes error -match glob -result *
test compExpr-old-12.10 {CompileMultiplyExpr: runtime error} {
list [catch {expr {24.0*"xx"}} msg] $msg
| | | | | | 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 |
expr 2*3%%6
} -returnCodes error -match glob -result *
test compExpr-old-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body {
expr 2*x
} -returnCodes error -match glob -result *
test compExpr-old-12.10 {CompileMultiplyExpr: runtime error} {
list [catch {expr {24.0*"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "*"}}
test compExpr-old-12.11 {CompileMultiplyExpr: runtime error} {
list [catch {expr {"a"/"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "/"}}
test compExpr-old-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255
test compExpr-old-13.2 {CompileUnaryExpr: unary exprs} {expr +0o00123} 83
test compExpr-old-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36
test compExpr-old-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0
test compExpr-old-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0
test compExpr-old-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1
test compExpr-old-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0
test compExpr-old-13.8 {CompileUnaryExpr: error compiling unary expr} -body {
expr ~x
} -returnCodes error -match glob -result *
test compExpr-old-13.9 {CompileUnaryExpr: error compiling unary expr} -body {
expr !1.x
set msg
} -returnCodes error -match glob -result *
test compExpr-old-13.10 {CompileUnaryExpr: runtime error} {
list [catch {expr {~"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "~"}}
test compExpr-old-13.11 {CompileUnaryExpr: runtime error} {
list [catch {expr ~4.0} msg] $msg
} {1 {can't use floating-point value as operand of "~"}}
test compExpr-old-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291
test compExpr-old-13.13 {CompileUnaryExpr: just primary expr} {
set a 27
expr $a
} 27
test compExpr-old-13.14 {CompileUnaryExpr: just primary expr} {
expr double(27)
|
| ︙ | ︙ | |||
584 585 586 587 588 589 590 |
set ::errorInfo
} -match glob -result {too few 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 *
| < | 585 586 587 588 589 590 591 592 593 594 595 596 597 598 |
set ::errorInfo
} -match glob -result {too few 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}
set a(VALUE) ff15
set i 123
if {[expr 0x$a(VALUE)] & 16} {
set i {}
}
|
| ︙ | ︙ |
Changes to tests/compExpr.test.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 |
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
# Constrain memory leak tests
testConstraint memory [llength [info commands memory]]
catch {unset a}
test compExpr-1.1 {TclCompileExpr procedure, successful expr parse and compile} {
| > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 |
if {"::tcltest" ni [namespace children]} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
# Constrain memory leak tests
testConstraint memory [llength [info commands memory]]
catch {unset a}
test compExpr-1.1 {TclCompileExpr procedure, successful expr parse and compile} {
|
| ︙ | ︙ |
Changes to tests/compile.test.
| ︙ | ︙ | |||
319 320 321 322 323 324 325 |
}}
} -returnCodes error -result {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}
test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
apply {{} { set r [list foobar] ; string index a bogus }}
} -returnCodes error -result {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}
test compile-11.3 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
apply {{} { set r [list foobar] ; string index a 0o9 }}
| | | 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 |
}}
} -returnCodes error -result {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}
test compile-11.2 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
apply {{} { set r [list foobar] ; string index a bogus }}
} -returnCodes error -result {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}
test compile-11.3 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
apply {{} { set r [list foobar] ; string index a 0o9 }}
} -returnCodes error -match glob -result {*invalid octal number*}
test compile-11.4 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body {
apply {{} { set r [list foobar] ; array set var {one two many} }}
} -returnCodes error -result {list must have an even number of elements}
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 {
|
| ︙ | ︙ | |||
461 462 463 464 465 466 467 468 469 470 471 472 473 474 |
for {set i 0} {$i < 3000} {incr i} {
append body " $i"
}
append body {]; puts OK}
regsub BODY {proc crash {} {BODY}; crash} $body script
list [catch {exec [interpreter] << $script} msg] $msg
} {0 OK}
# Tests compile-14.* for [Bug 599788] [Bug 0c043a175a47da8c2342]
test compile-14.1 {testing errors in element name; segfault?} {} {
catch {set a([error])} msg1
catch {set bubba([join $abba $jubba]) $vol} msg2
list $msg1 $msg2
} {{wrong # args: should be "error message ?errorInfo? ?errorCode?"} {can't read "abba": no such variable}}
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
for {set i 0} {$i < 3000} {incr i} {
append body " $i"
}
append body {]; puts OK}
regsub BODY {proc crash {} {BODY}; crash} $body script
list [catch {exec [interpreter] << $script} msg] $msg
} {0 OK}
# Tests of nested compile (body in body compilation), should not generate stack overflow
# (with abnormal program termination), bug [fec0c17d39]:
proc _ti_gencode {} {
# creates test interpreter on demand with [gencode] generator:
if {[interp exists ti]} {
return
}
interp create ti
ti eval {proc gencode {nr {cmd eval} {nl 0}} {
set code ""
set e ""; if {$nl} {set e "\n"}
for {set i 0} {$i < $nr} {incr i} {
append code "$cmd \{$e"
}
append code "lappend result 1$e"
for {set i 0} {$i < $nr} {incr i} {
append code "\}$e"
}
#puts [format "%% %.40s ... %d bytes" $code [string length $code]]
return $code
}}
}
test compile-13.2 {TclCompileScript: testing expected nested scripts compilation} -setup {
_ti_gencode
interp recursionlimit ti [expr {10000+50}]
ti eval {set result {}}
} -body {
# Test different compilation variants (instructions evalStk, invokeStk, etc),
# with 1500 (1000 in debug) nested scripts (bodies). If you get SO/SF exceptions on some low-stack
# boxes or systems, please don't decrease it (either provide a constraint)
ti eval {foreach cmd {eval "if 1" try catch} {
set c [gencode [expr {![::tcl::pkgconfig get debug] ? 1500 : 1000}] $cmd]
if 1 $c
}}
ti eval {set result}
} -result {1 1 1 1}
test compile-13.3 {TclCompileScript: testing check of max depth by nested scripts compilation} -setup {
_ti_gencode
interp recursionlimit ti 100
ti eval {set result {}}
} -body {
# Test different compilation variants (instructions evalStk, invokeStk, etc),
# with 500 nested scripts (bodies). It must generate "too many nested compilations"
# error for any variant we're testing here:
ti eval {foreach cmd {eval "if 1" try catch} {
set c [gencode 500 $cmd]
lappend errors [catch $c e] $e
}}
#puts $errors
# all of nested calls exceed the limit, so must end with "too many nested compilations"
# (or evaluations, depending on compile method/instruction and "mixed" compile within
# evaliation), so no one succeeds, the result must be empty:
ti eval {set result}
} -result {}
#
# clean up:
if {[interp exists ti]} {
interp delete ti
}
rename _ti_gencode {}
# Tests compile-14.* for [Bug 599788] [Bug 0c043a175a47da8c2342]
test compile-14.1 {testing errors in element name; segfault?} {} {
catch {set a([error])} msg1
catch {set bubba([join $abba $jubba]) $vol} msg2
list $msg1 $msg2
} {{wrong # args: should be "error message ?errorInfo? ?errorCode?"} {can't read "abba": no such variable}}
|
| ︙ | ︙ |
Changes to tests/dstring.test.
| ︙ | ︙ | |||
176 177 178 179 180 181 182 |
} -body {
testdstring append x -1
testdstring element #
testdstring get
} -cleanup {
testdstring free
} -result {x #}
| | > > | < | > > > > > > > > > > > > > > > > > > > > | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 |
} -body {
testdstring append x -1
testdstring element #
testdstring get
} -cleanup {
testdstring free
} -result {x #}
test dstring-2.13 {appending list elements} -constraints testdstring -setup {
testdstring free
} -body {
# This test checks the sophistication in Tcl_DStringAppendElement's
# decision about whether #-quoting can be disabled.
testdstring append "x " -1
testdstring element #
testdstring get
} -cleanup {
testdstring free
} -result {x #}
test dstring-2.14 {appending list elements} -constraints testdstring -setup {
testdstring free
} -body {
testdstring append " " -1
testdstring element #
testdstring get
} -cleanup {
testdstring free
} -result { {#}}
test dstring-2.15 {appending list elements} -constraints testdstring -setup {
testdstring free
} -body {
# This test checks the sophistication in Tcl_DStringAppendElement's
# decision about whether #-quoting can be disabled.
testdstring append "x " -1
testdstring element #
testdstring get
} -cleanup {
testdstring free
} -result {x #}
test dstring-3.1 {nested sublists} -constraints testdstring -setup {
testdstring free
} -body {
testdstring start
testdstring element foo
testdstring element bar
|
| ︙ | ︙ | |||
302 303 304 305 306 307 308 |
testdstring append x -1
testdstring element #
testdstring end
testdstring get
} -cleanup {
testdstring free
} -result {x {x #}}
| | > > | < | > > > > > > > > > > > > > > > > > > > > > > > > > > | 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 |
testdstring append x -1
testdstring element #
testdstring end
testdstring get
} -cleanup {
testdstring free
} -result {x {x #}}
test dstring-3.10 {appending list elements} -constraints testdstring -setup {
testdstring free
} -body {
# This test checks the sophistication in Tcl_DStringAppendElement's
# decision about whether #-quoting can be disabled.
testdstring append x -1
testdstring start
testdstring append "x " -1
testdstring element #
testdstring end
testdstring get
} -cleanup {
testdstring free
} -result {x {x #}}
test dstring-3.11 {appending list elements} -constraints testdstring -setup {
testdstring free
} -body {
testdstring append x -1
testdstring start
testdstring append " " -1
testdstring element #
testdstring end
testdstring get
} -cleanup {
testdstring free
} -result {x { {#}}}
test dstring-3.12 {appending list elements} -constraints testdstring -setup {
testdstring free
} -body {
# This test checks the sophistication in Tcl_DStringAppendElement's
# decision about whether #-quoting can be disabled.
testdstring append x -1
testdstring start
testdstring append "x " -1
testdstring element #
testdstring end
testdstring get
} -cleanup {
testdstring free
} -result {x {x #}}
test dstring-4.1 {truncation} -constraints testdstring -setup {
testdstring free
} -body {
testdstring append "abcdefg" -1
testdstring trunc 3
list [testdstring get] [testdstring length]
|
| ︙ | ︙ |
Changes to tests/encoding.test.
| ︙ | ︙ | |||
279 280 281 282 283 284 285 |
encoding dirs $path
encoding system $system
} -result {invalid encoding file "splat"}
# OpenEncodingFile is fully tested by the rest of the tests in this file.
test encoding-12.1 {LoadTableEncoding: normal encoding} {
| | | | | | | 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 |
encoding dirs $path
encoding system $system
} -result {invalid encoding file "splat"}
# 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\u4E4Eg]
append x [encoding convertfrom shiftjis ab\x8c\xc1g]
} "ab\x8c\xc1gab\u4e4eg"
test encoding-12.4 {LoadTableEncoding: double-byte encoding} {
set x [encoding convertto jis0208 \u4e4e\u3b1]
append x [encoding convertfrom jis0208 8C&A]
} "8C&A\u4e4e\u3b1"
test encoding-12.5 {LoadTableEncoding: symbol encoding} {
|
| ︙ | ︙ | |||
317 318 319 320 321 322 323 |
set z
} 00
test encoding-15.3 {UtfToUtfProc null character input} teststringbytes {
set y [encoding convertfrom utf-8 [encoding convertto utf-8 \u0000]]
binary scan [teststringbytes $y] H* z
set z
} c080
| | | | | | | > | > > > > > | > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > | > > > > > > | 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 |
set z
} 00
test encoding-15.3 {UtfToUtfProc null character input} teststringbytes {
set y [encoding convertfrom utf-8 [encoding convertto utf-8 \u0000]]
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 \U1F602"
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 \U1F602"
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} {
set x \uDE02\uD83D\uD83D
set y [encoding convertto utf-8 \uDE02\uD83D\uD83D]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {3 9 edb882eda0bdeda0bd}
test encoding-15.8 {UtfToUtfProc emoji character output} {
set x \uDE02\uD83D\xE9
set y [encoding convertto utf-8 \uDE02\uD83D\xE9]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {3 8 edb882eda0bdc3a9}
test encoding-15.9 {UtfToUtfProc emoji character output} {
set x \uDE02\uD83DX
set y [encoding convertto utf-8 \uDE02\uD83DX]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {3 7 edb882eda0bd58}
test encoding-15.10 {UtfToUtfProc high surrogate character output} {
set x \uDE02\xE9
set y [encoding convertto utf-8 \uDE02\xE9]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {2 5 edb882c3a9}
test encoding-15.11 {UtfToUtfProc low surrogate character output} {
set x \uDA02\xE9
set y [encoding convertto utf-8 \uDA02\xE9]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {2 5 eda882c3a9}
test encoding-15.12 {UtfToUtfProc high surrogate character output} {
set x \uDE02Y
set y [encoding convertto utf-8 \uDE02Y]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {2 4 edb88259}
test encoding-15.13 {UtfToUtfProc low surrogate character output} {
set x \uDA02Y
set y [encoding convertto utf-8 \uDA02Y]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {2 4 eda88259}
test encoding-15.14 {UtfToUtfProc high surrogate character output} {
set x \uDE02
set y [encoding convertto utf-8 \uDE02]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {1 3 edb882}
test encoding-15.15 {UtfToUtfProc low surrogate character output} {
set x \uDA02
set y [encoding convertto utf-8 \uDA02]
binary scan $y H* z
list [string length $x] [string length $y] $z
} {1 3 eda882}
test encoding-15.16 {UtfToUtfProc: Invalid 4-byte UTF-8, see [ed29806ba]} {
set x \xF0\xA0\xA1\xC2
set y [encoding convertfrom utf-8 \xF0\xA0\xA1\xC2]
list [string length $x] $y
} "4 \xF0\xA0\xA1\xC2"
test encoding-15.17 {UtfToUtfProc emoji character output} {
set x \U1F602
set y [encoding convertto utf-8 \U1F602]
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 "\u4E4E 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]]
} -result "\uDCDC dcdc"
test encoding-16.4 {Ucs2ToUtfProc} -body {
set val [encoding convertfrom ucs-2 NN]
list $val [format %x [scan $val %c]]
} -result "\u4E4E 4e4e"
test encoding-16.4 {Ucs2ToUtfProc} -body {
set val [encoding convertfrom ucs-2 "\xD8\xD8\xDC\xDC"]
list $val [format %x [scan $val %c]]
} -result "\U460DC 460dc"
test encoding-17.1 {UtfToUtf16Proc} -body {
encoding convertto utf-16 "\U460DC"
} -result "\xD8\xD8\xDC\xDC"
test encoding-17.2 {UtfToUtf16Proc} -body {
encoding convertto utf-16 "\uDCDC"
} -result "\xDC\xDC"
test encoding-17.3 {UtfToUtf16Proc} -body {
encoding convertto utf-16 "\uD8D8"
} -result "\xD8\xD8"
test encoding-17.4 {UtfToUcs2Proc} -body {
encoding convertfrom utf-16 [encoding convertto ucs-2 "\U460DC"]
} -result "\uFFFD"
test encoding-18.1 {TableToUtfProc} {
} {}
test encoding-19.1 {TableFromUtfProc} {
} {}
|
| ︙ | ︙ | |||
616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 |
encoding dirs ? ?
} -result {wrong # args: should be "encoding dirs ?dirList?"}
test encoding-27.2 {encoding dirs basic behavior} -returnCodes error -body {
encoding dirs "\{not a list"
} -result "expected directory list but got \"\{not a list\""
}
runtests
}
# cleanup
namespace delete ::tcl::test::encoding
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > > > > > > > > > > > > | 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 |
encoding dirs ? ?
} -result {wrong # args: should be "encoding dirs ?dirList?"}
test encoding-27.2 {encoding dirs basic behavior} -returnCodes error -body {
encoding dirs "\{not a list"
} -result "expected directory list but got \"\{not a list\""
}
test encoding-28.0 {all encodings load} -body {
set string hello
foreach name [encoding names] {
incr count
encoding convertto $name $string
# discard the cached internal representation of Tcl_Encoding
# Unfortunately, without this, encoding 2-1 fails.
llength $name
}
return $count
} -result [expr {[info exists ::tcl_precision] ? 86 : 85}]
runtests
}
# cleanup
namespace delete ::tcl::test::encoding
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/env.test.
| ︙ | ︙ | |||
215 216 217 218 219 220 221 222 223 224 225 226 227 228 |
set env(XYZZY) "garbage"
getenv
} -cleanup { cleanup1
} -result {NAME1=test string
NAME2=more
XYZZY=garbage}
test env-3.1 {
changing environment variables
} -constraints exec -setup setup2 -body {
set result [getenv]
unset env(NAME2)
set result
| > > > > > > > > > > > > > > > > > > > > | 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 |
set env(XYZZY) "garbage"
getenv
} -cleanup { cleanup1
} -result {NAME1=test string
NAME2=more
XYZZY=garbage}
test env-2.5 {different encoding (wide chars)} -constraints {win exec} -setup {
# be sure set of (unicode) environment occurs if single-byte encoding is used:
encodingswitch cp1252
# german (cp1252) and russian (cp1251) characters together encoded as utf-8:
set val 2d2dc3a4c3b6c3bcc39f2dd182d0b5d181d1822d2d
set env(XYZZY) [encoding convertfrom utf-8 [binary decode hex $val]]
# now switch to utf-8 (to see correct values from test):
encoding system utf-8
} -body {
exec [interpreter] << [string map [list \$val $val] {
encoding system utf-8; fconfigure stdout -encoding utf-8
set test [encoding convertfrom utf-8 [binary decode hex $val]]
puts "[expr {$env(XYZZY) eq $test}] \ngot:\t\
$env(XYZZY) ([binary encode hex [encoding convertto $env(XYZZY)]]) \nexp:\t\
$test ([binary encode hex [encoding convertto $test]])"
}]
} -cleanup {
encodingrestore
unset -nocomplain val f env(XYZZY)
} -match glob -result {1 *}
test env-3.1 {
changing environment variables
} -constraints exec -setup setup2 -body {
set result [getenv]
unset env(NAME2)
set result
|
| ︙ | ︙ |
Changes to tests/exec.test.
| ︙ | ︙ | |||
20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
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]]
unset -nocomplain path
# Utilities that are like bourne shell stalwarts, but cross-platform.
set path(echo) [makeFile {
puts -nonewline [lindex $argv 0]
foreach str [lrange $argv 1 end] {
puts -nonewline " $str"
| > > | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 |
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]]
testConstraint noosx [expr {![info exists ::env(TRAVIS_OSX_IMAGE)] || ![string match xcode* $::env(TRAVIS_OSX_IMAGE)]}]
unset -nocomplain path
# Utilities that are like bourne shell stalwarts, but cross-platform.
set path(echo) [makeFile {
puts -nonewline [lindex $argv 0]
foreach str [lrange $argv 1 end] {
puts -nonewline " $str"
|
| ︙ | ︙ | |||
665 666 667 668 669 670 671 |
} -constraints {exec tempNotWin} -cleanup {
removeFile $path(fooblah)
} -result contents
# Note that this test cannot be adapted to work on Windows; that platform has
# no kernel support for an analog of O_APPEND. OTOH, that means we can assume
# that there is a POSIX shell...
| | | 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 |
} -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...
test exec-19.1 {exec >> uses O_APPEND} -constraints {exec unix notValgrind noosx} -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.
| ︙ | ︙ | |||
33 34 35 36 37 38 39 40 41 42 43 44 45 46 |
&& [llength [info commands testdoubleobj]]
&& [llength [info commands teststringobj]]
}]
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint testexprlongobj [llength [info commands testexprlongobj]]
# Tests for the omnibus TclExecuteByteCode function:
# INST_DONE not tested
# INST_PUSH1 not tested
# INST_PUSH4 not tested
# INST_POP not tested
# INST_DUP not tested
| > > > > > | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 |
&& [llength [info commands testdoubleobj]]
&& [llength [info commands teststringobj]]
}]
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint testexprlongobj [llength [info commands testexprlongobj]]
if {[namespace which -command testbumpinterpepoch] eq ""} {
proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set }
}
# Tests for the omnibus TclExecuteByteCode function:
# INST_DONE not tested
# INST_PUSH1 not tested
# INST_PUSH4 not tested
# INST_POP not tested
# INST_DUP not tested
|
| ︙ | ︙ | |||
170 171 172 173 174 175 176 |
test execute-3.5 {TclExecuteByteCode, INST_ADD, op1 is string double} {testobj} {
set x [teststringobj set 0 1.0]
expr {$x + 1}
} 2.0
test execute-3.6 {TclExecuteByteCode, INST_ADD, op1 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {$x + 1}} msg] $msg
| | | 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 |
test execute-3.5 {TclExecuteByteCode, INST_ADD, op1 is string double} {testobj} {
set x [teststringobj set 0 1.0]
expr {$x + 1}
} 2.0
test execute-3.6 {TclExecuteByteCode, INST_ADD, op1 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {$x + 1}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test execute-3.7 {TclExecuteByteCode, INST_ADD, op2 is int} {testobj} {
set x [testintobj set 0 1]
expr {1 + $x}
} 2
test execute-3.8 {TclExecuteByteCode, INST_ADD, op2 is double} {testobj} {
set x [testdoubleobj set 0 1]
expr {1 + $x}
|
| ︙ | ︙ | |||
195 196 197 198 199 200 201 |
test execute-3.11 {TclExecuteByteCode, INST_ADD, op2 is string double} {testobj} {
set x [teststringobj set 0 1.0]
expr {1 + $x}
} 2.0
test execute-3.12 {TclExecuteByteCode, INST_ADD, op2 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {1 + $x}} msg] $msg
| | | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 |
test execute-3.11 {TclExecuteByteCode, INST_ADD, op2 is string double} {testobj} {
set x [teststringobj set 0 1.0]
expr {1 + $x}
} 2.0
test execute-3.12 {TclExecuteByteCode, INST_ADD, op2 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {1 + $x}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
# INST_SUB is partially tested:
test execute-3.13 {TclExecuteByteCode, INST_SUB, op1 is int} {testobj} {
set x [testintobj set 0 1]
expr {$x - 1}
} 0
test execute-3.14 {TclExecuteByteCode, INST_SUB, op1 is double} {testobj} {
|
| ︙ | ︙ | |||
222 223 224 225 226 227 228 |
test execute-3.17 {TclExecuteByteCode, INST_SUB, op1 is string double} {testobj} {
set x [teststringobj set 0 1.0]
expr {$x - 1}
} 0.0
test execute-3.18 {TclExecuteByteCode, INST_SUB, op1 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {$x - 1}} msg] $msg
| | | 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 |
test execute-3.17 {TclExecuteByteCode, INST_SUB, op1 is string double} {testobj} {
set x [teststringobj set 0 1.0]
expr {$x - 1}
} 0.0
test execute-3.18 {TclExecuteByteCode, INST_SUB, op1 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {$x - 1}} msg] $msg
} {1 {can't use non-numeric string as operand of "-"}}
test execute-3.19 {TclExecuteByteCode, INST_SUB, op2 is int} {testobj} {
set x [testintobj set 0 1]
expr {1 - $x}
} 0
test execute-3.20 {TclExecuteByteCode, INST_SUB, op2 is double} {testobj} {
set x [testdoubleobj set 0 1]
expr {1 - $x}
|
| ︙ | ︙ | |||
247 248 249 250 251 252 253 |
test execute-3.23 {TclExecuteByteCode, INST_SUB, op2 is string double} {testobj} {
set x [teststringobj set 0 1.0]
expr {1 - $x}
} 0.0
test execute-3.24 {TclExecuteByteCode, INST_SUB, op2 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {1 - $x}} msg] $msg
| | | 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 |
test execute-3.23 {TclExecuteByteCode, INST_SUB, op2 is string double} {testobj} {
set x [teststringobj set 0 1.0]
expr {1 - $x}
} 0.0
test execute-3.24 {TclExecuteByteCode, INST_SUB, op2 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {1 - $x}} msg] $msg
} {1 {can't use non-numeric string as operand of "-"}}
# INST_MULT is partially tested:
test execute-3.25 {TclExecuteByteCode, INST_MULT, op1 is int} {testobj} {
set x [testintobj set 1 1]
expr {$x * 1}
} 1
test execute-3.26 {TclExecuteByteCode, INST_MULT, op1 is double} {testobj} {
|
| ︙ | ︙ | |||
274 275 276 277 278 279 280 |
test execute-3.29 {TclExecuteByteCode, INST_MULT, op1 is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {$x * 1}
} 1.0
test execute-3.30 {TclExecuteByteCode, INST_MULT, op1 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {$x * 1}} msg] $msg
| | | 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 |
test execute-3.29 {TclExecuteByteCode, INST_MULT, op1 is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {$x * 1}
} 1.0
test execute-3.30 {TclExecuteByteCode, INST_MULT, op1 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {$x * 1}} msg] $msg
} {1 {can't use non-numeric string as operand of "*"}}
test execute-3.31 {TclExecuteByteCode, INST_MULT, op2 is int} {testobj} {
set x [testintobj set 1 1]
expr {1 * $x}
} 1
test execute-3.32 {TclExecuteByteCode, INST_MULT, op2 is double} {testobj} {
set x [testdoubleobj set 1 2.0]
expr {1 * $x}
|
| ︙ | ︙ | |||
299 300 301 302 303 304 305 |
test execute-3.35 {TclExecuteByteCode, INST_MULT, op2 is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {1 * $x}
} 1.0
test execute-3.36 {TclExecuteByteCode, INST_MULT, op2 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {1 * $x}} msg] $msg
| | | 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 |
test execute-3.35 {TclExecuteByteCode, INST_MULT, op2 is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {1 * $x}
} 1.0
test execute-3.36 {TclExecuteByteCode, INST_MULT, op2 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {1 * $x}} msg] $msg
} {1 {can't use non-numeric string as operand of "*"}}
# INST_DIV is partially tested:
test execute-3.37 {TclExecuteByteCode, INST_DIV, op1 is int} {testobj} {
set x [testintobj set 1 1]
expr {$x / 1}
} 1
test execute-3.38 {TclExecuteByteCode, INST_DIV, op1 is double} {testobj} {
|
| ︙ | ︙ | |||
326 327 328 329 330 331 332 |
test execute-3.41 {TclExecuteByteCode, INST_DIV, op1 is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {$x / 1}
} 1.0
test execute-3.42 {TclExecuteByteCode, INST_DIV, op1 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {$x / 1}} msg] $msg
| | | 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 |
test execute-3.41 {TclExecuteByteCode, INST_DIV, op1 is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {$x / 1}
} 1.0
test execute-3.42 {TclExecuteByteCode, INST_DIV, op1 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {$x / 1}} msg] $msg
} {1 {can't use non-numeric string as operand of "/"}}
test execute-3.43 {TclExecuteByteCode, INST_DIV, op2 is int} {testobj} {
set x [testintobj set 1 1]
expr {2 / $x}
} 2
test execute-3.44 {TclExecuteByteCode, INST_DIV, op2 is double} {testobj} {
set x [testdoubleobj set 1 1.0]
expr {2 / $x}
|
| ︙ | ︙ | |||
351 352 353 354 355 356 357 |
test execute-3.47 {TclExecuteByteCode, INST_DIV, op2 is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {2 / $x}
} 2.0
test execute-3.48 {TclExecuteByteCode, INST_DIV, op2 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {1 / $x}} msg] $msg
| | | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 |
test execute-3.47 {TclExecuteByteCode, INST_DIV, op2 is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {2 / $x}
} 2.0
test execute-3.48 {TclExecuteByteCode, INST_DIV, op2 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {1 / $x}} msg] $msg
} {1 {can't use non-numeric string as operand of "/"}}
# INST_UPLUS is partially tested:
test execute-3.49 {TclExecuteByteCode, INST_UPLUS, op is int} {testobj} {
set x [testintobj set 1 1]
expr {+ $x}
} 1
test execute-3.50 {TclExecuteByteCode, INST_UPLUS, op is double} {testobj} {
|
| ︙ | ︙ | |||
378 379 380 381 382 383 384 |
test execute-3.53 {TclExecuteByteCode, INST_UPLUS, op is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {+ $x}
} 1.0
test execute-3.54 {TclExecuteByteCode, INST_UPLUS, op is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {+ $x}} msg] $msg
| | | 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 |
test execute-3.53 {TclExecuteByteCode, INST_UPLUS, op is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {+ $x}
} 1.0
test execute-3.54 {TclExecuteByteCode, INST_UPLUS, op is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {+ $x}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
# INST_UMINUS is partially tested:
test execute-3.55 {TclExecuteByteCode, INST_UMINUS, op is int} {testobj} {
set x [testintobj set 1 1]
expr {- $x}
} -1
test execute-3.56 {TclExecuteByteCode, INST_UMINUS, op is double} {testobj} {
|
| ︙ | ︙ | |||
405 406 407 408 409 410 411 |
test execute-3.59 {TclExecuteByteCode, INST_UMINUS, op is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {- $x}
} -1.0
test execute-3.60 {TclExecuteByteCode, INST_UMINUS, op is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {- $x}} msg] $msg
| | | 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 |
test execute-3.59 {TclExecuteByteCode, INST_UMINUS, op is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {- $x}
} -1.0
test execute-3.60 {TclExecuteByteCode, INST_UMINUS, op is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {- $x}} msg] $msg
} {1 {can't use non-numeric string as operand of "-"}}
# INST_LNOT is partially tested:
test execute-3.61 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} {
set x [testintobj set 1 2]
expr {! $x}
} 0
test execute-3.62 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} {
|
| ︙ | ︙ | |||
453 454 455 456 457 458 459 |
test execute-3.70 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj} {
set x [teststringobj set 1 0.0]
expr {! $x}
} 1
test execute-3.71 {TclExecuteByteCode, INST_LNOT, op is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {! $x}} msg] $msg
| | > > > > | 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 |
test execute-3.70 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj} {
set x [teststringobj set 1 0.0]
expr {! $x}
} 1
test execute-3.71 {TclExecuteByteCode, INST_LNOT, op is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {! $x}} msg] $msg
} {1 {can't use non-numeric string as operand of "!"}}
# INST_BITNOT not tested
# INST_CALL_BUILTIN_FUNC1 not tested
# INST_CALL_FUNC1 not tested
# INST_TRY_CVT_TO_NUMERIC is partially tested:
test execute-3.72 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is int} {testobj} {
set x [testintobj set 1 1]
expr {$x}
} 1
test execute-3.73 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is double} {testobj} {
|
| ︙ | ︙ | |||
925 926 927 928 929 930 931 |
# Test for [Bug #1055676], correct restoration of the stack top after the
# epoch is bumped and the stack is grown in a call from a nested
# evaluation
set arglst [string repeat "a " 1000]
proc f {args} "f $arglst"
proc run {} {
# bump the interp's epoch
| | < | < | 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 |
# Test for [Bug #1055676], correct restoration of the stack top after the
# epoch is bumped and the stack is grown in a call from a nested
# evaluation
set arglst [string repeat "a " 1000]
proc f {args} "f $arglst"
proc run {} {
# bump the interp's epoch
testbumpinterpepoch
catch f msg
set msg
}
run
} -cleanup {
interp recursionlimit {} $limit
} -result {too many nested evaluations (infinite loop?)}
test execute-8.4 {Compile epoch bump effect on stack trace} -setup {
proc foo {} {
error bar
}
proc FOO {} {
catch {error bar} m o
testbumpinterpepoch
return -options $o $m
}
} -body {
catch foo m o
set stack1 [dict get $o -errorinfo]
catch FOO m o
set stack2 [string map {FOO foo} [dict get $o -errorinfo]]
|
| ︙ | ︙ | |||
970 971 972 973 974 975 976 977 978 979 |
rename demo {}
} -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-9.1 {Interp result resetting [Bug 1522803]} {
set c 0
catch {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 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 |
rename demo {}
} -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 slave
slave eval {
package require tcltest
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 {
slave eval {
lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C;
}
slave eval {
set i 0; while {[incr i] < 3} {
lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C;
}
}
slave eval {
set i 0; while {[incr i] < 3} {
lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C;
}
}
slave eval {
catch {
lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C;
}
}
slave eval {set res}
} -cleanup {
interp delete slave
} -result [lrepeat 4 A B]
test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), exception case} -setup {
interp create slave
slave eval {
package require tcltest
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 {
slave eval {
lappend res A; testbumpinterpepoch; lappend res B; return -code error test; lappend res C;
}
} e] $e
lappend res [catch {
slave eval {
lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C;
}
} e] $e
lappend res [catch {
slave eval {
lappend res A; testbumpinterpepoch; lappend res B; return -code return test; lappend res C;
}
} e] $e
lappend res [catch {
slave eval {
lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C;
}
} e] $e
list $res [slave eval {set res}]
} -cleanup {
interp delete slave
} -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
}
|
| ︙ | ︙ | |||
1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 |
for {set i 0} {$i < $n} {incr i} {
yield $i
}
}
proc t {args} {
incr ::foo
}
trace add execution ::generate enterstep ::t
} -body {
coroutine coro generate 5
trace remove execution ::generate enterstep ::t
set ::foo
} -cleanup {
unset ::foo
| > | 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 |
for {set i 0} {$i < $n} {incr i} {
yield $i
}
}
proc t {args} {
incr ::foo
}
set ::foo 0
trace add execution ::generate enterstep ::t
} -body {
coroutine coro generate 5
trace remove execution ::generate enterstep ::t
set ::foo
} -cleanup {
unset ::foo
|
| ︙ | ︙ |
Changes to tests/expr-old.test.
| ︙ | ︙ | |||
188 189 190 191 192 193 194 |
list [catch {expr 028.1 + 09.2} msg] $msg
} {0 37.3}
# Operators that aren't legal on floating-point numbers
test expr-old-3.1 {illegal floating-point operations} {
list [catch {expr ~4.0} msg] $msg
| | | | | | | | | | | | 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 |
list [catch {expr 028.1 + 09.2} msg] $msg
} {0 37.3}
# Operators that aren't legal on floating-point numbers
test expr-old-3.1 {illegal floating-point operations} {
list [catch {expr ~4.0} msg] $msg
} {1 {can't use floating-point value as operand of "~"}}
test expr-old-3.2 {illegal floating-point operations} {
list [catch {expr 27%4.0} msg] $msg
} {1 {can't use floating-point value as operand of "%"}}
test expr-old-3.3 {illegal floating-point operations} {
list [catch {expr 27.0%4} msg] $msg
} {1 {can't use floating-point value as operand of "%"}}
test expr-old-3.4 {illegal floating-point operations} {
list [catch {expr 1.0<<3} msg] $msg
} {1 {can't use floating-point value as operand of "<<"}}
test expr-old-3.5 {illegal floating-point operations} {
list [catch {expr 3<<1.0} msg] $msg
} {1 {can't use floating-point value as operand of "<<"}}
test expr-old-3.6 {illegal floating-point operations} {
list [catch {expr 24.0>>3} msg] $msg
} {1 {can't use floating-point value as operand of ">>"}}
test expr-old-3.7 {illegal floating-point operations} {
list [catch {expr 24>>3.0} msg] $msg
} {1 {can't use floating-point value as operand of ">>"}}
test expr-old-3.8 {illegal floating-point operations} {
list [catch {expr 24&3.0} msg] $msg
} {1 {can't use floating-point value as operand of "&"}}
test expr-old-3.9 {illegal floating-point operations} {
list [catch {expr 24.0|3} msg] $msg
} {1 {can't use floating-point value as operand of "|"}}
test expr-old-3.10 {illegal floating-point operations} {
list [catch {expr 24.0^3} msg] $msg
} {1 {can't use floating-point value as operand of "^"}}
# Check the string operators individually.
test expr-old-4.1 {string operators} {expr {"abc" > "def"}} 0
test expr-old-4.2 {string operators} {expr {"def" > "def"}} 0
test expr-old-4.3 {string operators} {expr {"g" > "def"}} 1
test expr-old-4.4 {string operators} {expr {"abc" < "abd"}} 1
|
| ︙ | ︙ | |||
256 257 258 259 260 261 262 |
test expr-old-4.31 {string operators} {expr {1?"foo":"bar"}} foo
test expr-old-4.32 {string operators} {expr {0?"foo":"bar"}} bar
# Operators that aren't legal on string operands.
test expr-old-5.1 {illegal string operations} {
list [catch {expr {-"a"}} msg] $msg
| | | | | | | | | | | | | | | | 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 |
test expr-old-4.31 {string operators} {expr {1?"foo":"bar"}} foo
test expr-old-4.32 {string operators} {expr {0?"foo":"bar"}} bar
# Operators that aren't legal on string operands.
test expr-old-5.1 {illegal string operations} {
list [catch {expr {-"a"}} msg] $msg
} {1 {can't use non-numeric string as operand of "-"}}
test expr-old-5.2 {illegal string operations} {
list [catch {expr {+"a"}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-old-5.3 {illegal string operations} {
list [catch {expr {~"a"}} msg] $msg
} {1 {can't use non-numeric string as operand of "~"}}
test expr-old-5.4 {illegal string operations} {
list [catch {expr {!"a"}} msg] $msg
} {1 {can't use non-numeric string as operand of "!"}}
test expr-old-5.5 {illegal string operations} {
list [catch {expr {"a"*"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "*"}}
test expr-old-5.6 {illegal string operations} {
list [catch {expr {"a"/"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "/"}}
test expr-old-5.7 {illegal string operations} {
list [catch {expr {"a"%"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "%"}}
test expr-old-5.8 {illegal string operations} {
list [catch {expr {"a"+"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-old-5.9 {illegal string operations} {
list [catch {expr {"a"-"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "-"}}
test expr-old-5.10 {illegal string operations} {
list [catch {expr {"a"<<"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "<<"}}
test expr-old-5.11 {illegal string operations} {
list [catch {expr {"a">>"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of ">>"}}
test expr-old-5.12 {illegal string operations} {
list [catch {expr {"a"&"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "&"}}
test expr-old-5.13 {illegal string operations} {
list [catch {expr {"a"^"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "^"}}
test expr-old-5.14 {illegal string operations} {
list [catch {expr {"a"|"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "|"}}
test expr-old-5.15 {illegal string operations} {
list [catch {expr {"a"&&"b"}} msg] $msg
} {1 {expected boolean value but got "a"}}
test expr-old-5.16 {illegal string operations} {
list [catch {expr {"a"||"b"}} msg] $msg
} {1 {expected boolean value but got "a"}}
test expr-old-5.17 {illegal string operations} {
|
| ︙ | ︙ | |||
484 485 486 487 488 489 490 |
test expr-old-25.19 {type conversions} {expr 2.0e15} 2000000000000000.0
test expr-old-25.20 {type conversions} {expr 10.0} 10.0
# Various error conditions.
test expr-old-26.1 {error conditions} {
list [catch {expr 2+"a"} msg] $msg
| | | | | 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 |
test expr-old-25.19 {type conversions} {expr 2.0e15} 2000000000000000.0
test expr-old-25.20 {type conversions} {expr 10.0} 10.0
# Various error conditions.
test expr-old-26.1 {error conditions} {
list [catch {expr 2+"a"} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-old-26.2 {error conditions} -body {
expr 2+4*
} -returnCodes error -match glob -result *
test expr-old-26.3 {error conditions} -body {
expr 2+4*(
} -returnCodes error -match glob -result *
unset -nocomplain _non_existent_
test expr-old-26.4 {error conditions} {
list [catch {expr 2+$_non_existent_} msg] $msg
} {1 {can't read "_non_existent_": no such variable}}
set a xx
test expr-old-26.5 {error conditions} {
list [catch {expr {2+$a}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-old-26.6 {error conditions} {
list [catch {expr {2+[set a]}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-old-26.7 {error conditions} -body {
expr {2+(4}
} -returnCodes error -match glob -result *
test expr-old-26.8 {error conditions} {
list [catch {expr 2/0} msg] $msg $errorCode
} {1 {divide by zero} {ARITH DIVZERO {divide by zero}}}
test expr-old-26.9 {error conditions} {
|
| ︙ | ︙ | |||
525 526 527 528 529 530 531 |
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
| | | 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 |
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 "/"}}
test expr-old-26.14 {error conditions} -body {
expr 2:3
} -returnCodes error -match glob -result *
test expr-old-26.15 {error conditions} -body {
expr a@b
} -returnCodes error -match glob -result *
test expr-old-26.16 {error conditions} {
|
| ︙ | ︙ | |||
937 938 939 940 941 942 943 |
} -5076964154930102272
test expr-old-34.15 {errors in math functions} {
expr round(1.0e30)
} 1000000000000000019884624838656
test expr-old-34.16 {errors in math functions} {
expr round(-1.0e30)
} -1000000000000000019884624838656
| < | | 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 |
} -5076964154930102272
test expr-old-34.15 {errors in math functions} {
expr round(1.0e30)
} 1000000000000000019884624838656
test expr-old-34.16 {errors in math functions} {
expr round(-1.0e30)
} -1000000000000000019884624838656
test expr-old-36.1 {ExprLooksLikeInt procedure} -body {
expr 0o289
} -returnCodes error -match glob -result {*invalid octal number*}
test expr-old-36.2 {ExprLooksLikeInt procedure} {
set x 0o289
list [catch {expr {$x+1}} msg] $msg
} {1 {can't use invalid octal number as operand of "+"}}
test expr-old-36.3 {ExprLooksLikeInt procedure} {
list [catch {expr 0289.1} msg] $msg
} {0 289.1}
test expr-old-36.4 {ExprLooksLikeInt procedure} {
set x 0289.1
list [catch {expr {$x+1}} msg] $msg
} {0 290.1}
|
| ︙ | ︙ | |||
984 985 986 987 988 989 990 |
expr {$x+1}
} 665802003400000000000001
# tests for [Bug #587140]
test expr-old-36.12 {ExprLooksLikeInt procedure} {
set x "10;"
list [catch {expr {$x+1}} msg] $msg
| | | | | 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 |
expr {$x+1}
} 665802003400000000000001
# tests for [Bug #587140]
test expr-old-36.12 {ExprLooksLikeInt procedure} {
set x "10;"
list [catch {expr {$x+1}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-old-36.13 {ExprLooksLikeInt procedure} {
set x " +"
list [catch {expr {$x+1}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-old-36.14 {ExprLooksLikeInt procedure} {
set x "123456789012345678901234567890 "
expr {$x+1}
} 123456789012345678901234567891
test expr-old-36.15 {ExprLooksLikeInt procedure} {
set x "0o99 "
list [catch {expr {$x+1}} msg] $msg
} {1 {can't use invalid octal number as operand of "+"}}
test expr-old-36.16 {ExprLooksLikeInt procedure} {
set x " 0xffffffffffffffffffffffffffffffffffffff "
expr {$x+1}
} [expr 0x100000000000000000000000000000000000000]
test expr-old-37.1 {Check that Tcl_ExprLong doesn't modify interpreter result if no error} testexprlong {
testexprlong 4+1
|
| ︙ | ︙ |
Changes to tests/expr.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
# Determine if "long int" type is a 32 bit number and if the wide
# type is a 64 bit number on this machine.
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]
| > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2.1
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
# type is a 64 bit number on this machine.
testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
testConstraint longIs64bit [expr {$tcl_platform(wordSize) == 8}]
testConstraint wideIs64bit [expr {wide(0x8000000000000000) < 0}]
|
| ︙ | ︙ | |||
247 248 249 250 251 252 253 |
test expr-4.9 {CompileLorExpr: long lor arm} {
set a "abcdefghijkl"
set i 7
expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]}
} 1
test expr-4.10 {CompileLorExpr: error compiling ! operand} {
list [catch {expr {!"a"}} msg] $msg
| | | 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 |
test expr-4.9 {CompileLorExpr: long lor arm} {
set a "abcdefghijkl"
set i 7
expr {[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]] || [string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]&&[string compare [format %c $i] [string index $a $i]]}
} 1
test expr-4.10 {CompileLorExpr: error compiling ! operand} {
list [catch {expr {!"a"}} msg] $msg
} {1 {can't use non-numeric string as operand of "!"}}
test expr-4.11 {CompileLorExpr: error compiling land arms} {
list [catch {expr {"a"||0}} msg] $msg
} {1 {expected boolean value but got "a"}}
test expr-4.12 {CompileLorExpr: error compiling land arms} {
list [catch {expr {0||"a"}} msg] $msg
} {1 {expected boolean value but got "a"}}
|
| ︙ | ︙ | |||
294 295 296 297 298 299 300 |
expr 2***3|6
} -returnCodes error -match glob -result *
test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body {
expr 2^x
} -returnCodes error -match glob -result *
test expr-6.9 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {24.0^3}} msg] $msg
| | | | | | 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 |
expr 2***3|6
} -returnCodes error -match glob -result *
test expr-6.8 {CompileBitXorExpr: error compiling bitxor arm} -body {
expr 2^x
} -returnCodes error -match glob -result *
test expr-6.9 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {24.0^3}} msg] $msg
} {1 {can't use floating-point value as operand of "^"}}
test expr-6.10 {CompileBitXorExpr: runtime error in bitxor arm} {
list [catch {expr {"a"^"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "^"}}
test expr-7.1 {CompileBitAndExpr: just equality expr} {expr 3==2} 0
test expr-7.2 {CompileBitAndExpr: just equality expr} {expr 2.0==2} 1
test expr-7.3 {CompileBitAndExpr: just equality expr} {expr 3.2!=2.2} 1
test expr-7.4 {CompileBitAndExpr: just equality expr} {expr {"abc" == "abd"}} 0
test expr-7.5 {CompileBitAndExpr: error in equality expr} -body {
expr x==3
} -returnCodes error -match glob -result *
test expr-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3
test expr-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82
test expr-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2
test expr-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7
test expr-7.10 {CompileBitAndExpr: error compiling bitand arm} -body {
expr 2***3&6
} -returnCodes error -match glob -result *
test expr-7.11 {CompileBitAndExpr: error compiling bitand arm} -body {
expr 2&x
} -returnCodes error -match glob -result *
test expr-7.12 {CompileBitAndExpr: runtime error in bitand arm} {
list [catch {expr {24.0&3}} msg] $msg
} {1 {can't use floating-point value as operand of "&"}}
test expr-7.13 {CompileBitAndExpr: runtime error in bitand arm} {
list [catch {expr {"a"&"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "&"}}
test expr-7.14 {CompileBitAndExpr: equality expr} {expr 3eq2} 0
test expr-7.18 {CompileBitAndExpr: equality expr} {expr {"abc" eq "abd"}} 0
test expr-7.20 {CompileBitAndExpr: error in equality expr} -body {
expr xne3
} -returnCodes error -match glob -result *
test expr-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1
|
| ︙ | ︙ | |||
463 464 465 466 467 468 469 |
expr 2***3>>6
} -returnCodes error -match glob -result *
test expr-10.9 {CompileShiftExpr: error compiling shift arm} -body {
expr 2<<x
} -returnCodes error -match glob -result *
test expr-10.10 {CompileShiftExpr: runtime error} {
list [catch {expr {24.0>>43}} msg] $msg
| | | | | | 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 |
expr 2***3>>6
} -returnCodes error -match glob -result *
test expr-10.9 {CompileShiftExpr: error compiling shift arm} -body {
expr 2<<x
} -returnCodes error -match glob -result *
test expr-10.10 {CompileShiftExpr: runtime error} {
list [catch {expr {24.0>>43}} msg] $msg
} {1 {can't use floating-point value as operand of ">>"}}
test expr-10.11 {CompileShiftExpr: runtime error} {
list [catch {expr {"a"<<"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "<<"}}
test expr-11.1 {CompileAddExpr: just multiply expr} {expr 4*-2} -8
test expr-11.2 {CompileAddExpr: just multiply expr} {expr 0xff%2} 1
test expr-11.3 {CompileAddExpr: just multiply expr} {expr -1/2} -1
test expr-11.4 {CompileAddExpr: just multiply expr} {expr 7891%0o123} 6
test expr-11.5 {CompileAddExpr: error in multiply expr} -body {
expr x*3
} -returnCodes error -match glob -result *
test expr-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258
test expr-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239
test expr-11.8 {CompileAddExpr: error compiling add arm} -body {
expr 2***3+6
} -returnCodes error -match glob -result *
test expr-11.9 {CompileAddExpr: error compiling add arm} -body {
expr 2-x
} -returnCodes error -match glob -result *
test expr-11.10 {CompileAddExpr: runtime error} {
list [catch {expr {24.0+"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "+"}}
test expr-11.11 {CompileAddExpr: runtime error} {
list [catch {expr {"a"-"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "-"}}
test expr-11.12 {CompileAddExpr: runtime error} {
list [catch {expr {3/0}} msg] $msg
} {1 {divide by zero}}
test expr-11.13a {CompileAddExpr: runtime error} !ieeeFloatingPoint {
list [catch {expr {2.3/0.0}} msg] $msg
} {1 {divide by zero}}
test expr-11.13b {CompileAddExpr: runtime error} ieeeFloatingPoint {
|
| ︙ | ︙ | |||
516 517 518 519 520 521 522 |
expr 2*3%%6
} -returnCodes error -match glob -result *
test expr-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body {
expr 2*x
} -returnCodes error -match glob -result *
test expr-12.10 {CompileMultiplyExpr: runtime error} {
list [catch {expr {24.0*"xx"}} msg] $msg
| | | | | | 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 |
expr 2*3%%6
} -returnCodes error -match glob -result *
test expr-12.9 {CompileMultiplyExpr: error compiling multiply arm} -body {
expr 2*x
} -returnCodes error -match glob -result *
test expr-12.10 {CompileMultiplyExpr: runtime error} {
list [catch {expr {24.0*"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "*"}}
test expr-12.11 {CompileMultiplyExpr: runtime error} {
list [catch {expr {"a"/"b"}} msg] $msg
} {1 {can't use non-numeric string as operand of "/"}}
test expr-13.1 {CompileUnaryExpr: unary exprs} {expr -0xff} -255
test expr-13.2 {CompileUnaryExpr: unary exprs} {expr +0o00123} 83
test expr-13.3 {CompileUnaryExpr: unary exprs} {expr +--++36} 36
test expr-13.4 {CompileUnaryExpr: unary exprs} {expr !2} 0
test expr-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0
test expr-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1
test expr-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0
test expr-13.8 {CompileUnaryExpr: error compiling unary expr} -body {
expr ~x
} -returnCodes error -match glob -result *
test expr-13.9 {CompileUnaryExpr: error compiling unary expr} -body {
expr !1.x
} -returnCodes error -match glob -result *
test expr-13.10 {CompileUnaryExpr: runtime error} {
list [catch {expr {~"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "~"}}
test expr-13.11 {CompileUnaryExpr: runtime error} {
list [catch {expr ~4.0} msg] $msg
} {1 {can't use floating-point value as operand of "~"}}
test expr-13.12 {CompileUnaryExpr: just primary expr} {expr 0x123} 291
test expr-13.13 {CompileUnaryExpr: just primary expr} {
set a 27
expr $a
} 27
test expr-13.14 {CompileUnaryExpr: just primary expr} {
expr double(27)
|
| ︙ | ︙ | |||
724 725 726 727 728 729 730 |
# double, convert to double.
test expr-18.1 {expr and conversion of operands to numbers} {
set x [lindex 11 0]
catch {expr int($x)}
expr {$x}
} 11
| | | 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 |
# double, convert to double.
test expr-18.1 {expr and conversion of operands to numbers} {
set x [lindex 11 0]
catch {expr int($x)}
expr {$x}
} 11
test expr-18.2 {whitespace strings should not be == 0 (buggy strtol/strtoul)} {
expr {" "}
} { }
# Check "expr" and interpreter result object resetting before appending
# an error msg during evaluation of exprs not in {}s
test expr-19.1 {expr and interpreter result object resetting} {
|
| ︙ | ︙ | |||
816 817 818 819 820 821 822 |
test expr-21.11 {non-numeric boolean literals} {expr !no } 1
test expr-21.12 {non-numeric boolean literals} {expr !yes } 0
test expr-21.13 {non-numeric boolean literals} -body {
expr !truef
} -returnCodes error -match glob -result *
test expr-21.14 {non-numeric boolean literals} {
list [catch {expr !"truef"} err] $err
| | | | | | | | | | 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 |
test expr-21.11 {non-numeric boolean literals} {expr !no } 1
test expr-21.12 {non-numeric boolean literals} {expr !yes } 0
test expr-21.13 {non-numeric boolean literals} -body {
expr !truef
} -returnCodes error -match glob -result *
test expr-21.14 {non-numeric boolean literals} {
list [catch {expr !"truef"} err] $err
} {1 {can't use non-numeric string as operand of "!"}}
test expr-21.15 {non-numeric boolean variables} {
set v truef
list [catch {expr {!$v}} err] $err
} {1 {can't use non-numeric string as operand of "!"}}
test expr-21.16 {non-numeric boolean variables} {
set v "true "
list [catch {expr {!$v}} err] $err
} {1 {can't use non-numeric string as operand of "!"}}
test expr-21.17 {non-numeric boolean variables} {
set v "tru"
list [catch {expr {!$v}} err] $err
} {0 0}
test expr-21.18 {non-numeric boolean variables} {
set v "fal"
list [catch {expr {!$v}} err] $err
} {0 1}
test expr-21.19 {non-numeric boolean variables} {
set v "y"
list [catch {expr {!$v}} err] $err
} {0 0}
test expr-21.20 {non-numeric boolean variables} {
set v "of"
list [catch {expr {!$v}} err] $err
} {0 1}
test expr-21.21 {non-numeric boolean variables} {
set v "o"
list [catch {expr {!$v}} err] $err
} {1 {can't use non-numeric string as operand of "!"}}
test expr-21.22 {non-numeric boolean variables} {
set v ""
list [catch {expr {!$v}} err] $err
} {1 {can't use empty string as operand of "!"}}
# Test for non-numeric float handling.
test expr-22.1 {non-numeric floats} {
list [catch {expr {NaN + 1}} msg] $msg
} {1 {can't use non-numeric floating-point value as operand of "+"}}
test expr-22.2 {non-numeric floats} !ieeeFloatingPoint {
list [catch {expr {Inf + 1}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "+"}}
test expr-22.3 {non-numeric floats} {
set nan NaN
list [catch {expr {$nan + 1}} msg] $msg
} {1 {can't use non-numeric floating-point value as operand of "+"}}
test expr-22.4 {non-numeric floats} !ieeeFloatingPoint {
set inf Inf
list [catch {expr {$inf + 1}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "+"}}
test expr-22.5 {non-numeric floats} {
list [catch {expr NaN} msg] $msg
} {1 {domain error: argument not in valid range}}
test expr-22.6 {non-numeric floats} !ieeeFloatingPoint {
list [catch {expr Inf} msg] $msg
} {1 {floating-point value too large to represent}}
test expr-22.7 {non-numeric floats} {
list [catch {expr {1 / NaN}} msg] $msg
} {1 {can't use non-numeric floating-point value as operand of "/"}}
test expr-22.8 {non-numeric floats} !ieeeFloatingPoint {
list [catch {expr {1 / Inf}} msg] $msg
} {1 {can't use infinite floating-point value as operand of "/"}}
# Make sure [Bug 761471] stays fixed.
test expr-22.9 {non-numeric floats: shared object equality and NaN} {
set x NaN
expr {$x == $x}
|
| ︙ | ︙ | |||
909 910 911 912 913 914 915 |
expr (-3-)**6
} -returnCodes error -match glob -result *
test expr-23.8 {CompileExponentialExpr: error compiling expo arm} -body {
expr 2**x
} -returnCodes error -match glob -result *
test expr-23.9 {CompileExponentialExpr: runtime error} {
list [catch {expr {24.0**"xx"}} msg] $msg
| | | | 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 |
expr (-3-)**6
} -returnCodes error -match glob -result *
test expr-23.8 {CompileExponentialExpr: error compiling expo arm} -body {
expr 2**x
} -returnCodes error -match glob -result *
test expr-23.9 {CompileExponentialExpr: runtime error} {
list [catch {expr {24.0**"xx"}} msg] $msg
} {1 {can't use non-numeric string as operand of "**"}}
test expr-23.10 {CompileExponentialExpr: runtime error} {
list [catch {expr {"a"**2}} msg] $msg
} {1 {can't use non-numeric string as operand of "**"}}
test expr-23.11 {CompileExponentialExpr: runtime error} {
list [catch {expr {0**-1}} msg] $msg
} {1 {exponentiation of zero by negative power}}
test expr-23.12 {CompileExponentialExpr: runtime error} {
list [catch {expr {0.0**-1.0}} msg] $msg
} {1 {exponentiation of zero by negative power}}
test expr-23.13 {CompileExponentialExpr: runtime error} {
|
| ︙ | ︙ | |||
6816 6817 6818 6819 6820 6821 6822 6823 6824 6825 6826 6827 6828 6829 |
test expr-41.1 {exponent overflow} {
expr 1.0e2147483630
} Inf
test expr-41.2 {exponent underflow} {
expr 1.0e-2147483630
} 0.0
test expr-42.1 {denormals} ieeeFloatingPoint {
expr 7e-324
} 5e-324
# TIP 114
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 6817 6818 6819 6820 6821 6822 6823 6824 6825 6826 6827 6828 6829 6830 6831 6832 6833 6834 6835 6836 6837 6838 6839 6840 6841 6842 6843 6844 6845 6846 6847 6848 6849 6850 6851 6852 6853 6854 6855 6856 6857 6858 6859 6860 6861 6862 6863 6864 6865 6866 6867 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 6886 6887 6888 6889 6890 6891 6892 6893 6894 6895 6896 |
test expr-41.1 {exponent overflow} {
expr 1.0e2147483630
} Inf
test expr-41.2 {exponent underflow} {
expr 1.0e-2147483630
} 0.0
test expr-41.3 {exponent overflow} {
expr 1e2147483647
} Inf
test expr-41.4 {exponent overflow} {
expr 1e2147483648
} Inf
test expr-41.5 {exponent overflow} {
expr 100e2147483645
} Inf
test expr-41.6 {exponent overflow} {
expr 100e2147483646
} Inf
test expr-41.7 {exponent overflow} {
expr 1.0e2147483647
} Inf
test expr-41.8 {exponent overflow} {
expr 1.0e2147483648
} Inf
test expr-41.9 {exponent overflow} {
expr 1.2e2147483647
} Inf
test expr-41.10 {exponent overflow} {
expr 1.2e2147483648
} Inf
test expr-41.11 {exponent overflow} {
expr 1e-2147483648
} 0.0
test expr-41.12 {exponent overflow} {
expr 1e-2147483649
} 0.0
test expr-41.13 {exponent overflow} {
expr 100e-2147483650
} 0.0
test expr-41.14 {exponent overflow} {
expr 100e-2147483651
} 0.0
test expr-41.15 {exponent overflow} {
expr 1.0e-2147483648
} 0.0
test expr-41.16 {exponent overflow} {
expr 1.0e-2147483649
} 0.0
test expr-41.17 {exponent overflow} {
expr 1.23e-2147483646
} 0.0
test expr-41.18 {exponent overflow} {
expr 1.23e-2147483647
} 0.0
test expr-41.19 {numSigDigs == 0} {
expr 0e309
} 0.0
test expr-41.20 {numSigDigs == 0} {
expr 0e310
} 0.0
test expr-41.21 {negative zero, large exponent} {
expr -0e309
} -0.0
test expr-41.22 {negative zero, large exponent} {
expr -0e310
} -0.0
test expr-41.23 {floating point overflow on significand (Bug 1de6b0629e)} {
expr 123[string repeat 0 309]1e-310
} 123.0
test expr-42.1 {denormals} ieeeFloatingPoint {
expr 7e-324
} 5e-324
# TIP 114
|
| ︙ | ︙ |
Changes to tests/fCmd.test.
| ︙ | ︙ | |||
272 273 274 275 276 277 278 |
cleanup
} -constraints {notRoot} -returnCodes error -body {
file mkdir td1
file rename ~_totally_bogus_user td1
} -result {user "_totally_bogus_user" doesn't exist}
test fCmd-3.15 {FileCopyRename: source[0] == '\0'} -setup {
cleanup
| | | 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 |
cleanup
} -constraints {notRoot} -returnCodes error -body {
file mkdir td1
file rename ~_totally_bogus_user td1
} -result {user "_totally_bogus_user" doesn't exist}
test fCmd-3.15 {FileCopyRename: source[0] == '\0'} -setup {
cleanup
} -constraints {notRoot unixOrWin} -returnCodes error -body {
file mkdir td1
file rename / td1
} -result {error renaming "/" to "td1": file already exists}
test fCmd-3.16 {FileCopyRename: break on first error} -setup {
cleanup
} -constraints {notRoot} -returnCodes error -body {
createfile tf1
|
| ︙ | ︙ | |||
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
| | | 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 |
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} -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 {
|
| ︙ | ︙ | |||
1112 1113 1114 1115 1116 1117 1118 |
set a3 [catch {file copy -force tds2 tdd2}]
set a4 [catch {file copy -force tds3 tdd3}]
set a5 [catch {file copy -force tds4 tdd4}]
list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5
} -result [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}]
test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} -setup {
cleanup
| | | 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 |
set a3 [catch {file copy -force tds2 tdd2}]
set a4 [catch {file copy -force tds3 tdd3}]
set a5 [catch {file copy -force tds4 tdd4}]
list [lsort [glob td*]] $a1 $a2 $a3 $a4 $a5
} -result [subst {{td1 td2 tdd1 tdd2 tdd3 tdd4 tds1 tds2 tds3 tds4} {1 {error copying "td1" to "[file join td2 td1]": file already exists}} {1 {error copying "tds1" to "[file join tdd1 tds1]": file already exists}} 1 1 1}]
test fCmd-10.6 {file copy: comprehensive: dir to non-empty dir} -setup {
cleanup
} -constraints {notRoot unixOrWin testchmod} -body {
file mkdir tds1
file mkdir tds2
file mkdir [file join tdd1 tds1 xxx]
file mkdir [file join tdd2 tds2 xxx]
testchmod 0o555 tds2
set a1 [list [catch {file copy -force tds1 tdd1} msg] $msg]
set a2 [list [catch {file copy -force tds2 tdd2} msg] $msg]
|
| ︙ | ︙ |
Changes to tests/fileName.test.
| ︙ | ︙ | |||
1085 1086 1087 1088 1089 1090 1091 |
} -result {bad argument to "-types": abcde}
file rename $horribleglobname globTest
file delete -force $tildeglobname
set globname globTest
unset horribleglobname tildeglobname
| | | | | | 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 |
} -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} {
glob {}
} {.}
test filename-12.1.1 {simple globbing} -constraints {unixOrWin} -body {
glob -types f {}
} -returnCodes error -result {no files matched glob pattern ""}
test filename-12.1.2 {simple globbing} {unixOrWin} {
glob -types d {}
} {.}
test filename-12.1.3 {simple globbing} {unix} {
glob -types hidden {}
} {.}
test filename-12.1.4 {simple globbing} -constraints {win} -body {
glob -types hidden {}
} -returnCodes error -result {no files matched glob pattern ""}
test filename-12.1.5 {simple globbing} -constraints {win} -body {
glob -types hidden c:/
} -returnCodes error -result {no files matched glob pattern "c:/"}
test filename-12.1.6 {simple globbing} {win} {
glob c:/
} {c:/}
test filename-12.3 {simple globbing} {
glob -nocomplain \{a1,a2\}
} {}
set globPreResult globTest/
set x1 x1.c
set y1 y1.c
test filename-12.4 {simple globbing} {unixOrWin} {
lsort [glob globTest/x1.c globTest/y1.c globTest/foo]
} "$globPreResult$x1 $globPreResult$y1"
test filename-12.5 {simple globbing} {
glob globTest\\/x1.c
} "$globPreResult$x1"
test filename-12.6 {simple globbing} {
glob globTest\\/\\x1.c
|
| ︙ | ︙ | |||
1174 1175 1176 1177 1178 1179 1180 |
} "$globPreResult$x1"
test filename-13.9 {globbing with brace substitution} {
lsort [glob globTest/\{x,y\}1.c]
} [list $globPreResult$x1 $globPreResult$y1]
test filename-13.10 {globbing with brace substitution} {
lsort [glob globTest/\{x,,y\}1.c]
} [list $globPreResult$x1 $globPreResult$y1]
| | | | | | | | | | | | | | | 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 |
} "$globPreResult$x1"
test filename-13.9 {globbing with brace substitution} {
lsort [glob globTest/\{x,y\}1.c]
} [list $globPreResult$x1 $globPreResult$y1]
test filename-13.10 {globbing with brace substitution} {
lsort [glob globTest/\{x,,y\}1.c]
} [list $globPreResult$x1 $globPreResult$y1]
test filename-13.11 {globbing with brace substitution} {unixOrWin} {
lsort [glob globTest/\{x,x\\,z,z\}1.c]
} [lsort {globTest/x1.c globTest/x,z1.c globTest/z1.c}]
test filename-13.13 {globbing with brace substitution} {
lsort [glob globTest/{a,b,x,y}1.c]
} [list $globPreResult$x1 $globPreResult$y1]
test filename-13.14 {globbing with brace substitution} {unixOrWin} {
lsort [glob {globTest/{x1,y2,weird name}.c}]
} {{globTest/weird name.c} globTest/x1.c}
test filename-13.16 {globbing with brace substitution} {unixOrWin} {
lsort [glob globTest/{x1.c,a1/*}]
} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c}
test filename-13.18 {globbing with brace substitution} {unixOrWin} {
lsort [glob globTest/{x1.c,{a},a1/*}]
} {globTest/a1/b1 globTest/a1/b2 globTest/x1.c}
test filename-13.20 {globbing with brace substitution} {unixOrWin} {
lsort [glob globTest/{a,x}1/*/{x,y}*]
} {globTest/a1/b1/x2.c globTest/a1/b2/y2.c}
test filename-13.22 {globbing with brace substitution} -body {
glob globTest/\{a,x\}1/*/\{
} -returnCodes error -result {unmatched open-brace in file name}
test filename-14.1 {asterisks, question marks, and brackets} {unixOrWin} {
lsort [glob glo*/*.c]
} {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.3 {asterisks, question marks, and brackets} {unixOrWin} {
lsort [glob globTest/?1.c]
} {globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.5 {asterisks, question marks, and brackets} -setup {
# The current directory could be anywhere; do this to stop spurious
# matches
file mkdir globTestContext
file rename globTest [file join globTestContext globTest]
set savepwd [pwd]
cd globTestContext
} -constraints {unixOrWin} -body {
lsort [glob */*/*/*.c]
} -cleanup {
# Reset to where we were
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} {
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} {
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} {
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]
glob ~/z*
} -cleanup {
set env(HOME) $temp
} -result [list [file join $env(HOME) globTest z1.c]]
test filename-14.18 {asterisks, question marks, and brackets} {unixOrWin} {
lsort [glob globTest/*.c goo/*]
} {{globTest/weird name.c} globTest/x,z1.c globTest/x1.c globTest/y1.c globTest/z1.c}
test filename-14.20 {asterisks, question marks, and brackets} {
glob -nocomplain goo/*
} {}
test filename-14.21 {asterisks, question marks, and brackets} -body {
glob globTest/*/gorp
|
| ︙ | ︙ | |||
1283 1284 1285 1286 1287 1288 1289 |
[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.26 {type specific globbing} {
glob -nocomplain -dir globTest -types {readonly} *
} {}
| | | | | | 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 |
[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.26 {type specific globbing} {
glob -nocomplain -dir globTest -types {readonly} *
} {}
test filename-14.27 {Bug 2710920} {unixOrWin} {
file tail [lindex [lsort [glob globTest/*/]] 0]
} a1
test filename-14.28 {Bug 2710920} {unixOrWin} {
file dirname [lindex [lsort [glob globTest/*/]] 0]
} globTest
test filename-14.29 {Bug 2710920} {unixOrWin} {
file extension [lindex [lsort [glob globTest/*/]] 0]
} {}
test filename-14.30 {Bug 2710920} {unixOrWin} {
file rootname [lindex [lsort [glob globTest/*/]] 0]
} globTest/a1/
test filename-14.31 {Bug 2918610} -setup {
set d [makeDirectory foo]
makeFile {} bar.soom $d
} -body {
|
| ︙ | ︙ |
Changes to tests/fileSystem.test.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 37 38 39 40 41 42 43 |
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]]
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]
| > | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
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]]
testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
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]
|
| ︙ | ︙ | |||
308 309 310 311 312 313 314 |
} 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]
| | | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 |
} 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 knownMsvcBug} -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 {
|
| ︙ | ︙ |
Added tests/fileSystemEncoding.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
#! /usr/bin/env tclsh
# Copyright (c) 2019 Poor Yorick
if {[string equal $::tcl_platform(os) "Windows NT"]} {
return
}
namespace eval ::tcl::test::fileSystemEncoding {
package require tcltest 2
namespace import ::tcltest::*
variable fname1 \u767b\u9e1b\u9d72\u6a13
proc autopath {} {
global auto_path
set scriptpath [info script]
set scriptpathnorm [file dirname [file normalize $scriptpath/...]]
set dirnorm [file dirname $scriptpathnorm]
set idx [lsearch -exact $auto_path $dirnorm]
if {$idx >= 0} {
set auto_path [lreplace $auto_path[set auto_path {}] $idx $idx {}]
}
set auto_path [linsert $auto_path[set auto_path {}] 0 0 $dirnorm]
}
autopath
package require tcltests
test filesystemEncoding-1.0 {
issue bcd100410465
} -body {
set dir [tcltests::tempdir]
set saved [encoding system]
encoding system iso8859-1
set fname1a $dir/$fname1
set utf8name [encoding convertto utf-8 $fname1a]
makeFile {} $utf8name
set globbed [lindex [glob -directory $dir *] 0]
encoding system utf-8
set res [file exists $globbed]
encoding system iso8859-1
lappend res [file exists $globbed]
return $res
} -cleanup {
removeFile $utf8name
file delete -force $dir
encoding system $saved
} -result {0 1}
cleanupTests
}
|
Changes to tests/format.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
}
# %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}]
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}
| > | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
}
# %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}]
testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
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}
|
| ︙ | ︙ | |||
75 76 77 78 79 80 81 |
format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1
} {0 0o6 0o42 0o41033 0o1777777777777777777764}
test format-1.12 {integer formatting} {
format "%b %#b %#b %llb" 5 0 5 [expr {2**100}]
} {101 0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000}
test format-1.13 {integer formatting} {
format "%#0d %#0d %#0d %#0d %#0d" 0 6 34 16923 -12 -1
| | | | | 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 |
format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1
} {0 0o6 0o42 0o41033 0o1777777777777777777764}
test format-1.12 {integer formatting} {
format "%b %#b %#b %llb" 5 0 5 [expr {2**100}]
} {101 0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000}
test format-1.13 {integer formatting} {
format "%#0d %#0d %#0d %#0d %#0d" 0 6 34 16923 -12 -1
} {0 0d6 0d34 0d16923 -0d12}
test format-1.14 {integer formatting} {
format "%#05d %#020d %#020d %#020d %#020d" 0 6 34 16923 -12 -1
} {00000 0d000000000000000006 0d000000000000000034 0d000000000000016923 -0d00000000000000012}
test format-1.15 {integer formatting} {
format "%-#05d %-#020d %-#020d %-#020d %-#020d" 0 6 34 16923 -12 -1
} {00000 0d000000000000000006 0d000000000000000034 0d000000000000016923 -0d00000000000000012}
test format-2.1 {string formatting} {
format "%s %s %c %s" abcd {This is a very long test string.} 120 x
} {abcd This is a very long test string. x x}
test format-2.2 {string formatting} {
format "%20s %20s %20c %20s" abcd {This is a very long test string.} 120 x
|
| ︙ | ︙ | |||
259 260 261 262 263 264 265 |
test format-6.1 {floating-point zeroes} {eformat} {
format "%e %f %g" 0.0 0.0 0.0 0.0
} {0.000000e+00 0.000000 0}
test format-6.2 {floating-point zeroes} {eformat} {
format "%.4e %.4f %.4g" 0.0 0.0 0.0 0.0
} {0.0000e+00 0.0000 0}
| | | | 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 |
test format-6.1 {floating-point zeroes} {eformat} {
format "%e %f %g" 0.0 0.0 0.0 0.0
} {0.000000e+00 0.000000 0}
test format-6.2 {floating-point zeroes} {eformat} {
format "%.4e %.4f %.4g" 0.0 0.0 0.0 0.0
} {0.0000e+00 0.0000 0}
test format-6.3 {floating-point zeroes} {eformat knownMsvcBug} {
format "%#.4e %#.4f %#.4g" 0.0 0.0 0.0 0.0
} {0.0000e+00 0.0000 0.000}
test format-6.4 {floating-point zeroes} {eformat} {
format "%.0e %.0f %.0g" 0.0 0.0 0.0 0.0
} {0e+00 0 0}
test format-6.5 {floating-point zeroes} {eformat knownMsvcBug} {
format "%#.0e %#.0f %#.0g" 0.0 0.0 0.0 0.0
} {0.e+00 0. 0.}
test format-6.6 {floating-point zeroes} {
format "%3.0f %3.0f %3.0f %3.0f" 0.0 0.0 0.0 0.0
} { 0 0 0 0}
test format-6.7 {floating-point zeroes} {
format "%3.0f %3.0f %3.0f %3.0f" 1.0 1.1 1.01 1.001
|
| ︙ | ︙ |
Changes to tests/get.test.
| ︙ | ︙ | |||
94 95 96 97 98 99 100 |
foreach num $numbers {
lappend result [catch {format %g $num} msg] $msg
}
set result
} {0 1 0 1 1 {expected floating-point number but got "++1.0"} 1 {expected floating-point number but got "+-1.0"} 1 {expected floating-point number but got "-+1.0"} 0 -1 1 {expected floating-point number but got "--1.0"} 1 {expected floating-point number but got "- +1.0"}}
# Bug 7114ac6141
test get-3.3 {tcl_GetInt with iffy numbers} testgetint {
| | | | | > > > > > > | 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 |
foreach num $numbers {
lappend result [catch {format %g $num} msg] $msg
}
set result
} {0 1 0 1 1 {expected floating-point number but got "++1.0"} 1 {expected floating-point number but got "+-1.0"} 1 {expected floating-point number but got "-+1.0"} 0 -1 1 {expected floating-point number but got "--1.0"} 1 {expected floating-point number but got "- +1.0"}}
# Bug 7114ac6141
test get-3.3 {tcl_GetInt with iffy numbers} testgetint {
lmap x {0 " 0" "0 " " 0 " " 0xa " " 007 " " 0o10 " " 0b10 "} {
catch {testgetint 44 $x} x
set x
}
} {44 44 44 44 54 51 52 46}
test get-3.4 {Tcl_GetDouble with iffy numbers} testdoubleobj {
lmap x {0 0.0 " .0" ".0 " " 0e0 " "07" "- 0" "-0" "0o12" "0b10"} {
catch {testdoubleobj set 1 $x} x
set x
}
} {0.0 0.0 0.0 0.0 0.0 7.0 {expected floating-point number but got "- 0"} 0.0 10.0 2.0}
test get-3.5 {tcl_GetInt with numeric whitespace (i.e. '_')} testgetint {
lmap x {0_0 " 1_0" "0_2 " " 3_3 " 14__23__32___4 " 0x_a " " 0_07 " " 0o_1_0 " " 0_b1_0 " _33 42_ 0_x15 0_o17 0_d19 } {
catch {testgetint $x} x
set x
}
} {0 10 2 33 1423324 10 7 8 {expected integer but got " 0_b1_0 "} {expected integer but got "_33"} {expected integer but got "42_"} {expected integer but got "0_x15"} {expected integer but got "0_o17"} {expected integer but got "0_d19"}}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
|
| ︙ | ︙ |
Changes to tests/http.test.
| ︙ | ︙ | |||
182 183 184 185 186 187 188 |
} -cleanup {
http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"
test http-3.8 {http::geturl} -body {
| | | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 |
} -cleanup {
http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>GET $tail</h2>
</body></html>"
test http-3.8 {http::geturl} -body {
set token [http::geturl $url -query Name=Value&Foo=Bar -timeout 3000]
http::data $token
} -cleanup {
http::cleanup $token
} -result "<html><head><title>HTTP/1.0 TEST</title></head><body>
<h1>Hello, World!</h1>
<h2>POST $tail</h2>
<h2>Query</h2>
|
| ︙ | ︙ | |||
348 349 350 351 352 353 354 |
} -returnCodes error -result {Illegal characters in URL path}
test http-3.24 {http::geturl parse failures} -body {
http::geturl http://somewhere/path?%query
} -returnCodes error -result {Illegal encoding character usage "%qu" in URL path}
test http-3.25 {http::meta} -setup {
unset -nocomplain m token
} -body {
| | | | 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 |
} -returnCodes error -result {Illegal characters in URL path}
test http-3.24 {http::geturl parse failures} -body {
http::geturl http://somewhere/path?%query
} -returnCodes error -result {Illegal encoding character usage "%qu" in URL path}
test http-3.25 {http::meta} -setup {
unset -nocomplain m token
} -body {
set token [http::geturl $url -timeout 3000]
array set m [http::meta $token]
lsort [array names m]
} -cleanup {
http::cleanup $token
unset -nocomplain m token
} -result {Content-Length Content-Type Date}
test http-3.26 {http::meta} -setup {
unset -nocomplain m token
} -body {
set token [http::geturl $url -headers {X-Check 1} -timeout 3000]
array set m [http::meta $token]
lsort [array names m]
} -cleanup {
http::cleanup $token
unset -nocomplain m token
} -result {Content-Length Content-Type Date X-Check}
test http-3.27 {http::geturl: -headers override -type} -body {
|
| ︙ | ︙ | |||
584 585 586 587 588 589 590 |
} -cleanup {
catch {http::cleanup $token}
} -result {connect failed connection refused}
# Bogus host
test http-4.15 {http::Event} -body {
# This test may fail if you use a proxy server. That is to be
# expected and is not a problem with Tcl.
| | | 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 |
} -cleanup {
catch {http::cleanup $token}
} -result {connect failed connection refused}
# Bogus host
test http-4.15 {http::Event} -body {
# This test may fail if you use a proxy server. That is to be
# expected and is not a problem with Tcl.
set token [http::geturl //not_a_host.tcl.tk -timeout 3000 -command \#]
http::wait $token
http::status $token
# error codes vary among platforms.
} -cleanup {
catch {http::cleanup $token}
} -returnCodes 1 -match glob -result "couldn't open socket*"
test http-4.16 {Leak with Close vs Keepalive (bug [6ca52aec14]} -setup {
|
| ︙ | ︙ | |||
666 667 668 669 670 671 672 |
# (unknown chars become '?')
http::config -urlencoding "iso8859-1"
http::mapReply "\u2208"
} -cleanup {
http::config -urlencoding $enc
} -result {%3F}
| | | | 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 |
# (unknown chars become '?')
http::config -urlencoding "iso8859-1"
http::mapReply "\u2208"
} -cleanup {
http::config -urlencoding $enc
} -result {%3F}
package require tcl::idna 1.0
test http-idna-1.1 {IDNA package: basics} -returnCodes error -body {
::tcl::idna
} -result {wrong # args: should be "::tcl::idna subcommand ?arg ...?"}
test http-idna-1.2 {IDNA package: basics} -returnCodes error -body {
::tcl::idna ?
} -result {unknown or ambiguous subcommand "?": must be decode, encode, puny, or version}
test http-idna-1.3 {IDNA package: basics} -body {
::tcl::idna version
} -result 1.0.1
test http-idna-1.4 {IDNA package: basics} -returnCodes error -body {
::tcl::idna version what
} -result {wrong # args: should be "::tcl::idna version"}
test http-idna-1.5 {IDNA package: basics} -returnCodes error -body {
::tcl::idna puny
} -result {wrong # args: should be "::tcl::idna puny subcommand ?arg ...?"}
test http-idna-1.6 {IDNA package: basics} -returnCodes error -body {
|
| ︙ | ︙ |
Changes to tests/httpcookie.test.
| ︙ | ︙ | |||
21 22 23 24 25 26 27 |
testConstraint sqlite3 [expr {[testConstraint notOSXtravis] && ![catch {
package require sqlite3
}]}]
testConstraint cookiejar [expr {[testConstraint sqlite3] && ![catch {
package require cookiejar
}]}]
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 |
testConstraint sqlite3 [expr {[testConstraint notOSXtravis] && ![catch {
package require sqlite3
}]}]
testConstraint cookiejar [expr {[testConstraint sqlite3] && ![catch {
package require cookiejar
}]}]
set COOKIEJAR_VERSION 0.2.0
test http-cookiejar-1.1 "cookie storage: packaging" {cookiejar} {
package require cookiejar
} $COOKIEJAR_VERSION
test http-cookiejar-1.2 "cookie storage: packaging" {cookiejar} {
package require cookiejar
package require cookiejar
} $COOKIEJAR_VERSION
test http-cookiejar-2.1 "cookie storage: basics" -constraints {
cookiejar
} -returnCodes error -body {
http::cookiejar
} -result {wrong # args: should be "http::cookiejar method ?arg ...?"}
test http-cookiejar-2.2 "cookie storage: basics" -constraints {
cookiejar
} -returnCodes error -body {
http::cookiejar ?
} -result {unknown method "?": must be configure, create, destroy or new}
test http-cookiejar-2.3 "cookie storage: basics" -constraints {
cookiejar
} -body {
http::cookiejar configure
} -result {-domainfile -domainlist -domainrefresh -loglevel -offline -purgeold -retain -vacuumtrigger}
test http-cookiejar-2.4 "cookie storage: basics" -constraints {
cookiejar
} -returnCodes error -body {
http::cookiejar configure a b c d e
} -result {wrong # args: should be "http::cookiejar configure ?optionName? ?optionValue?"}
test http-cookiejar-2.5 "cookie storage: basics" -constraints {
cookiejar
} -returnCodes error -body {
http::cookiejar configure a
} -result {bad option "a": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger}
test http-cookiejar-2.6 "cookie storage: basics" -constraints {
cookiejar
} -returnCodes error -body {
http::cookiejar configure -d
} -result {ambiguous option "-d": must be -domainfile, -domainlist, -domainrefresh, -loglevel, -offline, -purgeold, -retain, or -vacuumtrigger}
test http-cookiejar-2.7 "cookie storage: basics" -setup {
set old [http::cookiejar configure -loglevel]
} -constraints {cookiejar} -body {
list [http::cookiejar configure -loglevel] \
[http::cookiejar configure -loglevel debug] \
[http::cookiejar configure -loglevel] \
[http::cookiejar configure -loglevel error] \
[http::cookiejar configure -loglevel]
} -cleanup {
http::cookiejar configure -loglevel $old
} -result {info debug debug error error}
test http-cookiejar-2.8 "cookie storage: basics" -setup {
set old [http::cookiejar configure -loglevel]
} -constraints {cookiejar} -body {
list [http::cookiejar configure -loglevel] \
[http::cookiejar configure -loglevel d] \
[http::cookiejar configure -loglevel i] \
[http::cookiejar configure -loglevel w] \
[http::cookiejar configure -loglevel e]
} -cleanup {
http::cookiejar configure -loglevel $old
} -result {info debug info warn error}
test http-cookiejar-2.9 "cookie storage: basics" -body {
http::cookiejar configure -off
} -constraints {cookiejar} -match glob -result *
test http-cookiejar-2.10 "cookie storage: basics" -setup {
set oldval [http::cookiejar configure -offline]
} -constraints {cookiejar} -body {
http::cookiejar configure -offline true
} -cleanup {
catch {http::cookiejar configure -offline $oldval}
} -result 1
test http-cookiejar-2.11 "cookie storage: basics" -setup {
set oldval [http::cookiejar configure -offline]
} -constraints {cookiejar} -body {
http::cookiejar configure -offline nonbool
} -cleanup {
catch {http::cookiejar configure -offline $oldval}
} -returnCodes error -result {expected boolean value but got "nonbool"}
test http-cookiejar-2.12 "cookie storage: basics" -setup {
set oldval [http::cookiejar configure -purgeold]
} -constraints {cookiejar} -body {
http::cookiejar configure -purge nonint
} -cleanup {
catch {http::cookiejar configure -purgeold $oldval}
} -returnCodes error -result {expected positive integer but got "nonint"}
test http-cookiejar-2.13 "cookie storage: basics" -setup {
set oldval [http::cookiejar configure -domainrefresh]
} -constraints {cookiejar} -body {
http::cookiejar configure -domainref nonint
} -cleanup {
catch {http::cookiejar configure -domainrefresh $oldval}
} -returnCodes error -result {expected positive integer but got "nonint"}
test http-cookiejar-2.14 "cookie storage: basics" -setup {
set oldval [http::cookiejar configure -domainrefresh]
} -constraints {cookiejar} -body {
http::cookiejar configure -domainref -42
} -cleanup {
catch {http::cookiejar configure -domainrefresh $oldval}
} -returnCodes error -result {expected positive integer but got "-42"}
test http-cookiejar-2.15 "cookie storage: basics" -setup {
set oldval [http::cookiejar configure -domainrefresh]
set result unset
set tracer [http::cookiejar create tracer]
} -constraints {cookiejar} -body {
oo::objdefine $tracer method PostponeRefresh {} {
set ::result set
next
}
http::cookiejar configure -domainref 12345
return $result
} -cleanup {
$tracer destroy
catch {http::cookiejar configure -domainrefresh $oldval}
} -result set
test http-cookiejar-3.1 "cookie storage: class" {cookiejar} {
info object isa object http::cookiejar
} 1
test http-cookiejar-3.2 "cookie storage: class" {cookiejar} {
info object isa class http::cookiejar
} 1
test http-cookiejar-3.3 "cookie storage: class" {cookiejar} {
lsort [info object methods http::cookiejar]
} {configure}
test http-cookiejar-3.4 "cookie storage: class" {cookiejar} {
lsort [info object methods http::cookiejar -all]
} {configure create destroy new}
test http-cookiejar-3.5 "cookie storage: class" -setup {
catch {rename ::cookiejar ""}
} -constraints {cookiejar} -body {
namespace eval :: {http::cookiejar create cookiejar}
} -cleanup {
catch {rename ::cookiejar ""}
} -result ::cookiejar
test http-cookiejar-3.6 "cookie storage: class" -setup {
catch {rename ::cookiejar ""}
} -constraints {cookiejar} -body {
list [http::cookiejar create ::cookiejar] [info commands ::cookiejar] \
[::cookiejar destroy] [info commands ::cookiejar]
} -cleanup {
catch {rename ::cookiejar ""}
} -result {::cookiejar ::cookiejar {} {}}
test http-cookiejar-3.7 "cookie storage: class" -setup {
catch {rename ::cookiejar ""}
} -constraints {cookiejar} -body {
http::cookiejar create ::cookiejar foo bar
} -returnCodes error -cleanup {
catch {rename ::cookiejar ""}
} -result {wrong # args: should be "http::cookiejar create ::cookiejar ?path?"}
test http-cookiejar-3.8 "cookie storage: class" -setup {
catch {rename ::cookiejar ""}
set f [makeFile "" cookiejar]
file delete $f
} -constraints {cookiejar} -body {
list [file exists $f] [http::cookiejar create ::cookiejar $f] \
[file exists $f]
} -cleanup {
catch {rename ::cookiejar ""}
removeFile $f
} -result {0 ::cookiejar 1}
test http-cookiejar-3.9 "cookie storage: class" -setup {
catch {rename ::cookiejar ""}
set f [makeFile "bogus content for a database" cookiejar]
} -constraints {cookiejar} -body {
http::cookiejar create ::cookiejar $f
} -returnCodes error -cleanup {
catch {rename ::cookiejar ""}
removeFile $f
} -match glob -result *
test http-cookiejar-3.10 "cookie storage: class" -setup {
catch {rename ::cookiejar ""}
set dir [makeDirectory cookiejar]
} -constraints {cookiejar} -body {
http::cookiejar create ::cookiejar $dir
} -returnCodes error -cleanup {
catch {rename ::cookiejar ""}
removeDirectory $dir
} -match glob -result *
test http-cookiejar-4.1 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
} -constraints {cookiejar} -body {
cookiejar
} -returnCodes error -cleanup {
::cookiejar destroy
} -result {wrong # args: should be "cookiejar method ?arg ...?"}
test http-cookiejar-4.2 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
} -constraints {cookiejar} -body {
cookiejar ?
} -returnCodes error -cleanup {
::cookiejar destroy
} -result {unknown method "?": must be destroy, forceLoadDomainData, getCookies, lookup, policyAllow or storeCookie}
test http-cookiejar-4.3 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
} -constraints {cookiejar} -body {
lsort [info object methods cookiejar -all]
} -cleanup {
::cookiejar destroy
} -result {destroy forceLoadDomainData getCookies lookup policyAllow storeCookie}
test http-cookiejar-4.4 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
} -constraints {cookiejar} -body {
cookiejar getCookies
} -returnCodes error -cleanup {
::cookiejar destroy
} -result {wrong # args: should be "cookiejar getCookies proto host path"}
test http-cookiejar-4.5 "cookie storage" -setup {
http::cookiejar create ::cookiejar
} -constraints {cookiejar} -body {
cookiejar getCookies http www.example.com /
} -cleanup {
::cookiejar destroy
} -result {}
test http-cookiejar-4.6 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
} -constraints {cookiejar} -body {
cookiejar storeCookie
} -returnCodes error -cleanup {
::cookiejar destroy
} -result {wrong # args: should be "cookiejar storeCookie options"}
test http-cookiejar-4.7 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
} -constraints {cookiejar} -body {
cookiejar storeCookie {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
}
} -cleanup {
::cookiejar destroy
} -result {}
test http-cookiejar-4.8 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
oo::objdefine ::cookiejar export Database
} -constraints {cookiejar} -body {
cookiejar storeCookie {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
}
# Poke inside implementation!
cookiejar Database eval {SELECT count(*) FROM sessionCookies}
} -cleanup {
::cookiejar destroy
} -result 1
test http-cookiejar-4.9 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
oo::objdefine ::cookiejar export Database
} -constraints {cookiejar} -body {
cookiejar storeCookie {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
}
# Poke inside implementation!
cookiejar Database eval {SELECT count(*) FROM persistentCookies}
} -cleanup {
::cookiejar destroy
} -result 0
test http-cookiejar-4.10 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
} -constraints {cookiejar} -body {
cookiejar storeCookie [dict replace {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
} expires [expr {[clock seconds]+5}]]
} -cleanup {
::cookiejar destroy
} -result {}
test http-cookiejar-4.11 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
oo::objdefine ::cookiejar export Database
} -constraints {cookiejar} -body {
cookiejar storeCookie [dict replace {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
} expires [expr {[clock seconds]+5}]]
# Poke inside implementation!
cookiejar Database eval {SELECT count(*) FROM sessionCookies}
} -cleanup {
::cookiejar destroy
} -result 0
test http-cookiejar-4.12 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
oo::objdefine ::cookiejar export Database
} -constraints {cookiejar} -body {
cookiejar storeCookie [dict replace {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
} expires [expr {[clock seconds]+5}]]
# Poke inside implementation!
cookiejar Database eval {SELECT count(*) FROM persistentCookies}
} -cleanup {
::cookiejar destroy
} -result 1
test http-cookiejar-4.13 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
} -constraints {cookiejar} -body {
lappend result [cookiejar getCookies http www.example.com /]
cookiejar storeCookie {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
}
lappend result [cookiejar getCookies http www.example.com /]
} -cleanup {
::cookiejar destroy
} -result {{} {foo bar}}
test http-cookiejar-4.14 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
} -constraints {cookiejar} -body {
lappend result [cookiejar getCookies http www.example.com /]
cookiejar storeCookie [dict replace {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
path /
hostonly 1
} expires [expr {[clock seconds]+5}]]
lappend result [cookiejar getCookies http www.example.com /]
} -cleanup {
::cookiejar destroy
} -result {{} {foo bar}}
test http-cookiejar-4.15 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
} -constraints {cookiejar} -body {
lappend result [cookiejar getCookies http www.example.com /]
cookiejar storeCookie {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
|
| ︙ | ︙ | |||
410 411 412 413 414 415 416 |
lappend result [cookiejar getCookies http www.example.com /]
} -cleanup {
::cookiejar destroy
} -result {{} {foo bar}}
test http-cookiejar-4.16 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
| | | 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 |
lappend result [cookiejar getCookies http www.example.com /]
} -cleanup {
::cookiejar destroy
} -result {{} {foo bar}}
test http-cookiejar-4.16 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
} -constraints {cookiejar} -body {
lappend result [cookiejar getCookies http www.example.com /]
cookiejar storeCookie {
key foo1
value bar
secure 0
domain www.example.com
origin www.example.com
|
| ︙ | ︙ | |||
436 437 438 439 440 441 442 |
} expires [expr {[clock seconds]+5}]]
lappend result [lsort -stride 2 [cookiejar getCookies http www.example.com /]]
} -cleanup {
::cookiejar destroy
} -result {{} {foo1 bar foo2 bar}}
test http-cookiejar-4.17 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
| | | | 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 |
} expires [expr {[clock seconds]+5}]]
lappend result [lsort -stride 2 [cookiejar getCookies http www.example.com /]]
} -cleanup {
::cookiejar destroy
} -result {{} {foo1 bar foo2 bar}}
test http-cookiejar-4.17 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
} -constraints {cookiejar} -body {
cookiejar lookup a b c d
} -returnCodes error -cleanup {
::cookiejar destroy
} -result {wrong # args: should be "cookiejar lookup ?host? ?key?"}
test http-cookiejar-4.18 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
} -constraints {cookiejar} -body {
lappend result [cookiejar lookup]
lappend result [cookiejar lookup www.example.com]
lappend result [catch {cookiejar lookup www.example.com foo} value] $value
cookiejar storeCookie {
key foo
value bar
secure 0
|
| ︙ | ︙ | |||
466 467 468 469 470 471 472 |
lappend result [cookiejar lookup www.example.com foo]
} -cleanup {
::cookiejar destroy
} -result {{} {} 1 {no such key for that host} www.example.com foo bar}
test http-cookiejar-4.19 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
| | | 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 |
lappend result [cookiejar lookup www.example.com foo]
} -cleanup {
::cookiejar destroy
} -result {{} {} 1 {no such key for that host} www.example.com foo bar}
test http-cookiejar-4.19 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
} -constraints {cookiejar} -body {
cookiejar storeCookie {
key foo
value bar
secure 0
domain www.example.com
origin www.example.com
path /
|
| ︙ | ︙ | |||
496 497 498 499 500 501 502 |
lappend result [cookiejar lookup www.example.org bar]
} -cleanup {
::cookiejar destroy
} -result {{www.example.com www.example.org} foo bar bar foo}
test http-cookiejar-4.20 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
| | | 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 |
lappend result [cookiejar lookup www.example.org bar]
} -cleanup {
::cookiejar destroy
} -result {{www.example.com www.example.org} foo bar bar foo}
test http-cookiejar-4.20 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
} -constraints {cookiejar} -body {
cookiejar storeCookie {
key foo1
value bar1
secure 0
domain www.example.com
origin www.example.com
path /
|
| ︙ | ︙ | |||
525 526 527 528 529 530 531 |
lappend result [cookiejar lookup www.example.com foo2]
} -cleanup {
::cookiejar destroy
} -result {www.example.com {foo1 foo2} bar1 bar2}
test http-cookiejar-4.21 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
| | | 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 |
lappend result [cookiejar lookup www.example.com foo2]
} -cleanup {
::cookiejar destroy
} -result {www.example.com {foo1 foo2} bar1 bar2}
test http-cookiejar-4.21 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
} -constraints {cookiejar} -body {
cookiejar storeCookie {
key foo1
value bar1
secure 0
domain www.example.com
origin www.example.com
path /
|
| ︙ | ︙ | |||
554 555 556 557 558 559 560 |
lappend result [cookiejar lookup www.example.com foo2]
} -cleanup {
::cookiejar destroy
} -result {www.example.com {foo1 foo2} bar1 bar2}
test http-cookiejar-4.22 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
| | | | | | | | | 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 |
lappend result [cookiejar lookup www.example.com foo2]
} -cleanup {
::cookiejar destroy
} -result {www.example.com {foo1 foo2} bar1 bar2}
test http-cookiejar-4.22 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
} -constraints {cookiejar} -body {
cookiejar forceLoadDomainData x y z
} -returnCodes error -cleanup {
::cookiejar destroy
} -result {wrong # args: should be "cookiejar forceLoadDomainData"}
test http-cookiejar-4.23 "cookie storage: instance" -setup {
http::cookiejar create ::cookiejar
set result {}
} -constraints {cookiejar} -body {
cookiejar forceLoadDomainData
} -cleanup {
::cookiejar destroy
} -result {}
test http-cookiejar-4.23.a {cookie storage: instance} -setup {
set off [http::cookiejar configure -offline]
} -constraints {cookiejar} -body {
http::cookiejar configure -offline 1
[http::cookiejar create ::cookiejar] destroy
} -cleanup {
catch {::cookiejar destroy}
http::cookiejar configure -offline $off
} -result {}
test http-cookiejar-4.23.b {cookie storage: instance} -setup {
set off [http::cookiejar configure -offline]
} -constraints {cookiejar} -body {
http::cookiejar configure -offline 0
[http::cookiejar create ::cookiejar] destroy
} -cleanup {
catch {::cookiejar destroy}
http::cookiejar configure -offline $off
} -result {}
test http-cookiejar-5.1 "cookie storage: constraints" -setup {
http::cookiejar create ::cookiejar
cookiejar forceLoadDomainData
} -constraints {cookiejar} -body {
cookiejar storeCookie {
key foo
value bar
secure 0
domain com
origin com
path /
hostonly 1
}
cookiejar lookup
} -cleanup {
::cookiejar destroy
} -result {}
test http-cookiejar-5.2 "cookie storage: constraints" -setup {
http::cookiejar create ::cookiejar
cookiejar forceLoadDomainData
} -constraints {cookiejar} -body {
cookiejar storeCookie {
key foo
value bar
secure 0
domain foo.example.com
origin bar.example.org
path /
hostonly 1
}
cookiejar lookup
} -cleanup {
::cookiejar destroy
} -result {}
test http-cookiejar-5.3 "cookie storage: constraints" -setup {
http::cookiejar create ::cookiejar
cookiejar forceLoadDomainData
} -constraints {cookiejar} -body {
cookiejar storeCookie {
key foo1
value bar
secure 0
domain com
origin www.example.com
path /
|
| ︙ | ︙ | |||
649 650 651 652 653 654 655 |
cookiejar lookup
} -cleanup {
::cookiejar destroy
} -result {example.com}
test http-cookiejar-5.4 "cookie storage: constraints" -setup {
http::cookiejar create ::cookiejar
cookiejar forceLoadDomainData
| | | 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 |
cookiejar lookup
} -cleanup {
::cookiejar destroy
} -result {example.com}
test http-cookiejar-5.4 "cookie storage: constraints" -setup {
http::cookiejar create ::cookiejar
cookiejar forceLoadDomainData
} -constraints {cookiejar} -body {
cookiejar storeCookie {
key foo
value bar1
secure 0
domain www.example.com
origin www.example.com
path /
|
| ︙ | ︙ | |||
675 676 677 678 679 680 681 |
lsort [cookiejar lookup]
} -cleanup {
::cookiejar destroy
} -result {example.com www.example.com}
test http-cookiejar-5.5 "cookie storage: constraints" -setup {
http::cookiejar create ::cookiejar
cookiejar forceLoadDomainData
| | | 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 |
lsort [cookiejar lookup]
} -cleanup {
::cookiejar destroy
} -result {example.com www.example.com}
test http-cookiejar-5.5 "cookie storage: constraints" -setup {
http::cookiejar create ::cookiejar
cookiejar forceLoadDomainData
} -constraints {cookiejar} -body {
cookiejar storeCookie {
key foo1
value 1
secure 0
domain com
origin www.example.com
path /
|
| ︙ | ︙ | |||
773 774 775 776 777 778 779 |
http::cookiejar create ::cookiejar
oo::objdefine cookiejar export PurgeCookies
set result {}
proc values cookies {
global result
lappend result [lsort [lmap {k v} $cookies {set v}]]
}
| | | 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 |
http::cookiejar create ::cookiejar
oo::objdefine cookiejar export PurgeCookies
set result {}
proc values cookies {
global result
lappend result [lsort [lmap {k v} $cookies {set v}]]
}
} -constraints {cookiejar} -body {
values [cookiejar getCookies http www.example.com /]
cookiejar storeCookie {
key foo
value session
secure 0
domain www.example.com
origin www.example.com
|
| ︙ | ︙ | |||
829 830 831 832 833 834 835 |
::cookiejar destroy
} -result {{} session cookie {cookie session-global} {cookie session-global} session-global {}}
test http-cookiejar-7.1 "cookie storage: persistence of persistent cookies" -setup {
catch {rename ::cookiejar ""}
set f [makeFile "" cookiejar]
file delete $f
| | | | 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 |
::cookiejar destroy
} -result {{} session cookie {cookie session-global} {cookie session-global} session-global {}}
test http-cookiejar-7.1 "cookie storage: persistence of persistent cookies" -setup {
catch {rename ::cookiejar ""}
set f [makeFile "" cookiejar]
file delete $f
} -constraints {cookiejar} -body {
http::cookiejar create ::cookiejar $f
::cookiejar destroy
http::cookiejar create ::cookiejar $f
} -cleanup {
catch {rename ::cookiejar ""}
removeFile $f
} -result ::cookiejar
test http-cookiejar-7.2 "cookie storage: persistence of persistent cookies" -setup {
catch {rename ::cookiejar ""}
set f [makeFile "" cookiejar]
file delete $f
set result {}
} -constraints {cookiejar} -body {
http::cookiejar create ::cookiejar $f
cookiejar storeCookie [dict replace {
key foo
value cookie
secure 0
domain www.example.com
origin www.example.com
|
| ︙ | ︙ |
Changes to tests/init.test.
| ︙ | ︙ | |||
14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
package require tcltest 2.3.4
namespace import -force ::tcltest::*
}
# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}
# Six cases - white box testing
test init-1.1 {auto_qualify - absolute cmd - namespace} {
auto_qualify ::foo::bar ::blue
} ::foo::bar
test init-1.2 {auto_qualify - absolute cmd - global} {
auto_qualify ::global ::sub
| > > > > > > > > > > > > > | 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 |
package require tcltest 2.3.4
namespace import -force ::tcltest::*
}
# Clear out any namespaces called test_ns_*
catch {namespace delete {*}[namespace children :: test_ns_*]}
test init-0.1 {no error on initialization phase (init.tcl)} -setup {
interp create slave
} -body {
slave eval {
list [set v [info exists ::errorInfo]] \
[if {$v} {set ::errorInfo}] \
[set v [info exists ::errorCode]] \
[if {$v} {set ::errorCode}]
}
} -cleanup {
interp delete slave
} -result {0 {} 0 {}}
# Six cases - white box testing
test init-1.1 {auto_qualify - absolute cmd - namespace} {
auto_qualify ::foo::bar ::blue
} ::foo::bar
test init-1.2 {auto_qualify - absolute cmd - global} {
auto_qualify ::global ::sub
|
| ︙ | ︙ |
Added tests/internals.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 |
# 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 (c) 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
::tcltest::ConstraintInitializer testWithLimit { expr {[testConstraint macOrUnix] && ![catch { exec prlimit --version }]} }
# test-with-limit --
#
# Usage: test-with-limit ?-addmem bytes? ?-maxmem bytes? command
# Options:
# -addmem - set additional memory limit (in bytes) as difference (extra memory needed to run a test)
# -maxmem - set absolute maximum address space limit (in bytes)
#
proc testWithLimit args {
set body [lindex $args end]
array set in [lrange $args 0 end-1]
# test in child process (with limits):
set pipe {}
if {[catch {
# start new process:
set pipe [open |[list [interpreter]] r+]
set ppid [pid $pipe]
# create prlimit args:
set args {}
# with limited address space:
if {[info exists in(-addmem)] || [info exists in(-maxmem)]} {
if {[info exists in(-addmem)]} {
# as differnce to normal usage, so try to retrieve current memory usage:
if {[catch {
# using ps (vsz is in KB):
incr in(-addmem) [expr {[lindex [exec ps -hq $ppid -o vsz] end] * 1024}]
}]} {
# ps failed, use default size 20MB:
incr in(-addmem) 20000000
# + size of locale-archive (may be up to 100MB):
incr in(-addmem) [expr {
[file exists /usr/lib/locale/locale-archive] ?
[file size /usr/lib/locale/locale-archive] : 0
}]
}
if {![info exists in(-maxmem)]} {
set in(-maxmem) $in(-addmem)
}
set in(-maxmem) [expr { max($in(-addmem), $in(-maxmem)) }]
}
append args --as=$in(-maxmem)
}
# apply limits:
exec prlimit -p $ppid {*}$args
} msg opt]} {
catch {close $pipe}
tcltest::Warn "testWithLimit: error - [regsub {^\s*([^\n]*).*$} $msg {\1}]"
tcltest::Skip testWithLimit
}
# execute body, close process and return:
set ret [catch {
chan configure $pipe -buffering line
puts $pipe "puts \[$body\]"
puts $pipe exit
set result [read $pipe]
close $pipe
set pipe {}
set result
} result opt]
if {$pipe ne ""} { catch { close $pipe } }
if {$ret && [dict get $opt -errorcode] eq "BYPASS-SKIPPED-TEST"} {
return {*}$opt $result
}
if { ( [info exists in(-warn-on-code)] && $ret in $in(-warn-on-code) )
|| ( $ret && [info exists in(-warn-on-alloc-error)] && $in(-warn-on-alloc-error)
&& [regexp {\munable to (?:re)?alloc\M} $result] )
} {
tcltest::Warn "testWithLimit: wrong limit, result: $result"
tcltest::Skip testWithLimit
}
return {*}$opt $result
}
# export all routines starting with test
namespace export test*
# for script path & as mark for loaded
proc scriptpath {} [list return [info script]]
}}; # end of internals.
|
Changes to tests/interp.test.
| ︙ | ︙ | |||
1832 1833 1834 1835 1836 1837 1838 |
lappend l [interp aliases a] [interp hidden a]
} -cleanup {
interp delete a
} -result {{} bar {} bar bar {} {}}
test interp-23.2 {testing hiding vs aliases: safe interp} -setup {
catch {interp delete a}
set l ""
| | | 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 |
lappend l [interp aliases a] [interp hidden a]
} -cleanup {
interp delete a
} -result {{} bar {} bar bar {} {}}
test interp-23.2 {testing hiding vs aliases: safe interp} -setup {
catch {interp delete a}
set l ""
} -constraints {unixOrWin} -body {
interp create a -safe
lappend l [lsort [interp hidden a]]
a alias bar bar
lappend l [lsort [interp aliases a]] [lsort [interp hidden a]]
a hide bar
lappend l [lsort [interp aliases a]] [lsort [interp hidden a]]
a alias bar {}
|
| ︙ | ︙ |
Changes to tests/io.test.
| ︙ | ︙ | |||
39 40 41 42 43 44 45 46 47 48 49 50 51 52 |
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testchannel [llength [info commands testchannel]]
testConstraint openpipe 1
testConstraint testfevent [llength [info commands testfevent]]
testConstraint testchannelevent [llength [info commands testchannelevent]]
testConstraint testmainthread [llength [info commands testmainthread]]
testConstraint testobj [llength [info commands testobj]]
# 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.
| > | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testchannel [llength [info commands testchannel]]
testConstraint openpipe 1
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 knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
# 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.
|
| ︙ | ︙ | |||
914 915 916 917 918 919 920 |
set x
} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel openpipe fileevent} {
# Tcl_ExternalToUtf()
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
| | | 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 |
set x
} [list "bbbbbbbbbbbbbbb" 15 "123456789abcdef" 1 4 "abcd" 0 3 "efg"]
test io-6.45 {Tcl_GetsObj: input saw cr, skip right number of bytes} {stdio testchannel openpipe fileevent} {
# Tcl_ExternalToUtf()
set f [open "|[list [interpreter] $path(cat)]" w+]
fconfigure $f -translation {auto lf} -buffering none
fconfigure $f -encoding utf-16
puts -nonewline $f "bbbbbbbbbbbbbbb\n123456789abcdef\r"
fconfigure $f -buffersize 16
gets $f
fconfigure $f -blocking 0
set x [list [gets $f line] $line [testchannel queuedcr $f]]
fconfigure $f -blocking 1
puts -nonewline $f "\nabcd\refg"
|
| ︙ | ︙ | |||
1158 1159 1160 1161 1162 1163 1164 |
puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz"
variable x {}
fileevent $f read [namespace code "ready $f"]
proc ready {f} {
variable x
lappend x [gets $f line] $line [testchannel inputbuffered $f]
}
| | | 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 |
puts -nonewline $f "123456789012345\r\nbcdefghijklmnopqrstuvwxyz"
variable x {}
fileevent $f read [namespace code "ready $f"]
proc ready {f} {
variable x
lappend x [gets $f line] $line [testchannel inputbuffered $f]
}
fconfigure $f -encoding utf-16 -buffersize 16 -blocking 0
vwait [namespace which -variable x]
fconfigure $f -translation auto -encoding ascii -blocking 1
# here
vwait [namespace which -variable x]
close $f
set x
} [list -1 "" 42 15 "123456789012345" 25]
|
| ︙ | ︙ | |||
2207 2208 2209 2210 2211 2212 2213 |
lappend l [file size $path(test1)]
flush $f
lappend l [file size $path(test1)]
close $f
set l
} {0 60 72}
test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \
| | | | 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 |
lappend l [file size $path(test1)]
flush $f
lappend l [file size $path(test1)]
close $f
set l
} {0 60 72}
test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \
{unixOrWin} {
file delete $path(test1)
set f [open $path(test1) w]
fconfigure $f -translation lf -buffersize 60 -eofchar {}
set l ""
lappend l [file size $path(test1)]
for {set i 0} {$i < 12} {incr i} {
puts $f hello
}
lappend l [file size $path(test1)]
close $f
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 openpipe knownMsvcBug} {
# 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 {
|
| ︙ | ︙ | |||
2822 2823 2824 2825 2826 2827 2828 |
}
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
# allow a little time for the background process to close.
| | | | 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 |
}
if {$counter == 1000} {
set result "file size only [file size $path(output)]"
} else {
set result ok
}
# allow a little time for the background process to close.
# otherwise, the following test fails on the [file delete $path(output)]
# on Windows because a process still has the file open.
after 100 set v 1; vwait v
set result
} ok
test io-29.32 {Tcl_WriteChars, background flush to slow reader} \
{stdio asyncPipeClose openpipe knownMsvcBug} {
# 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}
|
| ︙ | ︙ | |||
5960 5961 5962 5963 5964 5965 5966 |
vwait [namespace which -variable x]
close $f4
set x
} {initial foo eof}
close $f
| | | | 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 |
vwait [namespace which -variable x]
close $f4
set x
} {initial foo eof}
close $f
test io-44.6 {FileEventProc procedure: write-only non-blocking channel} -setup {
} -constraints {stdio fileevent openpipe} -body {
namespace eval refchan {
namespace ensemble create
namespace export *
proc finalize {chan args} {
|
| ︙ | ︙ | |||
6012 6013 6014 6015 6016 6017 6018 |
puts $f $data
incr count [string length $data]
if {$count > 262144} {
chan event $f writable {}
set x done
}
}]
| | | > | 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 |
puts $f $data
incr count [string length $data]
if {$count > 262144} {
chan event $f writable {}
set x done
}
}]
set token [after 10000 [namespace code {
set x timeout
}]]
vwait [namespace which -variable x]
return $x
} -cleanup {
after cancel $token
catch {chan close $f}
} -result done
makeFile "foo bar" foo
test io-45.1 {DeleteFileEvent, cleanup on close} {fileevent} {
|
| ︙ | ︙ | |||
7441 7442 7443 7444 7445 7446 7447 |
close $f1
after 500
set f [open $path(test1)]
lappend result [read $f]
close $f
set result
} "ready line1 line2 {done\n}"
| | | 7443 7444 7445 7446 7447 7448 7449 7450 7451 7452 7453 7454 7455 7456 7457 |
close $f1
after 500
set f [open $path(test1)]
lappend result [read $f]
close $f
set result
} "ready line1 line2 {done\n}"
test io-53.4 {CopyData: background write overflow} {stdio openpipe fileevent fcopy} {
set big bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb\n
variable x
for {set x 0} {$x < 12} {incr x} {
append big $big
}
file delete $path(pipe)
set f1 [open $path(pipe) w]
|
| ︙ | ︙ | |||
8079 8080 8081 8082 8083 8084 8085 |
list [gets $c] [chan copy $c $outChan -size 100] [gets $c]
} -cleanup {
close $outChan
close $c
removeFile out
} -result {line 100 line}
| | | 8081 8082 8083 8084 8085 8086 8087 8088 8089 8090 8091 8092 8093 8094 8095 |
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 knownMsvcBug} {
# 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"
|
| ︙ | ︙ | |||
8288 8289 8290 8291 8292 8293 8294 |
vwait [namespace which -variable result]
close $s
close $s2
close $server
set result
} {1 readable 234567890 timer}
| | | 8290 8291 8292 8293 8294 8295 8296 8297 8298 8299 8300 8301 8302 8303 8304 |
vwait [namespace which -variable result]
close $s
close $s2
close $server
set result
} {1 readable 234567890 timer}
test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrWin openpipe fileevent} {
set out [open $path(script) w]
puts $out {
puts "normal message from pipe"
puts stderr "error message from pipe"
exit 1
}
proc readit {pipe} {
|
| ︙ | ︙ |
Changes to tests/ioCmd.test.
| ︙ | ︙ | |||
237 238 239 240 241 242 243 |
test iocmd-8.6 {fconfigure command} -returnCodes error -body {
fconfigure stdin -translation froboz
} -result {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}
test iocmd-8.7 {fconfigure command} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
| | | | | | 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 |
test iocmd-8.6 {fconfigure command} -returnCodes error -body {
fconfigure stdin -translation froboz
} -result {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}
test iocmd-8.7 {fconfigure command} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -eofchar {} -encoding utf-16
fconfigure $f1
} -cleanup {
catch {close $f1}
} -result {-blocking 1 -buffering full -buffersize 4096 -encoding utf-16 -eofchar {} -translation lf}
test iocmd-8.8 {fconfigure command} -setup {
file delete $path(test1)
set x {}
} -body {
set f1 [open $path(test1) w]
fconfigure $f1 -translation lf -buffering line -buffersize 3030 \
-eofchar {} -encoding utf-16
lappend x [fconfigure $f1 -buffering]
lappend x [fconfigure $f1]
} -cleanup {
catch {close $f1}
} -result {line {-blocking 1 -buffering line -buffersize 3030 -encoding utf-16 -eofchar {} -translation lf}}
test iocmd-8.9 {fconfigure command} -setup {
file delete $path(test1)
} -body {
set f1 [open $path(test1) w]
fconfigure $f1 -translation binary -buffering none -buffersize 4040 \
-eofchar {} -encoding binary
fconfigure $f1
|
| ︙ | ︙ | |||
290 291 292 293 294 295 296 |
} -returnCodes error -cleanup {
catch {close $chan}
} -result [expectedOpts "-buffer" {}]
removeFile fconfigure.dummy
test iocmd-8.14 {fconfigure command} {
fconfigure stdin -buffers
} 4096
| | | 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 |
} -returnCodes error -cleanup {
catch {close $chan}
} -result [expectedOpts "-buffer" {}]
removeFile fconfigure.dummy
test iocmd-8.14 {fconfigure command} {
fconfigure stdin -buffers
} 4096
test iocmd-8.15.1 {fconfigure command / tcp channel} -constraints {socket unixOrWin} -setup {
set srv [socket -server iocmdSRV -myaddr 127.0.0.1 0]
set port [lindex [fconfigure $srv -sockname] 2]
proc iocmdSRV {sock ip port} {close $sock}
set cli [socket 127.0.0.1 $port]
} -body {
fconfigure $cli -blah
} -cleanup {
|
| ︙ | ︙ | |||
398 399 400 401 402 403 404 |
test iocmd-10.5 {fblocked command} {
fblocked stdin
} 0
set path(test4) [makeFile {} test4]
set path(test5) [makeFile {} test5]
| | | | | | 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 |
test iocmd-10.5 {fblocked command} {
fblocked stdin
} 0
set path(test4) [makeFile {} test4]
set path(test5) [makeFile {} test5]
test iocmd-11.1 {I/O to command pipelines} {unixOrWin unixExecs} {
set f [open $path(test4) w]
close $f
list [catch {open "| cat < \"$path(test4)\" > \"$path(test5)\"" w} msg] $msg $::errorCode
} {1 {can't write input to command: standard input was redirected} {TCL OPERATION EXEC BADREDIRECT}}
test iocmd-11.2 {I/O to command pipelines} {unixOrWin unixExecs} {
list [catch {open "| echo > \"$path(test5)\"" r} msg] $msg $::errorCode
} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}}
test iocmd-11.3 {I/O to command pipelines} {unixOrWin unixExecs} {
list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode
} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}}
test iocmd-11.4 {I/O to command pipelines} {notValgrind unixOrWin} {
list [catch {open "| no_such_command_exists" rb} msg] $msg $::errorCode
} {1 {couldn't execute "no_such_command_exists": no such file or directory} {POSIX ENOENT {no such file or directory}}}
test iocmd-12.1 {POSIX open access modes: RDONLY} {
file delete $path(test1)
set f [open $path(test1) w]
puts $f "Two lines: this one"
|
| ︙ | ︙ | |||
820 821 822 823 824 825 826 |
configure cget cgetall}
} finalize {
return
}
}
set ch [chan create {read write} foo]
} -body {
| | | | 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 |
configure cget cgetall}
} finalize {
return
}
}
set ch [chan create {read write} foo]
} -body {
chan configure $ch -blocking 0
} -cleanup {
close $ch
rename foo {}
} -match glob -returnCodes 1 -result {*(infinite loop?)*}
test iocmd-21.21 {[close] in [read] segfaults} -setup {
proc foo {method chan args} {
switch -- $method initialize {
return {initialize finalize watch read}
} finalize {} watch {} read {
close $chan
return a
|
| ︙ | ︙ | |||
2011 2012 2013 2014 2015 2016 2017 |
} -result {{unmatched open brace in list}}
test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return}
set c [chan create {r w} foo]
set tock {}
note [fileevent $c readable {lappend res TOCK; set tock 1}]
| | | | 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 |
} -result {{unmatched open brace in list}}
test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return}
set c [chan create {r w} foo]
set tock {}
note [fileevent $c readable {lappend res TOCK; set tock 1}]
set stop [after 15000 {lappend res TIMEOUT; set tock 1}]
after 1000 {note [chan postevent $c r]}
vwait ::tock
catch {after cancel $stop}
close $c
rename foo {}
set res
} -result {{watch rc* read} {} {} TOCK {watch rc* {}}}
test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body {
set res {}
proc foo {args} {oninit; onfinal; track; return}
set c [chan create {r w} foo]
note [fileevent $c writable {lappend res TOCK; set tock 1}]
set stop [after 15000 {lappend res TIMEOUT; set tock 1}]
after 1000 {note [chan postevent $c w]}
vwait ::tock
catch {after cancel $stop}
close $c
rename foo {}
set res
} -result {{watch rc* write} {} {} TOCK {watch rc* {}}}
|
| ︙ | ︙ |
Changes to tests/lindex.test.
| ︙ | ︙ | |||
47 48 49 50 51 52 53 |
test lindex-2.4 {malformed index list} testevalex {
set x \{
list [catch { testevalex {lindex {a b c} $x} } result] $result
} {1 bad\ index\ \"\{\":\ must\ be\ integer?\[+-\]integer?\ or\ end?\[+-\]integer?}
# Indices that are integers or convertible to integers
| | | | | | | | | | | | | | | | | | | | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 |
test lindex-2.4 {malformed index list} testevalex {
set x \{
list [catch { testevalex {lindex {a b c} $x} } result] $result
} {1 bad\ index\ \"\{\":\ must\ be\ integer?\[+-\]integer?\ or\ end?\[+-\]integer?}
# Indices that are integers or convertible to integers
test lindex-3.1 {integer -1} -constraints testevalex -body {
set x ${minus}1
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} -result {{} {}}
test lindex-3.2 {integer 0} -constraints testevalex -body {
set x [string range 00 0 0]
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} -result {a a}
test lindex-3.3 {integer 2} -constraints testevalex -body {
set x [string range 22 0 0]
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} -result {c c}
test lindex-3.4 {integer 3} -constraints testevalex -body {
set x [string range 33 0 0]
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} -result {{} {}}
test lindex-3.5 {bad octal} -constraints testevalex -body {
set x 0o8
list [catch { testevalex {lindex {a b c} $x} } result] $result
} -match glob -result {1 {*invalid octal number*}}
test lindex-3.6 {bad octal} -constraints testevalex -body {
set x -0o9
list [catch { testevalex {lindex {a b c} $x} } result] $result
} -match glob -result {1 {*invalid octal number*}}
test lindex-3.7 {indexes don't shimmer wide ints} -body {
set x [expr {(wide(1)<<31) - 2}]
list $x [lindex {1 2 3} $x] [incr x] [incr x]
} -result {2147483646 {} 2147483647 2147483648}
test lindex-3.8 {compiled with static indices out of range, negative} -body {
list [lindex {a b c} -1] [lindex {a b c} -2] [lindex {a b c} -3]
} -result [lrepeat 3 {}]
test lindex-3.9 {compiled with calculated indices out of range, negative constant} -body {
list [lindex {a b c} -1-1] [lindex {a b c} -2+0] [lindex {a b c} -2+1]
} -result [lrepeat 3 {}]
test lindex-3.10 {compiled with calculated indices out of range, after end} -body {
list [lindex {a b c} end+1] [lindex {a b c} end+2] [lindex {a b c} end+3]
} -result [lrepeat 3 {}]
# Indices relative to end
test lindex-4.1 {index = end} testevalex {
set x end
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {c c}
|
| ︙ | ︙ | |||
110 111 112 113 114 115 116 |
test lindex-4.5 {index = end-3} testevalex {
set x end-3
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {{} {}}
test lindex-4.6 {bad octal} -constraints testevalex -body {
set x end-0o8
list [catch { testevalex {lindex {a b c} $x} } result] $result
| | | | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 |
test lindex-4.5 {index = end-3} testevalex {
set x end-3
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
} {{} {}}
test lindex-4.6 {bad octal} -constraints testevalex -body {
set x end-0o8
list [catch { testevalex {lindex {a b c} $x} } result] $result
} -match glob -result {1 {*invalid octal number*}}
test lindex-4.7 {bad octal} -constraints testevalex -body {
set x end--0o9
list [catch { testevalex {lindex {a b c} $x} } result] $result
} -match glob -result {1 {*invalid octal number*}}
test lindex-4.8 {bad integer, not octal} testevalex {
set x end-0a2
list [catch { testevalex {lindex {a b c} $x} } result] $result
} {1 {bad index "end-0a2": must be integer?[+-]integer? or end?[+-]integer?}}
test lindex-4.9 {obsolete test} testevalex {
set x end
list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}]
|
| ︙ | ︙ | |||
161 162 163 164 165 166 167 |
test lindex-7.3 {quoted elements} testevalex {
testevalex {lindex {ab "c d \" x" y} 1}
} {c d " x}
test lindex-7.4 {quoted elements} {
lindex {a b {c d "e} {f g"}} 2
} {c d "e}
| | | | | | > > | | | | | | | | > > | | 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 |
test lindex-7.3 {quoted elements} testevalex {
testevalex {lindex {ab "c d \" x" y} 1}
} {c d " x}
test lindex-7.4 {quoted elements} {
lindex {a b {c d "e} {f g"}} 2
} {c d "e}
test lindex-8.1 {data reuse} -constraints testevalex -body {
set x 0
testevalex {lindex $x $x}
} -result 0
test lindex-8.2 {data reuse} -constraints testevalex -body {
set a 0
testevalex {lindex $a $a $a}
} -result 0
test lindex-8.3 {data reuse} -constraints {
testevalex
} -body {
set a 1
testevalex {lindex $a $a $a}
} -result {}
test lindex-8.4 {data reuse} -constraints testevalex -body {
set x [list 0 0]
testevalex {lindex $x $x}
} -result 0
test lindex-8.5 {data reuse} -constraints testevalex -body {
set x 0
testevalex {lindex $x [list $x $x]}
} -result 0
test lindex-8.6 {data reuse} -constraints testevalex -body {
set x [list 1 1]
testevalex {lindex $x $x}
} -result {}
test lindex-8.7 {data reuse} -constraints {
testevalex
} -body {
set x 1
testevalex {lindex $x [list $x $x]}
} -result {}
#----------------------------------------------------------------------
# Compilation tests for lindex
test lindex-9.1 {wrong # args} {
list [catch {lindex} result] $result
|
| ︙ | ︙ | |||
266 267 268 269 270 271 272 |
list [lindex {a b c} $x] [lindex {a b c} $x]
} result
set result
} {{} {}}
test lindex-11.5 {bad octal} -body {
set x 0o8
list [catch { lindex {a b c} $x } result] $result
| | | | 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 |
list [lindex {a b c} $x] [lindex {a b c} $x]
} result
set result
} {{} {}}
test lindex-11.5 {bad octal} -body {
set x 0o8
list [catch { lindex {a b c} $x } result] $result
} -match glob -result {1 {*invalid octal number*}}
test lindex-11.6 {bad octal} -body {
set x -0o9
list [catch { lindex {a b c} $x } result] $result
} -match glob -result {1 {*invalid octal number*}}
# Indices relative to end
test lindex-12.1 {index = end} {
set x end
catch {
list [lindex {a b c} $x] [lindex {a b c} $x]
|
| ︙ | ︙ | |||
312 313 314 315 316 317 318 |
list [lindex {a b c} $x] [lindex {a b c} $x]
} result
set result
} {{} {}}
test lindex-12.6 {bad octal} -body {
set x end-0o8
list [catch { lindex {a b c} $x } result] $result
| | | | 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 |
list [lindex {a b c} $x] [lindex {a b c} $x]
} result
set result
} {{} {}}
test lindex-12.6 {bad octal} -body {
set x end-0o8
list [catch { lindex {a b c} $x } result] $result
} -match glob -result {1 {*invalid octal number*}}
test lindex-12.7 {bad octal} -body {
set x end--0o9
list [catch { lindex {a b c} $x } result] $result
} -match glob -result {1 {*invalid octal number*}}
test lindex-12.8 {bad integer, not octal} {
set x end-0a2
list [catch { lindex {a b c} $x } result] $result
} {1 {bad index "end-0a2": must be integer?[+-]integer? or end?[+-]integer?}}
test lindex-12.9 {obsolete test} {
set x end
catch {
|
| ︙ | ︙ | |||
377 378 379 380 381 382 383 |
} {{}}
test lindex-15.3 {quoted elements} {
catch {
lindex {ab "c d \" x" y} 1
} result
set result
} {c d " x}
| | | | | | | | | | | | | | | | | | < | < < | < < < | < | < < | < < | 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 |
} {{}}
test lindex-15.3 {quoted elements} {
catch {
lindex {ab "c d \" x" y} 1
} result
set result
} {c d " x}
test lindex-15.4 {quoted elements} -body {
catch {
lindex {a b {c d "e} {f g"}} 2
} result
set result
} -result {c d "e}
test lindex-16.1 {data reuse} -body {
set x 0
catch {
lindex $x $x
} result
set result
} -result {0}
test lindex-16.2 {data reuse} -body {
set a 0
catch {
lindex $a $a $a
} result
set result
} -result 0
test lindex-16.3 {data reuse} -body {
set a 1
catch {
lindex $a $a $a
} result
set result
} -result {}
test lindex-16.4 {data reuse} -body {
set x [list 0 0]
catch {
lindex $x $x
} result
set result
} -result {0}
test lindex-16.5 {data reuse} -body {
set x 0
catch {
lindex $x [list $x $x]
} result
set result
} -result {0}
test lindex-16.6 {data reuse} -body {
set x [list 1 1]
catch {
lindex $x $x
} result
set result
} -result {}
test lindex-16.7 {data reuse} -body {
set x 1
catch {
lindex $x [list $x $x]
} result
set result
} -result {}
test lindex-17.0 {Bug 1718580} -body {
lindex {} end foo
} -match glob -result {bad index "foo"*} -returnCodes 1
test lindex-17.1 {Bug 1718580} -body {
lindex a end foo
} -match glob -result {bad index "foo"*} -returnCodes 1
catch { unset minus }
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/link.test.
| ︙ | ︙ | |||
406 407 408 409 410 411 412 |
test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} {
testlink create 0 0 0 0 0 0 0 0 0 0 0 0 0 0
list [catch {
testlink update 47 {} {} {} {} {} {} {} {} {} {} {} {} {}
} msg] $msg $int
} {0 {} 47}
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 |
test link-8.3 {Tcl_UpdateLinkedVar procedure, read-only variable} {testlink} {
testlink create 0 0 0 0 0 0 0 0 0 0 0 0 0 0
list [catch {
testlink update 47 {} {} {} {} {} {} {} {} {} {} {} {} {}
} msg] $msg $int
} {0 {} 47}
test link-9.1 {linkarray usage messages} -returnCodes error -constraints testlinkarray -body {
testlinkarray
} -result {wrong # args: should be "testlinkarray option args"}
test link-9.2 {linkarray usage messages} -returnCodes error -constraints testlinkarray -body {
testlinkarray x
} -result {bad option "x": must be update, remove, or create}
test link-9.3 {linkarray usage messages} -constraints testlinkarray -body {
testlinkarray update
} -result {}
test link-9.4 {linkarray usage messages} -constraints testlinkarray -body {
testlinkarray remove
} -result {}
test link-9.5 {linkarray usage messages} -returnCodes error -constraints testlinkarray -body {
testlinkarray create
} -result {wrong # args: should be "testlinkarray create ?-readonly? type size name ?address?"}
test link-9.6 {linkarray usage messages} -returnCodes error -constraints testlinkarray -body {
testlinkarray create xx 1 my
} -result {bad type "xx": must be char, uchar, short, ushort, int, uint, long, ulong, wide, uwide, float, double, string, char*, or binary}
test link-9.7 {linkarray usage messages} -returnCodes error -constraints testlinkarray -body {
testlinkarray create char* 0 my
} -result {wrong array size given}
test link-10.1 {linkarray char*} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create char* 1 ::my(var)
lappend mylist [set ::my(var) ""]
catch {set ::my(var) x} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{} {can't set "::my(var)": wrong size of char* value}}
test link-10.2 {linkarray char*} -constraints testlinkarray -body {
testlinkarray create char* 4 ::my(var)
set ::my(var) x
catch {set ::my(var) xyzz} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": wrong size of char* value}
test link-10.3 {linkarray char*} -constraints testlinkarray -body {
testlinkarray create -r char* 4 ::my(var)
catch {set ::my(var) x} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-11.1 {linkarray char} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create char 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1234} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have char value} 120 {can't set "::my(var)": variable must have char value}}
test link-11.2 {linkarray char} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create char 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-11.3 {linkarray char} -constraints testlinkarray -body {
testlinkarray create -r char 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-12.1 {linkarray unsigned char} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create uchar 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1234} msg
lappend mylist $msg
catch {set ::my(var) -1} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have unsigned char value} 120 {can't set "::my(var)": variable must have unsigned char value} {can't set "::my(var)": variable must have unsigned char value}}
test link-12.2 {linkarray unsigned char} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create uchar 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-12.3 {linkarray unsigned char} -constraints testlinkarray -body {
testlinkarray create -r uchar 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-13.1 {linkarray short} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create short 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 123456} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have short value} 120 {can't set "::my(var)": variable must have short value}}
test link-13.2 {linkarray short} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create short 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-13.3 {linkarray short} -constraints testlinkarray -body {
testlinkarray create -r short 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-14.1 {linkarray unsigned short} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create ushort 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 123456} msg
lappend mylist $msg
catch {set ::my(var) -1} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have unsigned short value} 120 {can't set "::my(var)": variable must have unsigned short value} {can't set "::my(var)": variable must have unsigned short value}}
test link-14.2 {linkarray unsigned short} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create ushort 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-14.3 {linkarray unsigned short} -constraints testlinkarray -body {
testlinkarray create -r ushort 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-15.1 {linkarray int} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create int 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1e3} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have integer value} 120 {can't set "::my(var)": variable must have integer value}}
test link-15.2 {linkarray int} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create int 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-15.3 {linkarray int} -constraints testlinkarray -body {
testlinkarray create -r int 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-16.1 {linkarray unsigned int} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create uint 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1e33} msg
lappend mylist $msg
catch {set ::my(var) -1} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain ::my
} -result {{can't set "::my(var)": variable must have unsigned int value} 120 {can't set "::my(var)": variable must have unsigned int value} {can't set "::my(var)": variable must have unsigned int value}}
test link-16.2 {linkarray unsigned int} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create uint 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain ::my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-16.3 {linkarray unsigned int} -constraints testlinkarray -body {
testlinkarray create -r uint 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-17.1 {linkarray long} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create long 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1e33} msg
lappend mylist $msg
} -match glob -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have * value} 120 {can't set "::my(var)": variable must have * value}}
test link-17.2 {linkarray long} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create long 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-17.3 {linkarray long} -constraints testlinkarray -body {
testlinkarray create -r long 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-18.1 {linkarray unsigned long} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create ulong 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1e33} msg
lappend mylist $msg
} -match glob -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have unsigned * value} 120 {can't set "::my(var)": variable must have unsigned * value}}
test link-18.2 {linkarray unsigned long} -constraints testlinkarray -body {
testlinkarray create ulong 1 ::my(var)
set ::my(var) 120
catch {set ::my(var) -1} msg
return $msg
} -match glob -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": variable must have unsigned * value}
test link-18.3 {linkarray unsigned long} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create ulong 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-18.4 {linkarray unsigned long} -constraints testlinkarray -body {
testlinkarray create -r ulong 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-19.1 {linkarray wide} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create wide 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1e33} msg
lappend mylist $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have wide integer value} 120 {can't set "::my(var)": variable must have wide integer value}}
test link-19.2 {linkarray wide} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create wide 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-19.3 {linkarray wide} -constraints testlinkarray -body {
testlinkarray create -r wide 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-20.1 {linkarray unsigned wide} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create uwide 1 ::my(var)
catch {set ::my(var) x} msg
lappend mylist $msg
lappend mylist [set ::my(var) 120]
catch {set ::my(var) 1e33} msg
lappend mylist $msg
lappend mylist [set ::my(var) 0xbabed00dbabed00d]
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": variable must have unsigned wide int value} 120 {can't set "::my(var)": variable must have unsigned wide int value} 0xbabed00dbabed00d}
test link-20.2 {linkarray unsigned wide} -constraints testlinkarray -body {
testlinkarray create uwide 1 ::my(var)
set ::my(var) 120
catch {set ::my(var) -1} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": variable must have unsigned wide int value}
test link-20.3 {linkarray unsigned wide} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create uwide 4 ::my(var)
catch {set ::my(var) {1 2 3}} msg
lappend mylist $msg
set ::my(var) {1 2 3 4}
lappend mylist $my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong dimension} {1 2 3 4}}
test link-20.4 {linkarray unsigned wide} -constraints testlinkarray -body {
testlinkarray create -r uwide 2 ::my(var)
catch {set ::my(var) {1 2}} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-21.1 {linkarray string} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create string 1 ::my(var)
lappend mylist [set ::my(var) ""]
lappend mylist [set ::my(var) "xyz"]
lappend mylist $::my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{} xyz xyz}
test link-21.2 {linkarray string} -constraints testlinkarray -body {
testlinkarray create -r string 4 ::my(var)
catch {set ::my(var) x} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
test link-22.1 {linkarray binary} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create binary 1 ::my(var)
set ::my(var) x
catch {set ::my(var) xy} msg
lappend mylist $msg
lappend mylist $::my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong size of binary value} x}
test link-22.2 {linkarray binary} -constraints testlinkarray -setup {
set mylist [list]
} -body {
testlinkarray create binary 4 ::my(var)
catch {set ::my(var) abc} msg
lappend mylist $msg
catch {set ::my(var) abcde} msg
lappend mylist $msg
set ::my(var) abcd
lappend mylist $::my(var)
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {{can't set "::my(var)": wrong size of binary value} {can't set "::my(var)": wrong size of binary value} abcd}
test link-22.3 {linkarray binary} -constraints testlinkarray -body {
testlinkarray create -r binary 4 ::my(var)
catch {set ::my(var) xyzv} msg
return $msg
} -cleanup {
testlinkarray remove ::my(var)
unset -nocomplain my
} -result {can't set "::my(var)": linked variable is read-only}
|
| ︙ | ︙ |
Changes to tests/lpop.test.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 19 20 21 22 23 24 25 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
test lpop-1.1 {error conditions} -returnCodes error -body {
lpop no
} -result {can't read "no": no such variable}
test lpop-1.2 {error conditions} -returnCodes error -body {
lpop no 0
} -result {can't read "no": no such variable}
test lpop-1.3 {error conditions} -returnCodes error -body {
| > | | | | | > > > > | | | | | | | | | | | | | | 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 |
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
unset -nocomplain no; # following tests expecting var "no" does not exists
test lpop-1.1 {error conditions} -returnCodes error -body {
lpop no
} -result {can't read "no": no such variable}
test lpop-1.2 {error conditions} -returnCodes error -body {
lpop no 0
} -result {can't read "no": no such variable}
test lpop-1.3 {error conditions} -returnCodes error -body {
set l "x {}x"
lpop l
} -result {list element in braces followed by "x" instead of space}
test lpop-1.4 {error conditions} -returnCodes error -body {
set l "x y"
lpop l -1
} -result {index "-1" out of range}
test lpop-1.4b {error conditions (also check SF on empty list variable, bug [234d6c811d])} -body {
set l "x y"
list [lpop l] [lpop l] [catch {lpop l} v] $v [catch {lpop l 0} v] $v $l
} -result {y x 1 {index "end" out of range} 1 {index "0" out of range} {}}
test lpop-1.5 {error conditions} -returnCodes error -body {
set l "x y z"
lpop l 3
} -result {index "3" out of range} ;#-errorCode {TCL OPERATION LPOP BADINDEX}
test lpop-1.6 {error conditions} -returnCodes error -body {
set l "x y"
lpop l end+1
} -result {index "end+1" out of range}
test lpop-1.7 {error conditions} -returnCodes error -body {
set l "x y"
lpop l {}
} -match glob -result {bad index *}
test lpop-1.8 {error conditions} -returnCodes error -body {
set l "x y"
lpop l 0 0 0 0 1
} -result {index "1" out of range}
test lpop-1.9 {error conditions} -returnCodes error -body {
set l "x y"
lpop l {1 0}
} -match glob -result {bad index *}
test lpop-2.1 {basic functionality} -body {
set l "x y z"
list [lpop l 0] $l
} -result {x {y z}}
test lpop-2.2 {basic functionality} -body {
|
| ︙ | ︙ |
Changes to tests/lrange.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 |
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testpurebytesobj [llength [info commands testpurebytesobj]]
| < | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testpurebytesobj [llength [info commands testpurebytesobj]]
test lrange-1.1 {range of list elements} {
lrange {a b c d} 1 2
} {b c}
test lrange-1.2 {range of list elements} {
lrange {a {bcd e {f g {}}} l14 l15 d} 1 1
} {{bcd e {f g {}}}}
|
| ︙ | ︙ | |||
98 99 100 101 102 103 104 |
} {}
test lrange-3.2 {compiled with static indices out of range, negative} {
list [lrange {a b c} -1 -2] [lrange {a b c} -2 -1] [lrange {a b c} -3 -2] [lrange {a b c} -2 -3]
} [lrepeat 4 {}]
test lrange-3.3 {compiled with calculated indices out of range, negative constant} {
list [lrange {a b c} 0-1 -1-1] [lrange {a b c} -2+0 0-1] [lrange {a b c} -2-1 -2+1] [lrange {a b c} -2+1 -2-1]
} [lrepeat 4 {}]
| | | | | | | | > > | | > > | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 |
} {}
test lrange-3.2 {compiled with static indices out of range, negative} {
list [lrange {a b c} -1 -2] [lrange {a b c} -2 -1] [lrange {a b c} -3 -2] [lrange {a b c} -2 -3]
} [lrepeat 4 {}]
test lrange-3.3 {compiled with calculated indices out of range, negative constant} {
list [lrange {a b c} 0-1 -1-1] [lrange {a b c} -2+0 0-1] [lrange {a b c} -2-1 -2+1] [lrange {a b c} -2+1 -2-1]
} [lrepeat 4 {}]
test lrange-3.4 {compiled with calculated indices out of range, after end} -body {
list [lrange {a b c} end+1 end+2] [lrange {a b c} end+2 end+1] [lrange {a b c} end+2 end+3] [lrange {a b c} end+3 end+2]
} -result [lrepeat 4 {}]
test lrange-3.5 {compiled with calculated indices, start out of range (negative)} {
list [lrange {a b c} -1 1] [lrange {a b c} -1+0 end-1] [lrange {a b c} -2 1] [lrange {a b c} -2+0 0+1]
} [lrepeat 4 {a b}]
test lrange-3.6 {compiled with calculated indices, end out of range (after end)} {
list [lrange {a b c} 1 end+1] [lrange {a b c} 1+0 2+1] [lrange {a b c} 1 end+1] [lrange {a b c} end-1 3+1]
} [lrepeat 4 {b c}]
test lrange-3.7a {compiled on empty not canonical list (with static and dynamic indices), regression test, bug [cc1e91552c]} {
list [lrange { } 0 1] [lrange [format %c 32] 0 1] [lrange [set a { }] 0 1] \
[lrange { } 0-1 end+1] [lrange [format %c 32] 0-1 end+1] [lrange $a 0-1 end+1]
} [lrepeat 6 {}]
test lrange-3.7b {not compiled on empty not canonical list (with static and dynamic indices), regression test, bug [cc1e91552c]} -body {
set cmd lrange
list [$cmd { } 0 1] [$cmd [format %c 32] 0 1] [$cmd [set a { }] 0 1] \
[$cmd { } 0-1 end+1] [$cmd [format %c 32] 0-1 end+1] [$cmd $a 0-1 end+1]
} -result [lrepeat 6 {}]
# following 4 tests could cause a segfault on empty non-lists with tclEmptyStringRep
# (as before the fix [58c46e74b931d3a1]):
test lrange-3.7a.2 {compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} {
list [lrange {} 0 1] [lrange [lindex a -1] 0 1] [lrange [set a {}] 0 1] \
[lrange {} 0-1 end+1] [lrange [lindex a -1] 0-1 end+1] [lrange $a 0-1 end+1]
} [lrepeat 6 {}]
test lrange-3.7b.2 {not compiled on empty not list object, 2nd regression test, bug [cc1e91552c]} -body {
set cmd lrange
list [$cmd {} 0 1] [$cmd [lindex a -1] 0 1] [$cmd [set a {}] 0 1] \
[$cmd {} 0-1 end+1] [$cmd [lindex a -1] 0-1 end+1] [$cmd $a 0-1 end+1]
} -result [lrepeat 6 {}]
test lrange-3.7c.2 {compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints {
testpurebytesobj
} -body {
list [lrange [testpurebytesobj] 0 1] [lrange [testpurebytesobj { }] 0 1] [lrange [set a [testpurebytesobj {}]] 0 1] \
[lrange [testpurebytesobj] 0-1 end+1] [lrange [testpurebytesobj { }] 0-1 end+1] [lrange $a 0-1 end+1]
} -result [lrepeat 6 {}]
test lrange-3.7d.2 {not compiled on empty pure bytes object, 2nd regression test, bug [cc1e91552c]} -constraints {
testpurebytesobj
} -body {
set cmd lrange
list [$cmd [testpurebytesobj] 0 1] [$cmd [testpurebytesobj { }] 0 1] [$cmd [set a [testpurebytesobj {}]] 0 1] \
[$cmd [testpurebytesobj] 0-1 end+1] [$cmd [testpurebytesobj { }] 0-1 end+1] [$cmd $a 0-1 end+1]
} -result [lrepeat 6 {}]
test lrange-4.1 {lrange pure promise} -body {
set ll1 [list $tcl_version 2 3 4]
# Shared
set ll2 $ll1
# With string rep
string length $ll1
|
| ︙ | ︙ | |||
218 219 220 221 222 223 224 |
# Shared, uncompiled
set ls2 $ls
set expected [list [catch {$lrange $ls $a $b} m] $m]
# Shared, compiled
set tester [list lrange $ls $a $b]
set script [list catch $tester m]
set script "list \[$script\] \$m"
| | | | | | | | 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 |
# Shared, uncompiled
set ls2 $ls
set expected [list [catch {$lrange $ls $a $b} m] $m]
# Shared, compiled
set tester [list lrange $ls $a $b]
set script [list catch $tester m]
set script "list \[$script\] \$m"
test lrange-5.[incr n].1 {lrange shared compiled} -body \
[list apply [list {} $script]] -result $expected
# Unshared, uncompiled
set tester [string map [list %l [list $ls] %a $a %b $b] {
[string cat l range] [lrange %l 0 end] %a %b
}]
set script [list catch $tester m]
set script "list \[$script\] \$m"
test lrange-5.$n.2 {lrange unshared uncompiled} -body \
[list apply [list {} $script]] -result $expected
# Unshared, compiled
set tester [string map [list %l [list $ls] %a $a %b $b] {
lrange [lrange %l 0 end] %a %b
}]
set script [list catch $tester m]
set script "list \[$script\] \$m"
test lrange-5.$n.3 {lrange unshared compiled} -body \
[list apply [list {} $script]] -result $expected
}
}
}
}}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/lreplace.test.
| ︙ | ︙ | |||
107 108 109 110 111 112 113 |
test lreplace-1.29 {lreplace command} -body {
lreplace x 1 1 [error foo]
} -returnCodes 1 -result {foo}
test lreplace-1.30 {lreplace command} -body {
lreplace {not {}alist} 0 0 [error foo]
} -returnCodes 1 -result {foo}
| | | | | | | | | | | | | | | | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 |
test lreplace-1.29 {lreplace command} -body {
lreplace x 1 1 [error foo]
} -returnCodes 1 -result {foo}
test lreplace-1.30 {lreplace command} -body {
lreplace {not {}alist} 0 0 [error foo]
} -returnCodes 1 -result {foo}
test lreplace-2.1 {lreplace errors} -body {
list [catch lreplace msg] $msg
} -result {1 {wrong # args: should be "lreplace list first last ?element ...?"}}
test lreplace-2.2 {lreplace errors} -body {
list [catch {lreplace a b} msg] $msg
} -result {1 {wrong # args: should be "lreplace list first last ?element ...?"}}
test lreplace-2.3 {lreplace errors} -body {
list [catch {lreplace x a 10} msg] $msg
} -result {1 {bad index "a": must be integer?[+-]integer? or end?[+-]integer?}}
test lreplace-2.4 {lreplace errors} -body {
list [catch {lreplace x 10 x} msg] $msg
} -result {1 {bad index "x": must be integer?[+-]integer? or end?[+-]integer?}}
test lreplace-2.5 {lreplace errors} -body {
list [catch {lreplace x 10 1x} msg] $msg
} -result {1 {bad index "1x": must be integer?[+-]integer? or end?[+-]integer?}}
test lreplace-2.6 {lreplace errors} -body {
list [catch {lreplace x 3 2} msg] $msg
} -result {0 x}
test lreplace-2.7 {lreplace errors} -body {
list [catch {lreplace x 2 2} msg] $msg
} -result {0 x}
test lreplace-3.1 {lreplace won't modify shared argument objects} {
proc p {} {
lreplace "a b c" 1 1 "x y"
return "a b c"
}
p
|
| ︙ | ︙ | |||
224 225 226 227 228 229 230 |
foreach a $idxs {
foreach b $idxs {
foreach i $ins {
set expected [list [catch {$lreplace $ls $a $b {*}$i} m] $m]
set tester [list lreplace $ls $a $b {*}$i]
set script [list catch $tester m]
set script "list \[$script\] \$m"
| | | | 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 |
foreach a $idxs {
foreach b $idxs {
foreach i $ins {
set expected [list [catch {$lreplace $ls $a $b {*}$i} m] $m]
set tester [list lreplace $ls $a $b {*}$i]
set script [list catch $tester m]
set script "list \[$script\] \$m"
test lreplace-6.[incr n] {lreplace battery} -body \
[list apply [list {} $script]] -result $expected
}
}
}
}
}}
# cleanup
|
| ︙ | ︙ |
Changes to tests/lsearch.test.
| ︙ | ︙ | |||
145 146 147 148 149 150 151 |
set res {}
for {set i 0} {$i < 100} {incr i} {
lappend res [lsearch -integer -decreasing -sorted \
$decreasingIntegers $i]
}
set res
} $decreasingIntegers
| | | | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 |
set res {}
for {set i 0} {$i < 100} {incr i} {
lappend res [lsearch -integer -decreasing -sorted \
$decreasingIntegers $i]
}
set res
} $decreasingIntegers
test lsearch-5.3 {binary search finds leftmost occurrences} {
set res {}
for {set i 0} {$i < 10} {incr i} {
lappend res [lsearch -integer -sorted $repeatingIncreasingIntegers $i]
}
set res
} [list 0 5 10 15 20 25 30 35 40 45]
test lsearch-5.4 {binary search -decreasing finds leftmost occurrences} {
set res {}
for {set i 9} {$i >= 0} {incr i -1} {
lappend res [lsearch -sorted -integer -decreasing \
$repeatingDecreasingIntegers $i]
}
set res
} [list 0 5 10 15 20 25 30 35 40 45]
|
| ︙ | ︙ | |||
428 429 430 431 432 433 434 |
lsearch -index {} [list \{] \{
} 0
test lsearch-17.11 {lsearch -index option, empty argument} {
lsearch -index {} [list \{] \{
} [lsearch [list \{] \{]
test lsearch-17.12 {lsearch -index option, encoding aliasing} -body {
lsearch -index -2 a a
| | | | | | | 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 |
lsearch -index {} [list \{] \{
} 0
test lsearch-17.11 {lsearch -index option, empty argument} {
lsearch -index {} [list \{] \{
} [lsearch [list \{] \{]
test lsearch-17.12 {lsearch -index option, encoding aliasing} -body {
lsearch -index -2 a a
} -returnCodes error -result {index "-2" out of range}
test lsearch-17.13 {lsearch -index option, encoding aliasing} -body {
lsearch -index -1-1 a a
} -returnCodes error -result {index "-1-1" out of range}
test lsearch-17.14 {lsearch -index option, encoding aliasing} -body {
lsearch -index end--1 a a
} -returnCodes error -result {index "end--1" out of range}
test lsearch-17.15 {lsearch -index option, encoding aliasing} -body {
lsearch -index end+1 a a
} -returnCodes error -result {index "end+1" out of range}
test lsearch-17.16 {lsearch -index option, encoding aliasing} -body {
lsearch -index end+2 a a
} -returnCodes error -result {index "end+2" out of range}
test lsearch-18.1 {lsearch -index option, list as index basic functionality} {
lsearch -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
} 1
test lsearch-18.2 {lsearch -index option, list as index basic functionality} {
lsearch -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
|
| ︙ | ︙ |
Changes to tests/lset.test.
| ︙ | ︙ | |||
93 94 95 96 97 98 99 |
} msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
test lset-4.3 {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a [list -1] w}
} msg] $msg
| | | | | | | | | | | | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 |
} msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
test lset-4.3 {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a [list -1] w}
} msg] $msg
} {1 {index "-1" out of range}}
test lset-4.4 {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a [list 4] w}
} msg] $msg
} {1 {index "4" out of range}}
test lset-4.5a {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a [list end--2] w}
} msg] $msg
} {1 {index "end--2" out of range}}
test lset-4.5b {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a [list end+2] w}
} msg] $msg
} {1 {index "end+2" out of range}}
test lset-4.6 {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a [list end-3] w}
} msg] $msg
} {1 {index "end-3" out of range}}
test lset-4.7 {lset, not compiled, 3 args, not a list} testevalex {
set a "x \{"
list [catch {
testevalex {lset a 0 y}
} msg] $msg
} {1 {unmatched open brace in list}}
test lset-4.8 {lset, not compiled, 3 args, bad index} testevalex {
set a {x y z}
list [catch {
testevalex {lset a 2a2 w}
} msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
test lset-4.9 {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a -1 w}
} msg] $msg
} {1 {index "-1" out of range}}
test lset-4.10 {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a 4 w}
} msg] $msg
} {1 {index "4" out of range}}
test lset-4.11a {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a end--2 w}
} msg] $msg
} {1 {index "end--2" out of range}}
test lset-4.11 {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a end+2 w}
} msg] $msg
} {1 {index "end+2" out of range}}
test lset-4.12 {lset, not compiled, 3 args, index out of range} testevalex {
set a {x y z}
list [catch {
testevalex {lset a end-3 w}
} msg] $msg
} {1 {index "end-3" out of range}}
test lset-5.1 {lset, not compiled, 3 args, can't set variable} testevalex {
list [catch {
testevalex {lset noWrite 0 d}
} msg] $msg $noWrite
} {1 {can't set "noWrite": trace failed} {d b c}}
test lset-5.2 {lset, not compiled, 3 args, can't set variable} testevalex {
|
| ︙ | ︙ | |||
277 278 279 280 281 282 283 |
test lset-8.4 {lset, not compiled, bad second index} testevalex {
set a {{b c} {d e}}
list [catch {testevalex {lset a {0 2a2} f}} msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
test lset-8.5 {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a 2 -1 h}} msg] $msg
| | | | | | | | | | | | 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 |
test lset-8.4 {lset, not compiled, bad second index} testevalex {
set a {{b c} {d e}}
list [catch {testevalex {lset a {0 2a2} f}} msg] $msg
} {1 {bad index "2a2": must be integer?[+-]integer? or end?[+-]integer?}}
test lset-8.5 {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a 2 -1 h}} msg] $msg
} {1 {index "-1" out of range}}
test lset-8.6 {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a {2 -1} h}} msg] $msg
} {1 {index "-1" out of range}}
test lset-8.7 {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a 2 3 h}} msg] $msg
} {1 {index "3" out of range}}
test lset-8.8 {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a {2 3} h}} msg] $msg
} {1 {index "3" out of range}}
test lset-8.9a {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a 2 end--2 h}} msg] $msg
} {1 {index "end--2" out of range}}
test lset-8.9b {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a 2 end+2 h}} msg] $msg
} {1 {index "end+2" out of range}}
test lset-8.10a {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a {2 end--2} h}} msg] $msg
} {1 {index "end--2" out of range}}
test lset-8.10b {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a {2 end+2} h}} msg] $msg
} {1 {index "end+2" out of range}}
test lset-8.11 {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a 2 end-2 h}} msg] $msg
} {1 {index "end-2" out of range}}
test lset-8.12 {lset, not compiled, second index out of range} testevalex {
set a {{b c} {d e} {f g}}
list [catch {testevalex {lset a {2 end-2} h}} msg] $msg
} {1 {index "end-2" out of range}}
test lset-9.1 {lset, not compiled, entire variable} testevalex {
set a x
list [testevalex {lset a y}] $a
} {y y}
test lset-9.2 {lset, not compiled, entire variable} testevalex {
set a x
|
| ︙ | ︙ |
Changes to tests/lsetComp.test.
| ︙ | ︙ | |||
215 216 217 218 219 220 221 |
} "0 {{1 2} {3 5}}"
test lsetComp-2.8 {lset, compiled, list of args, error } {
evalInProc {
set x { {1 2} {3 4} }
lset x {1 5} 5
}
| | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 |
} "0 {{1 2} {3 5}}"
test lsetComp-2.8 {lset, compiled, list of args, error } {
evalInProc {
set x { {1 2} {3 4} }
lset x {1 5} 5
}
} {1 {index "5" out of range}}
test lsetComp-2.9 {lset, compiled, list of args, error - is string preserved} {
set ::x { { 1 2 } { 3 4 } }
evalInProc {
lset ::x { 1 5 } 5
}
list $::x [lindex $::x 1]
|
| ︙ | ︙ | |||
408 409 410 411 412 413 414 |
} "0 {{1 2} {3 5}}"
test lsetComp-3.8 {lset, compiled, flat args, error } {
evalInProc {
set x { {1 2} {3 4} }
lset x 1 5 5
}
| | | 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 |
} "0 {{1 2} {3 5}}"
test lsetComp-3.8 {lset, compiled, flat args, error } {
evalInProc {
set x { {1 2} {3 4} }
lset x 1 5 5
}
} {1 {index "5" out of range}}
test lsetComp-3.9 {lset, compiled, flat args, error - is string preserved} {
set ::x { { 1 2 } { 3 4 } }
evalInProc {
lset ::x 1 5 5
}
list $::x [lindex $::x 1]
|
| ︙ | ︙ |
Changes to tests/main.test.
| ︙ | ︙ | |||
609 610 611 612 613 614 615 |
catch {chan configure $f -blocking 0}
} -body {
type $f "chan configure stdin -eofchar \\032
if 1 \{\n\032"
variable wait
chan event $f readable \
[list set [namespace which -variable wait] "child exit"]
| | | 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 |
catch {chan configure $f -blocking 0}
} -body {
type $f "chan configure stdin -eofchar \\032
if 1 \{\n\032"
variable wait
chan event $f readable \
[list set [namespace which -variable wait] "child exit"]
set id [after 5000 [list set [namespace which -variable wait] timeout]]
vwait [namespace which -variable wait]
after cancel $id
set wait
} -cleanup {
if {$wait eq "timeout" && [testConstraint unix]} {
exec kill [pid $f]
}
|
| ︙ | ︙ | |||
632 633 634 635 636 637 638 |
set cmd {makeFile "if 1 \{" script}
catch {set f [open "|[list [interpreter]] < [list [eval $cmd]]" r]}
catch {chan configure $f -blocking 0}
} -body {
variable wait
chan event $f readable \
[list set [namespace which -variable wait] "child exit"]
| | | 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 |
set cmd {makeFile "if 1 \{" script}
catch {set f [open "|[list [interpreter]] < [list [eval $cmd]]" r]}
catch {chan configure $f -blocking 0}
} -body {
variable wait
chan event $f readable \
[list set [namespace which -variable wait] "child exit"]
set id [after 5000 [list set [namespace which -variable wait] timeout]]
vwait [namespace which -variable wait]
after cancel $id
set wait
} -cleanup {
if {$wait eq "timeout" && [testConstraint unix]} {
exec kill [pid $f]
}
|
| ︙ | ︙ |
Changes to tests/mathop.test.
| ︙ | ︙ | |||
110 111 112 113 114 115 116 |
test mathop-1.6 {compiled +} { + 1 2 3.0 } 6.0
test mathop-1.7 {compiled +} { + 100000000000 2 3 } 100000000005
test mathop-1.8 {compiled +} { + 1 2 300000000000 } 300000000003
test mathop-1.9 {compiled +} { + 1000000000000000000000 2 3 } 1000000000000000000005
test mathop-1.10 {compiled +} { + 1 2 3000000000000000000000 } 3000000000000000000003
test mathop-1.11 {compiled +: errors} -returnCodes error -body {
+ x 0
| | | | | | | | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 |
test mathop-1.6 {compiled +} { + 1 2 3.0 } 6.0
test mathop-1.7 {compiled +} { + 100000000000 2 3 } 100000000005
test mathop-1.8 {compiled +} { + 1 2 300000000000 } 300000000003
test mathop-1.9 {compiled +} { + 1000000000000000000000 2 3 } 1000000000000000000005
test mathop-1.10 {compiled +} { + 1 2 3000000000000000000000 } 3000000000000000000003
test mathop-1.11 {compiled +: errors} -returnCodes error -body {
+ x 0
} -result {can't use non-numeric string as operand of "+"}
test mathop-1.12 {compiled +: errors} -returnCodes error -body {
+ nan 0
} -result {can't use non-numeric floating-point value as operand of "+"}
test mathop-1.13 {compiled +: errors} -returnCodes error -body {
+ 0 x
} -result {can't use non-numeric string as operand of "+"}
test mathop-1.14 {compiled +: errors} -returnCodes error -body {
+ 0 nan
} -result {can't use non-numeric floating-point value as operand of "+"}
test mathop-1.15 {compiled +: errors} -returnCodes error -body {
+ 0o8 0
} -result {can't use invalid octal number as operand of "+"}
test mathop-1.16 {compiled +: errors} -returnCodes error -body {
+ 0 0o8
} -result {can't use invalid octal number as operand of "+"}
test mathop-1.17 {compiled +: errors} -returnCodes error -body {
+ 0 [error expectedError]
} -result expectedError
test mathop-1.18 {compiled +: argument processing order} -body {
# Bytecode compilation known hard for 3+ arguments
list [catch {
+ [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
|
| ︙ | ︙ | |||
148 149 150 151 152 153 154 |
test mathop-1.24 {interpreted +} { $op 1 2 3.0 } 6.0
test mathop-1.25 {interpreted +} { $op 100000000000 2 3 } 100000000005
test mathop-1.26 {interpreted +} { $op 1 2 300000000000 } 300000000003
test mathop-1.27 {interpreted +} { $op 1000000000000000000000 2 3 } 1000000000000000000005
test mathop-1.28 {interpreted +} { $op 1 2 3000000000000000000000 } 3000000000000000000003
test mathop-1.29 {interpreted +: errors} -returnCodes error -body {
$op x 0
| | | | | | | | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 |
test mathop-1.24 {interpreted +} { $op 1 2 3.0 } 6.0
test mathop-1.25 {interpreted +} { $op 100000000000 2 3 } 100000000005
test mathop-1.26 {interpreted +} { $op 1 2 300000000000 } 300000000003
test mathop-1.27 {interpreted +} { $op 1000000000000000000000 2 3 } 1000000000000000000005
test mathop-1.28 {interpreted +} { $op 1 2 3000000000000000000000 } 3000000000000000000003
test mathop-1.29 {interpreted +: errors} -returnCodes error -body {
$op x 0
} -result {can't use non-numeric string as operand of "+"}
test mathop-1.30 {interpreted +: errors} -returnCodes error -body {
$op nan 0
} -result {can't use non-numeric floating-point value as operand of "+"}
test mathop-1.31 {interpreted +: errors} -returnCodes error -body {
$op 0 x
} -result {can't use non-numeric string as operand of "+"}
test mathop-1.32 {interpreted +: errors} -returnCodes error -body {
$op 0 nan
} -result {can't use non-numeric floating-point value as operand of "+"}
test mathop-1.33 {interpreted +: errors} -returnCodes error -body {
$op 0o8 0
} -result {can't use invalid octal number as operand of "+"}
test mathop-1.34 {interpreted +: errors} -returnCodes error -body {
$op 0 0o8
} -result {can't use invalid octal number as operand of "+"}
test mathop-1.35 {interpreted +: errors} -returnCodes error -body {
$op 0 [error expectedError]
} -result expectedError
test mathop-1.36 {interpreted +: argument processing order} -body {
list [catch {
$op [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
} msg] $msg $x
|
| ︙ | ︙ | |||
185 186 187 188 189 190 191 |
test mathop-2.6 {compiled *} { * 1 2 3.0 } 6.0
test mathop-2.7 {compiled *} { * 100000000000 2 3 } 600000000000
test mathop-2.8 {compiled *} { * 1 2 300000000000 } 600000000000
test mathop-2.9 {compiled *} { * 1000000000000000000000 2 3 } 6000000000000000000000
test mathop-2.10 {compiled *} { * 1 2 3000000000000000000000 } 6000000000000000000000
test mathop-2.11 {compiled *: errors} -returnCodes error -body {
* x 0
| | | | | | | | 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 |
test mathop-2.6 {compiled *} { * 1 2 3.0 } 6.0
test mathop-2.7 {compiled *} { * 100000000000 2 3 } 600000000000
test mathop-2.8 {compiled *} { * 1 2 300000000000 } 600000000000
test mathop-2.9 {compiled *} { * 1000000000000000000000 2 3 } 6000000000000000000000
test mathop-2.10 {compiled *} { * 1 2 3000000000000000000000 } 6000000000000000000000
test mathop-2.11 {compiled *: errors} -returnCodes error -body {
* x 0
} -result {can't use non-numeric string as operand of "*"}
test mathop-2.12 {compiled *: errors} -returnCodes error -body {
* nan 0
} -result {can't use non-numeric floating-point value as operand of "*"}
test mathop-2.13 {compiled *: errors} -returnCodes error -body {
* 0 x
} -result {can't use non-numeric string as operand of "*"}
test mathop-2.14 {compiled *: errors} -returnCodes error -body {
* 0 nan
} -result {can't use non-numeric floating-point value as operand of "*"}
test mathop-2.15 {compiled *: errors} -returnCodes error -body {
* 0o8 0
} -result {can't use invalid octal number as operand of "*"}
test mathop-2.16 {compiled *: errors} -returnCodes error -body {
* 0 0o8
} -result {can't use invalid octal number as operand of "*"}
test mathop-2.17 {compiled *: errors} -returnCodes error -body {
* 0 [error expectedError]
} -result expectedError
test mathop-2.18 {compiled *: argument processing order} -body {
# Bytecode compilation known hard for 3+ arguments
list [catch {
* [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
|
| ︙ | ︙ | |||
223 224 225 226 227 228 229 |
test mathop-2.24 {interpreted *} { $op 1 2 3.0 } 6.0
test mathop-2.25 {interpreted *} { $op 100000000000 2 3 } 600000000000
test mathop-2.26 {interpreted *} { $op 1 2 300000000000 } 600000000000
test mathop-2.27 {interpreted *} { $op 1000000000000000000000 2 3 } 6000000000000000000000
test mathop-2.28 {interpreted *} { $op 1 2 3000000000000000000000 } 6000000000000000000000
test mathop-2.29 {interpreted *: errors} -returnCodes error -body {
$op x 0
| | | | | | | | | | | | | | | | | | 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 |
test mathop-2.24 {interpreted *} { $op 1 2 3.0 } 6.0
test mathop-2.25 {interpreted *} { $op 100000000000 2 3 } 600000000000
test mathop-2.26 {interpreted *} { $op 1 2 300000000000 } 600000000000
test mathop-2.27 {interpreted *} { $op 1000000000000000000000 2 3 } 6000000000000000000000
test mathop-2.28 {interpreted *} { $op 1 2 3000000000000000000000 } 6000000000000000000000
test mathop-2.29 {interpreted *: errors} -returnCodes error -body {
$op x 0
} -result {can't use non-numeric string as operand of "*"}
test mathop-2.30 {interpreted *: errors} -returnCodes error -body {
$op nan 0
} -result {can't use non-numeric floating-point value as operand of "*"}
test mathop-2.31 {interpreted *: errors} -returnCodes error -body {
$op 0 x
} -result {can't use non-numeric string as operand of "*"}
test mathop-2.32 {interpreted *: errors} -returnCodes error -body {
$op 0 nan
} -result {can't use non-numeric floating-point value as operand of "*"}
test mathop-2.33 {interpreted *: errors} -returnCodes error -body {
$op 0o8 0
} -result {can't use invalid octal number as operand of "*"}
test mathop-2.34 {interpreted *: errors} -returnCodes error -body {
$op 0 0o8
} -result {can't use invalid octal number as operand of "*"}
test mathop-2.35 {interpreted *: errors} -returnCodes error -body {
$op 0 [error expectedError]
} -result expectedError
test mathop-2.36 {interpreted *: argument processing order} -body {
list [catch {
$op [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
} msg] $msg $x
} -result {1 expected 2}
test mathop-3.1 {compiled !} {! 0} 1
test mathop-3.2 {compiled !} {! 1} 0
test mathop-3.3 {compiled !} {! false} 1
test mathop-3.4 {compiled !} {! true} 0
test mathop-3.5 {compiled !} {! 0.0} 1
test mathop-3.6 {compiled !} {! 10000000000} 0
test mathop-3.7 {compiled !} {! 10000000000000000000000000} 0
test mathop-3.8 {compiled !: errors} -body {
! foobar
} -returnCodes error -result {can't use non-numeric string as operand of "!"}
test mathop-3.9 {compiled !: errors} -body {
! 0 0
} -returnCodes error -result "wrong # args: should be \"! boolean\""
test mathop-3.10 {compiled !: errors} -body {
!
} -returnCodes error -result "wrong # args: should be \"! boolean\""
set op !
test mathop-3.11 {interpreted !} {$op 0} 1
test mathop-3.12 {interpreted !} {$op 1} 0
test mathop-3.13 {interpreted !} {$op false} 1
test mathop-3.14 {interpreted !} {$op true} 0
test mathop-3.15 {interpreted !} {$op 0.0} 1
test mathop-3.16 {interpreted !} {$op 10000000000} 0
test mathop-3.17 {interpreted !} {$op 10000000000000000000000000} 0
test mathop-3.18 {interpreted !: errors} -body {
$op foobar
} -returnCodes error -result {can't use non-numeric string as operand of "!"}
test mathop-3.19 {interpreted !: errors} -body {
$op 0 0
} -returnCodes error -result "wrong # args: should be \"! boolean\""
test mathop-3.20 {interpreted !: errors} -body {
$op
} -returnCodes error -result "wrong # args: should be \"! boolean\""
test mathop-3.21 {compiled !: error} -returnCodes error -body {
! NaN
} -result {can't use non-numeric floating-point value as operand of "!"}
test mathop-3.22 {interpreted !: error} -returnCodes error -body {
$op NaN
} -result {can't use non-numeric floating-point value as operand of "!"}
test mathop-4.1 {compiled ~} {~ 0} -1
test mathop-4.2 {compiled ~} {~ 1} -2
test mathop-4.3 {compiled ~} {~ 31} -32
test mathop-4.4 {compiled ~} {~ -127} 126
test mathop-4.5 {compiled ~} {~ -0} -1
test mathop-4.6 {compiled ~} {~ 10000000000} -10000000001
test mathop-4.7 {compiled ~} {~ 10000000000000000000000000} -10000000000000000000000001
test mathop-4.8 {compiled ~: errors} -body {
~ foobar
} -returnCodes error -result {can't use non-numeric string as operand of "~"}
test mathop-4.9 {compiled ~: errors} -body {
~ 0 0
} -returnCodes error -result "wrong # args: should be \"~ integer\""
test mathop-4.10 {compiled ~: errors} -body {
~
} -returnCodes error -result "wrong # args: should be \"~ integer\""
test mathop-4.11 {compiled ~: errors} -returnCodes error -body {
~ 0.0
} -result {can't use floating-point value as operand of "~"}
test mathop-4.12 {compiled ~: errors} -returnCodes error -body {
~ NaN
} -result {can't use non-numeric floating-point value as operand of "~"}
set op ~
test mathop-4.13 {interpreted ~} {$op 0} -1
test mathop-4.14 {interpreted ~} {$op 1} -2
test mathop-4.15 {interpreted ~} {$op 31} -32
test mathop-4.16 {interpreted ~} {$op -127} 126
test mathop-4.17 {interpreted ~} {$op -0} -1
test mathop-4.18 {interpreted ~} {$op 10000000000} -10000000001
test mathop-4.19 {interpreted ~} {$op 10000000000000000000000000} -10000000000000000000000001
test mathop-4.20 {interpreted ~: errors} -body {
$op foobar
} -returnCodes error -result {can't use non-numeric string as operand of "~"}
test mathop-4.21 {interpreted ~: errors} -body {
$op 0 0
} -returnCodes error -result "wrong # args: should be \"~ integer\""
test mathop-4.22 {interpreted ~: errors} -body {
$op
} -returnCodes error -result "wrong # args: should be \"~ integer\""
test mathop-4.23 {interpreted ~: errors} -returnCodes error -body {
$op 0.0
} -result {can't use floating-point value as operand of "~"}
test mathop-4.24 {interpreted ~: errors} -returnCodes error -body {
$op NaN
} -result {can't use non-numeric floating-point value as operand of "~"}
test mathop-5.1 {compiled eq} {eq {} a} 0
test mathop-5.2 {compiled eq} {eq a a} 1
test mathop-5.3 {compiled eq} {eq a {}} 0
test mathop-5.4 {compiled eq} {eq a b} 0
test mathop-5.5 {compiled eq} { eq } 1
test mathop-5.6 {compiled eq} {eq a} 1
|
| ︙ | ︙ | |||
373 374 375 376 377 378 379 |
test mathop-6.1 {compiled &} { & } -1
test mathop-6.2 {compiled &} { & 1 } 1
test mathop-6.3 {compiled &} { & 1 2 } 0
test mathop-6.4 {compiled &} { & 3 7 6 } 2
test mathop-6.5 {compiled &} -returnCodes error -body {
& 1.0 2 3
| | | | | | | | | | | | | | | | | | 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 |
test mathop-6.1 {compiled &} { & } -1
test mathop-6.2 {compiled &} { & 1 } 1
test mathop-6.3 {compiled &} { & 1 2 } 0
test mathop-6.4 {compiled &} { & 3 7 6 } 2
test mathop-6.5 {compiled &} -returnCodes error -body {
& 1.0 2 3
} -result {can't use floating-point value as operand of "&"}
test mathop-6.6 {compiled &} -returnCodes error -body {
& 1 2 3.0
} -result {can't use floating-point value as operand of "&"}
test mathop-6.7 {compiled &} { & 100000000002 18 -126 } 2
test mathop-6.8 {compiled &} { & 0xff 0o377 333333333333 } 85
test mathop-6.9 {compiled &} { & 1000000000000000000002 18 -126 } 2
test mathop-6.10 {compiled &} { & 0xff 0o377 3333333333333333333333 } 85
test mathop-6.11 {compiled &: errors} -returnCodes error -body {
& x 0
} -result {can't use non-numeric string as operand of "&"}
test mathop-6.12 {compiled &: errors} -returnCodes error -body {
& nan 0
} -result {can't use non-numeric floating-point value as operand of "&"}
test mathop-6.13 {compiled &: errors} -returnCodes error -body {
& 0 x
} -result {can't use non-numeric string as operand of "&"}
test mathop-6.14 {compiled &: errors} -returnCodes error -body {
& 0 nan
} -result {can't use non-numeric floating-point value as operand of "&"}
test mathop-6.15 {compiled &: errors} -returnCodes error -body {
& 0o8 0
} -result {can't use invalid octal number as operand of "&"}
test mathop-6.16 {compiled &: errors} -returnCodes error -body {
& 0 0o8
} -result {can't use invalid octal number as operand of "&"}
test mathop-6.17 {compiled &: errors} -returnCodes error -body {
& 0 [error expectedError]
} -result expectedError
test mathop-6.18 {compiled &: argument processing order} -body {
# Bytecode compilation known hard for 3+ arguments
list [catch {
& [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
} msg] $msg $x
} -result {1 expected 2}
set op &
test mathop-6.19 {interpreted &} { $op } -1
test mathop-6.20 {interpreted &} { $op 1 } 1
test mathop-6.21 {interpreted &} { $op 1 2 } 0
test mathop-6.22 {interpreted &} { $op 3 7 6 } 2
test mathop-6.23 {interpreted &} -returnCodes error -body {
$op 1.0 2 3
} -result {can't use floating-point value as operand of "&"}
test mathop-6.24 {interpreted &} -returnCodes error -body {
$op 1 2 3.0
} -result {can't use floating-point value as operand of "&"}
test mathop-6.25 {interpreted &} { $op 100000000002 18 -126 } 2
test mathop-6.26 {interpreted &} { $op 0xff 0o377 333333333333 } 85
test mathop-6.27 {interpreted &} { $op 1000000000000000000002 18 -126 } 2
test mathop-6.28 {interpreted &} { $op 0xff 0o377 3333333333333333333333 } 85
test mathop-6.29 {interpreted &: errors} -returnCodes error -body {
$op x 0
} -result {can't use non-numeric string as operand of "&"}
test mathop-6.30 {interpreted &: errors} -returnCodes error -body {
$op nan 0
} -result {can't use non-numeric floating-point value as operand of "&"}
test mathop-6.31 {interpreted &: errors} -returnCodes error -body {
$op 0 x
} -result {can't use non-numeric string as operand of "&"}
test mathop-6.32 {interpreted &: errors} -returnCodes error -body {
$op 0 nan
} -result {can't use non-numeric floating-point value as operand of "&"}
test mathop-6.33 {interpreted &: errors} -returnCodes error -body {
$op 0o8 0
} -result {can't use invalid octal number as operand of "&"}
test mathop-6.34 {interpreted &: errors} -returnCodes error -body {
$op 0 0o8
} -result {can't use invalid octal number as operand of "&"}
test mathop-6.35 {interpreted &: errors} -returnCodes error -body {
$op 0 [error expectedError]
} -result expectedError
test mathop-6.36 {interpreted &: argument processing order} -body {
list [catch {
$op [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
} msg] $msg $x
|
| ︙ | ︙ | |||
483 484 485 486 487 488 489 |
test mathop-7.1 {compiled |} { | } 0
test mathop-7.2 {compiled |} { | 1 } 1
test mathop-7.3 {compiled |} { | 1 2 } 3
test mathop-7.4 {compiled |} { | 3 7 6 } 7
test mathop-7.5 {compiled |} -returnCodes error -body {
| 1.0 2 3
| | | | | | | | | | | | | | | | | | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 |
test mathop-7.1 {compiled |} { | } 0
test mathop-7.2 {compiled |} { | 1 } 1
test mathop-7.3 {compiled |} { | 1 2 } 3
test mathop-7.4 {compiled |} { | 3 7 6 } 7
test mathop-7.5 {compiled |} -returnCodes error -body {
| 1.0 2 3
} -result {can't use floating-point value as operand of "|"}
test mathop-7.6 {compiled |} -returnCodes error -body {
| 1 2 3.0
} -result {can't use floating-point value as operand of "|"}
test mathop-7.7 {compiled |} { | 100000000002 18 -126 } -110
test mathop-7.8 {compiled |} { | 0xff 0o377 333333333333 } 333333333503
test mathop-7.9 {compiled |} { | 1000000000000000000002 18 -126 } -110
test mathop-7.10 {compiled |} { | 0xff 0o377 3333333333333333333333 } 3333333333333333333503
test mathop-7.11 {compiled |: errors} -returnCodes error -body {
| x 0
} -result {can't use non-numeric string as operand of "|"}
test mathop-7.12 {compiled |: errors} -returnCodes error -body {
| nan 0
} -result {can't use non-numeric floating-point value as operand of "|"}
test mathop-7.13 {compiled |: errors} -returnCodes error -body {
| 0 x
} -result {can't use non-numeric string as operand of "|"}
test mathop-7.14 {compiled |: errors} -returnCodes error -body {
| 0 nan
} -result {can't use non-numeric floating-point value as operand of "|"}
test mathop-7.15 {compiled |: errors} -returnCodes error -body {
| 0o8 0
} -result {can't use invalid octal number as operand of "|"}
test mathop-7.16 {compiled |: errors} -returnCodes error -body {
| 0 0o8
} -result {can't use invalid octal number as operand of "|"}
test mathop-7.17 {compiled |: errors} -returnCodes error -body {
| 0 [error expectedError]
} -result expectedError
test mathop-7.18 {compiled |: argument processing order} -body {
# Bytecode compilation known hard for 3+ arguments
list [catch {
| [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
} msg] $msg $x
} -result {1 expected 2}
set op |
test mathop-7.19 {interpreted |} { $op } 0
test mathop-7.20 {interpreted |} { $op 1 } 1
test mathop-7.21 {interpreted |} { $op 1 2 } 3
test mathop-7.22 {interpreted |} { $op 3 7 6 } 7
test mathop-7.23 {interpreted |} -returnCodes error -body {
$op 1.0 2 3
} -result {can't use floating-point value as operand of "|"}
test mathop-7.24 {interpreted |} -returnCodes error -body {
$op 1 2 3.0
} -result {can't use floating-point value as operand of "|"}
test mathop-7.25 {interpreted |} { $op 100000000002 18 -126 } -110
test mathop-7.26 {interpreted |} { $op 0xff 0o377 333333333333 } 333333333503
test mathop-7.27 {interpreted |} { $op 1000000000000000000002 18 -126 } -110
test mathop-7.28 {interpreted |} { $op 0xff 0o377 3333333333333333333333 } 3333333333333333333503
test mathop-7.29 {interpreted |: errors} -returnCodes error -body {
$op x 0
} -result {can't use non-numeric string as operand of "|"}
test mathop-7.30 {interpreted |: errors} -returnCodes error -body {
$op nan 0
} -result {can't use non-numeric floating-point value as operand of "|"}
test mathop-7.31 {interpreted |: errors} -returnCodes error -body {
$op 0 x
} -result {can't use non-numeric string as operand of "|"}
test mathop-7.32 {interpreted |: errors} -returnCodes error -body {
$op 0 nan
} -result {can't use non-numeric floating-point value as operand of "|"}
test mathop-7.33 {interpreted |: errors} -returnCodes error -body {
$op 0o8 0
} -result {can't use invalid octal number as operand of "|"}
test mathop-7.34 {interpreted |: errors} -returnCodes error -body {
$op 0 0o8
} -result {can't use invalid octal number as operand of "|"}
test mathop-7.35 {interpreted |: errors} -returnCodes error -body {
$op 0 [error expectedError]
} -result expectedError
test mathop-7.36 {interpreted |: argument processing order} -body {
list [catch {
$op [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
} msg] $msg $x
|
| ︙ | ︙ | |||
593 594 595 596 597 598 599 |
test mathop-8.1 {compiled ^} { ^ } 0
test mathop-8.2 {compiled ^} { ^ 1 } 1
test mathop-8.3 {compiled ^} { ^ 1 2 } 3
test mathop-8.4 {compiled ^} { ^ 3 7 6 } 2
test mathop-8.5 {compiled ^} -returnCodes error -body {
^ 1.0 2 3
| | | | | | | | | | | | | | | | | | 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 |
test mathop-8.1 {compiled ^} { ^ } 0
test mathop-8.2 {compiled ^} { ^ 1 } 1
test mathop-8.3 {compiled ^} { ^ 1 2 } 3
test mathop-8.4 {compiled ^} { ^ 3 7 6 } 2
test mathop-8.5 {compiled ^} -returnCodes error -body {
^ 1.0 2 3
} -result {can't use floating-point value as operand of "^"}
test mathop-8.6 {compiled ^} -returnCodes error -body {
^ 1 2 3.0
} -result {can't use floating-point value as operand of "^"}
test mathop-8.7 {compiled ^} { ^ 100000000002 18 -126 } -100000000110
test mathop-8.8 {compiled ^} { ^ 0xff 0o377 333333333333 } 333333333333
test mathop-8.9 {compiled ^} { ^ 1000000000000000000002 18 -126 } -1000000000000000000110
test mathop-8.10 {compiled ^} { ^ 0xff 0o377 3333333333333333333333 } 3333333333333333333333
test mathop-8.11 {compiled ^: errors} -returnCodes error -body {
^ x 0
} -result {can't use non-numeric string as operand of "^"}
test mathop-8.12 {compiled ^: errors} -returnCodes error -body {
^ nan 0
} -result {can't use non-numeric floating-point value as operand of "^"}
test mathop-8.13 {compiled ^: errors} -returnCodes error -body {
^ 0 x
} -result {can't use non-numeric string as operand of "^"}
test mathop-8.14 {compiled ^: errors} -returnCodes error -body {
^ 0 nan
} -result {can't use non-numeric floating-point value as operand of "^"}
test mathop-8.15 {compiled ^: errors} -returnCodes error -body {
^ 0o8 0
} -result {can't use invalid octal number as operand of "^"}
test mathop-8.16 {compiled ^: errors} -returnCodes error -body {
^ 0 0o8
} -result {can't use invalid octal number as operand of "^"}
test mathop-8.17 {compiled ^: errors} -returnCodes error -body {
^ 0 [error expectedError]
} -result expectedError
test mathop-8.18 {compiled ^: argument processing order} -body {
# Bytecode compilation known hard for 3+ arguments
list [catch {
^ [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
} msg] $msg $x
} -result {1 expected 2}
set op ^
test mathop-8.19 {interpreted ^} { $op } 0
test mathop-8.20 {interpreted ^} { $op 1 } 1
test mathop-8.21 {interpreted ^} { $op 1 2 } 3
test mathop-8.22 {interpreted ^} { $op 3 7 6 } 2
test mathop-8.23 {interpreted ^} -returnCodes error -body {
$op 1.0 2 3
} -result {can't use floating-point value as operand of "^"}
test mathop-8.24 {interpreted ^} -returnCodes error -body {
$op 1 2 3.0
} -result {can't use floating-point value as operand of "^"}
test mathop-8.25 {interpreted ^} { $op 100000000002 18 -126 } -100000000110
test mathop-8.26 {interpreted ^} { $op 0xff 0o377 333333333333 } 333333333333
test mathop-8.27 {interpreted ^} { $op 1000000000000000000002 18 -126 } -1000000000000000000110
test mathop-8.28 {interpreted ^} { $op 0xff 0o377 3333333333333333333333 } 3333333333333333333333
test mathop-8.29 {interpreted ^: errors} -returnCodes error -body {
$op x 0
} -result {can't use non-numeric string as operand of "^"}
test mathop-8.30 {interpreted ^: errors} -returnCodes error -body {
$op nan 0
} -result {can't use non-numeric floating-point value as operand of "^"}
test mathop-8.31 {interpreted ^: errors} -returnCodes error -body {
$op 0 x
} -result {can't use non-numeric string as operand of "^"}
test mathop-8.32 {interpreted ^: errors} -returnCodes error -body {
$op 0 nan
} -result {can't use non-numeric floating-point value as operand of "^"}
test mathop-8.33 {interpreted ^: errors} -returnCodes error -body {
$op 0o8 0
} -result {can't use invalid octal number as operand of "^"}
test mathop-8.34 {interpreted ^: errors} -returnCodes error -body {
$op 0 0o8
} -result {can't use invalid octal number as operand of "^"}
test mathop-8.35 {interpreted ^: errors} -returnCodes error -body {
$op 0 [error expectedError]
} -result expectedError
test mathop-8.36 {interpreted ^: argument processing order} -body {
list [catch {
$op [set x 0] [incr x] NaN [incr x] [error expected] [incr x]
} msg] $msg $x
|
| ︙ | ︙ | |||
771 772 773 774 775 776 777 |
test mathop-20.6 { one arg, error } {
set res {}
set exp {}
foreach vals {x {1 x} {1 1 x} {1 x 1}} {
# skipping - for now, knownbug...
foreach op {+ * / & | ^ **} {
lappend res [TestOp $op {*}$vals]
| | | | 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 |
test mathop-20.6 { one arg, error } {
set res {}
set exp {}
foreach vals {x {1 x} {1 1 x} {1 x 1}} {
# skipping - for now, knownbug...
foreach op {+ * / & | ^ **} {
lappend res [TestOp $op {*}$vals]
lappend exp "can't use non-numeric string as operand of \"$op\"\
ARITH DOMAIN {non-numeric string}"
}
}
foreach op {+ * / & | ^ **} {
lappend res [TestOp $op NaN 1]
lappend exp "can't use non-numeric floating-point value as operand of \"$op\"\
ARITH DOMAIN {non-numeric floating-point value}"
}
expr {$res eq $exp ? 0 : $res}
} 0
test mathop-20.7 { multi arg } {
set res {}
foreach vals {{1 2} {3 4 5} {4 3 2 1}} {
|
| ︙ | ︙ | |||
846 847 848 849 850 851 852 |
set res
} [list 1.0 0.2 0.17857142857142858 -0.125 \
2.8196218755553604e-15 8.10000006561e-27]
test mathop-21.5 { unary ops, bad values } {
set res {}
set exp {}
lappend res [TestOp / x]
| | | | | | | 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 |
set res
} [list 1.0 0.2 0.17857142857142858 -0.125 \
2.8196218755553604e-15 8.10000006561e-27]
test mathop-21.5 { unary ops, bad values } {
set res {}
set exp {}
lappend res [TestOp / x]
lappend exp "can't use non-numeric string as operand of \"/\" ARITH DOMAIN {non-numeric string}"
lappend res [TestOp - x]
lappend exp "can't use non-numeric string as operand of \"-\" ARITH DOMAIN {non-numeric string}"
lappend res [TestOp ~ x]
lappend exp "can't use non-numeric string as operand of \"~\" ARITH DOMAIN {non-numeric string}"
lappend res [TestOp ! x]
lappend exp "can't use non-numeric string as operand of \"!\" ARITH DOMAIN {non-numeric string}"
lappend res [TestOp ~ 5.0]
lappend exp "can't use floating-point value as operand of \"~\" ARITH DOMAIN {floating-point value}"
expr {$res eq $exp ? 0 : $res}
} 0
test mathop-21.6 { unary ops, too many } {
set exp {}
foreach op {~ !} {
set res [TestOp $op 7 8]
if {[string match "wrong # args: should be * TCL WRONGARGS" $res]} {
|
| ︙ | ︙ | |||
961 962 963 964 965 966 967 |
70720 \
]
test mathop-22.4 { unary ops, bad values } {
set res {}
set exp {}
foreach op {& | ^} {
lappend res [TestOp $op x 5]
| | | | 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 |
70720 \
]
test mathop-22.4 { unary ops, bad values } {
set res {}
set exp {}
foreach op {& | ^} {
lappend res [TestOp $op x 5]
lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}"
lappend res [TestOp $op 5 x]
lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}"
}
expr {$res eq $exp ? 0 : $res}
} 0
test mathop-23.1 { comparison ops, numerical } {
set res {}
set todo {5 {1 6} {1 2 2 3} {4 3 2 1} {5.0 5.0} {6 3 3 1} {5.0 5}}
|
| ︙ | ︙ | |||
1076 1077 1078 1079 1080 1081 1082 |
0 \
]
test mathop-24.3 { binary ops, bad values } {
set res {}
set exp {}
foreach op {% << >>} {
lappend res [TestOp $op x 1]
| | | | | | 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 |
0 \
]
test mathop-24.3 { binary ops, bad values } {
set res {}
set exp {}
foreach op {% << >>} {
lappend res [TestOp $op x 1]
lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}"
lappend res [TestOp $op 1 x]
lappend exp "can't use non-numeric string as operand of \"$op\" ARITH DOMAIN {non-numeric string}"
}
foreach op {% << >>} {
lappend res [TestOp $op 5.0 1]
lappend exp "can't use floating-point value as operand of \"$op\" ARITH DOMAIN {floating-point value}"
lappend res [TestOp $op 1 5.0]
lappend exp "can't use floating-point value as operand of \"$op\" ARITH DOMAIN {floating-point value}"
}
foreach op {in ni} {
lappend res [TestOp $op 5 "a b \{ c"]
lappend exp "unmatched open brace in list TCL VALUE LIST BRACE"
}
lappend res [TestOp % 5 0]
lappend exp "divide by zero ARITH DIVZERO {divide by zero}"
|
| ︙ | ︙ | |||
1262 1263 1264 1265 1266 1267 1268 |
lappend res [TestOp ** $small $wide]
lappend exp "exponent too large NONE"
lappend res [TestOp ** 2 $big]
lappend exp "exponent too large NONE"
lappend res [TestOp ** $huge 2.1]
lappend exp "Inf"
lappend res [TestOp ** 2 foo]
| | | | 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 |
lappend res [TestOp ** $small $wide]
lappend exp "exponent too large NONE"
lappend res [TestOp ** 2 $big]
lappend exp "exponent too large NONE"
lappend res [TestOp ** $huge 2.1]
lappend exp "Inf"
lappend res [TestOp ** 2 foo]
lappend exp "can't use non-numeric string as operand of \"**\" ARITH DOMAIN {non-numeric string}"
lappend res [TestOp ** foo 2]
lappend exp "can't use non-numeric string as operand of \"**\" ARITH DOMAIN {non-numeric string}"
expr {$res eq $exp ? 0 : $res}
} 0
test mathop-26.1 { misc ops, size combinations } {
set big1 12135435435354435435342423948763867876
set big2 2746237174783836746262564892918327847
|
| ︙ | ︙ |
Changes to tests/namespace-old.test.
| ︙ | ︙ | |||
289 290 291 292 293 294 295 |
proc test_ns_show {} {return "[namespace current]: 2"}
namespace eval test_ns_hier3a {}
namespace eval test_ns_hier3b {}
}
namespace eval test_ns_hier2a {}
namespace eval test_ns_hier2b {}
}
| < | | | | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 |
proc test_ns_show {} {return "[namespace current]: 2"}
namespace eval test_ns_hier3a {}
namespace eval test_ns_hier3b {}
}
namespace eval test_ns_hier2a {}
namespace eval test_ns_hier2b {}
}
test namespace-old-5.4 {nested namespaces can access global namespace} {
list [namespace eval test_ns_hier1 {set test_ns_var_global}] \
[namespace eval test_ns_hier1 {test_ns_cmd_global}] \
[namespace eval test_ns_hier1::test_ns_hier2 {set test_ns_var_global}] \
[namespace eval test_ns_hier1::test_ns_hier2 {test_ns_cmd_global}]
} {{var in ::} {cmd in ::} {var in ::} {cmd in ::}}
test namespace-old-5.5 {variables in different namespaces don't conflict} {
list [set test_ns_hier1::test_ns_level] \
[set test_ns_hier1::test_ns_hier2::test_ns_level]
} {1 2}
test namespace-old-5.6 {commands in different namespaces don't conflict} {
list [test_ns_hier1::test_ns_show] \
[test_ns_hier1::test_ns_hier2::test_ns_show]
|
| ︙ | ︙ | |||
465 466 467 468 469 470 471 |
}
test namespace-old-6.11 {commands affect all parent namespaces} {
proc test_ns_cache1::test_ns_cache2::test_ns_cache_cmd {} {
return "cache2 version"
}
list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger]
} {{cache2 version} {cache2 version}}
| < | | < | | < | | | | 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 |
}
test namespace-old-6.11 {commands affect all parent namespaces} {
proc test_ns_cache1::test_ns_cache2::test_ns_cache_cmd {} {
return "cache2 version"
}
list [test_ns_cache1::trigger] [test_ns_cache1::test_ns_cache2::trigger]
} {{cache2 version} {cache2 version}}
test namespace-old-6.12 {define test variables} {
variable test_ns_cache_var "global version"
set trigger {set test_ns_cache_var}
namespace eval test_ns_cache1 $trigger
} {global version}
set trigger {set test_ns_cache_var}
test namespace-old-6.13 {one-level check for variable shadowing} {
namespace eval test_ns_cache1 {
variable test_ns_cache_var "cache1 version"
}
namespace eval test_ns_cache1 $trigger
} {cache1 version}
variable ::test_ns_cache_var "global version"
test namespace-old-6.14 {deleting variables changes variable epoch} {
namespace eval test_ns_cache1 {
variable test_ns_cache_var "cache1 version"
}
list [namespace eval test_ns_cache1 $trigger] \
[namespace eval test_ns_cache1 {unset test_ns_cache_var}] \
[namespace eval test_ns_cache1 $trigger]
} {{cache1 version} {} {global version}}
test namespace-old-6.15 {define test namespaces} {
namespace eval test_ns_cache2 {
variable test_ns_cache_var "global cache2 version"
}
set trigger2 {set test_ns_cache2::test_ns_cache_var}
list [namespace eval test_ns_cache1 $trigger2] \
[namespace eval test_ns_cache1::test_ns_cache2 $trigger]
} {{global cache2 version} {global version}}
set trigger2 {set test_ns_cache2::test_ns_cache_var}
test namespace-old-6.16 {public variables affect all parent namespaces} {
variable test_ns_cache1::test_ns_cache2::test_ns_cache_var "cache2 version"
list [namespace eval test_ns_cache1 $trigger2] \
[namespace eval test_ns_cache1::test_ns_cache2 $trigger]
} {{cache2 version} {cache2 version}}
test namespace-old-6.17 {usage for "namespace which"} {
|
| ︙ | ︙ |
Changes to tests/namespace.test.
| ︙ | ︙ | |||
42 43 44 45 46 47 48 |
list [namespace current] [namespace eval {} {namespace current}] \
[namespace eval {} {namespace current}]
} {:: :: ::}
test namespace-2.2 {Tcl_GetCurrentNamespace} {
set l {}
lappend l [namespace current]
namespace eval test_ns_1 {
| | | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 |
list [namespace current] [namespace eval {} {namespace current}] \
[namespace eval {} {namespace current}]
} {:: :: ::}
test namespace-2.2 {Tcl_GetCurrentNamespace} {
set l {}
lappend l [namespace current]
namespace eval test_ns_1 {
lappend l [namespace current]
namespace eval foo {
lappend l [namespace current]
}
}
lappend l [namespace current]
} {:: ::test_ns_1 ::test_ns_1::foo ::}
test namespace-3.1 {Tcl_GetGlobalNamespace} {
namespace eval test_ns_1 {namespace eval foo {namespace eval bar {} } }
|
| ︙ | ︙ | |||
642 643 644 645 646 647 648 |
}
} -body {
namespace eval test_ns_1 {
list [catch {set ::test_ns_777::v} msg] $msg \
[catch {namespace children test_ns_777} msg] $msg
}
} -result {1 {can't read "::test_ns_777::v": no such variable} 1 {namespace "test_ns_777" not found in "::test_ns_1"}}
| < < | < | < | 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 |
}
} -body {
namespace eval test_ns_1 {
list [catch {set ::test_ns_777::v} msg] $msg \
[catch {namespace children test_ns_777} msg] $msg
}
} -result {1 {can't read "::test_ns_777::v": no such variable} 1 {namespace "test_ns_777" not found in "::test_ns_1"}}
test namespace-14.3 {TclGetNamespaceForQualName, relative names} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
variable v 10
namespace eval test_ns_1::test_ns_2 {
variable v 20
}
namespace eval test_ns_2 {
variable v 30
}
} -body {
namespace eval test_ns_1 {
list $v $test_ns_2::v
}
} -result {10 20}
test namespace-14.4 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} {
namespace eval test_ns_1::test_ns_2 {
namespace eval foo {}
}
namespace eval test_ns_1 {
list [namespace children test_ns_2] \
[catch {namespace children test_ns_1} msg] $msg
|
| ︙ | ︙ | |||
720 721 722 723 724 725 726 |
catch {rename test_ns_1::test_ns_2:: {}}
set l {}
} -body {
lappend l [catch {test_ns_1::test_ns_2:: hello} msg] $msg
proc test_ns_1::test_ns_2:: {args} {return "\{\}: $args"}
lappend l [test_ns_1::test_ns_2:: hello]
} -result {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}}
| < < | | | | 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 |
catch {rename test_ns_1::test_ns_2:: {}}
set l {}
} -body {
lappend l [catch {test_ns_1::test_ns_2:: hello} msg] $msg
proc test_ns_1::test_ns_2:: {args} {return "\{\}: $args"}
lappend l [test_ns_1::test_ns_2:: hello]
} -result {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}}
test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
namespace eval test_ns_1 {
variable {}
set test_ns_1::(x) y
}
set test_ns_1::(x)
} -result y
test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -returnCodes error -body {
namespace eval test_ns_1 {
proc {} {} {}
namespace eval {} {}
{}
|
| ︙ | ︙ | |||
903 904 905 906 907 908 909 |
variable x 777
}
} -body {
namespace eval test_ns_1 {
set x
}
} -result {777}
| < < | | < < | | 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 |
variable x 777
}
} -body {
namespace eval test_ns_1 {
set x
}
} -result {777}
test namespace-17.7 {Tcl_FindNamespaceVar, relative name found} {
namespace eval test_ns_1 {
variable x 777
unset x
set x ;# must be global x now
}
} {314159}
test namespace-17.8 {Tcl_FindNamespaceVar, relative name not found} -body {
namespace eval test_ns_1 {
set wuzzat
}
} -returnCodes error -result {can't read "wuzzat": no such variable}
test namespace-17.9 {Tcl_FindNamespaceVar, relative name and TCL_GLOBAL_ONLY} {
namespace eval test_ns_1 {
variable a hello
}
set test_ns_1::a
} {hello}
test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} -setup {
namespace eval test_ns_1 {}
} -body {
proc test_ns {} {
set ::test_ns_1::a 0
}
test_ns
rename test_ns {}
namespace eval test_ns_1 unset a
set a 0
namespace eval test_ns_1 set a 1
namespace delete test_ns_1
return $a
} -result 1
catch {unset a}
catch {unset x}
catch {unset l}
catch {rename foo {}}
test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
|
| ︙ | ︙ | |||
1559 1560 1561 1562 1563 1564 1565 |
namespace eval test_ns_3 {
list [namespace which foreach] \
[namespace which p] \
[namespace which cmd1] \
[namespace which ::test_ns_2::cmd2]
}
} -result {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2}
| < < | | | 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 |
namespace eval test_ns_3 {
list [namespace which foreach] \
[namespace which p] \
[namespace which cmd1] \
[namespace which ::test_ns_2::cmd2]
}
} -result {::foreach ::test_ns_3::p ::test_ns_3::cmd1 ::test_ns_2::cmd2}
test namespace-34.7 {NamespaceWhichCmd, variable lookup} -setup {
catch {namespace delete {*}[namespace children test_ns_*]}
namespace eval test_ns_1 {
namespace export cmd*
proc cmd1 {args} {return "cmd1: $args"}
proc cmd2 {args} {return "cmd2: $args"}
}
namespace eval test_ns_2 {
namespace export *
namespace import ::test_ns_1::*
variable v2 222
proc p {} {}
}
namespace eval test_ns_3 {
variable v3 333
namespace import ::test_ns_2::*
}
} -body {
namespace eval test_ns_3 {
list [namespace which -variable env] \
[namespace which -variable v3] \
[namespace which -variable ::test_ns_2::v2] \
[catch {namespace which -variable ::test_ns_2::noSuchVar} msg] $msg
}
} -result {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}}
test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} -setup {
catch {namespace delete {*}[namespace children :: test_ns_*]}
} -body {
namespace eval test_ns_1 {
proc p {} {
namespace delete [namespace current]
|
| ︙ | ︙ | |||
2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 |
return global
}
lappend result [::test_ns_1::test_ns_2::pathtestA]
} -result "1,2,1,::test_ns_1 {global,2,global,:: ::test_ns_1} {global,1,global,:: ::test_ns_1} {global,global,global,:: ::test_ns_1}" -cleanup {
namespace delete ::test_ns_1
catch {rename ::pathtestB {}}
catch {rename ::pathtestD {}}
}
test namespace-51.7 {name resolution path control} -body {
namespace eval ::test_ns_1 {
}
namespace eval ::test_ns_2 {
namespace path ::test_ns_1
proc getpath {} {namespace path}
| > | 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 |
return global
}
lappend result [::test_ns_1::test_ns_2::pathtestA]
} -result "1,2,1,::test_ns_1 {global,2,global,:: ::test_ns_1} {global,1,global,:: ::test_ns_1} {global,global,global,:: ::test_ns_1}" -cleanup {
namespace delete ::test_ns_1
catch {rename ::pathtestB {}}
catch {rename ::pathtestD {}}
catch {rename ::pathtestC {}}
}
test namespace-51.7 {name resolution path control} -body {
namespace eval ::test_ns_1 {
}
namespace eval ::test_ns_2 {
namespace path ::test_ns_1
proc getpath {} {namespace path}
|
| ︙ | ︙ |
Changes to tests/oo.test.
| ︙ | ︙ | |||
107 108 109 110 111 112 113 |
}
leaktest {[foo new] destroy}
} -cleanup {
foo destroy
} -result 0
test oo-0.9 {various types of presence of the TclOO package} {
list [lsearch -nocase -all -inline [package names] tcloo] \
| | | | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 |
}
leaktest {[foo new] destroy}
} -cleanup {
foo destroy
} -result 0
test oo-0.9 {various types of presence of the TclOO package} {
list [lsearch -nocase -all -inline [package names] tcloo] \
[package present TclOO] [expr {$::oo::patchlevel in [package versions TclOO]}]
} [list TclOO $::oo::patchlevel 1]
test oo-1.1 {basic test of OO functionality: no classes} {
set result {}
lappend result [oo::object create foo]
lappend result [oo::objdefine foo {
method bar args {
global result
|
| ︙ | ︙ | |||
309 310 311 312 313 314 315 316 317 318 319 320 321 322 |
slave eval {
oo::define [oo::class create foo] superclass oo::class
oo::class destroy
}
} -cleanup {
interp delete slave
}
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"}
test oo-1.20 {basic test of OO functionality: my teardown post rename} -body {
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
slave eval {
oo::define [oo::class create foo] superclass oo::class
oo::class destroy
}
} -cleanup {
interp delete slave
}
test oo-1.18.4 {correct handling of cleanup in superclass set error} -setup {
interp create slave
} -body {
slave 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 slave
} -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 slave
} -body {
slave 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 slave
} -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"}
test oo-1.20 {basic test of OO functionality: my teardown post rename} -body {
|
| ︙ | ︙ | |||
1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 |
oo::class create boo
oo::define boo {superclass bar}
oo::define boo {mixin mixin}
oo::class create spong {superclass boo}
return
}
} -result {}
test oo-8.1 {OO: global must work in methods} {
oo::object create foo
oo::objdefine foo method bar x {global result; lappend result $x}
set result {}
foo bar this
foo bar is
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 |
oo::class create boo
oo::define boo {superclass bar}
oo::define boo {mixin mixin}
oo::class create spong {superclass boo}
return
}
} -result {}
test oo-7.10 {OO: next after object deletion, bug [135804138e]} -setup {
set ::result ""
oo::class create c1 {
method m1 {} {
lappend ::result c1::m1
}
}
oo::class create c2 {
superclass c1
destructor {
lappend ::result c2::destructor
my m1
lappend ::result /c2::destructor
}
method m1 {} {
lappend ::result c2::m1
rename [self] {}
lappend ::result no-self
next
lappend ::result /c2::m1
}
}
} -body {
c2 create o
lappend ::result [catch {o m1} msg] $msg
} -cleanup {
c1 destroy
unset ::result
} -result {c2::m1 c2::destructor c2::m1 no-self c1::m1 /c2::m1 /c2::destructor no-self 1 {no next method implementation}}
test oo-8.1 {OO: global must work in methods} {
oo::object create foo
oo::objdefine foo method bar x {global result; lappend result $x}
set result {}
foo bar this
foo bar is
|
| ︙ | ︙ |
Changes to tests/opt.test.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# the package we are going to test
| | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# the package we are going to test
package require opt 0.4.7
# we are using implementation specifics to test the package
#### functions tests #####
set n $::tcl::OptDescN
|
| ︙ | ︙ |
Changes to tests/parse.test.
| ︙ | ︙ | |||
372 373 374 375 376 377 378 |
variable ::aresult
variable ::acode
set aresult $result
set acode $code
return "new result"
}
set handler1 [testasync create async1]
| | | | | 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 |
variable ::aresult
variable ::acode
set aresult $result
set acode $code
return "new result"
}
set handler1 [testasync create async1]
set aresult xxx
set acode yyy
} -cleanup {
testasync delete
} -body {
list [testevalobjv 0 testasync mark $handler1 original 0] $acode $aresult
} -result {{new result} 0 original}
test parse-8.9 {Tcl_EvalObjv procedure, exceptional return} testevalobjv {
list [catch {testevalobjv 0 error message} msg] $msg
} {1 message}
test parse-8.10 {Tcl_EvalObjv procedure, TCL_EVAL_GLOBAL} testevalobjv {
rename ::unknown unknown.save
proc ::unknown args {lappend ::info [info level]}
|
| ︙ | ︙ |
Changes to tests/pid.test.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 |
}
testConstraint pidDefined [llength [info commands pid]]
test pid-1.1 {pid command} pidDefined {
regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
} 1
| | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 |
}
testConstraint pidDefined [llength [info commands pid]]
test pid-1.1 {pid command} pidDefined {
regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid]
} 1
test pid-1.2 {pid command} -constraints {unixOrWin unixExecs pidDefined} -setup {
set path(test1) [makeFile {} test1]
file delete $path(test1)
} -body {
set f [open |[list echo foo | cat >$path(test1)] w]
set pids [pid $f]
close $f
list [llength $pids] [regexp {^[0-9]+$} [lindex $pids 0]] \
|
| ︙ | ︙ |
Changes to tests/reg.test.
| ︙ | ︙ | |||
622 623 624 625 626 627 628 629 630 631 632 633 634 635 |
expectMatch 13.11 LMP "a\\e" "a\033" "a\033"
expectMatch 13.12 P "a\\fb" "a\fb" "a\fb"
expectMatch 13.13 P "a\\nb" "a\nb" "a\nb"
expectMatch 13.14 P "a\\rb" "a\rb" "a\rb"
expectMatch 13.15 P "a\\tb" "a\tb" "a\tb"
expectMatch 13.16 P "a\\u0008x" "a\bx" "a\bx"
expectMatch 13.17 P {a\u008x} "a\bx" "a\bx"
expectMatch 13.18 P "a\\u00088x" "a\b8x" "a\b8x"
expectMatch 13.19 P "a\\U00000008x" "a\bx" "a\bx"
expectMatch 13.20 P {a\U0000008x} "a\bx" "a\bx"
expectMatch 13.21 P "a\\vb" "a\vb" "a\vb"
expectMatch 13.22 MP "a\\x08x" "a\bx" "a\bx"
expectError 13.23 - {a\xq} EESCAPE
expectMatch 13.24 MP "a\\x08x" "a\bx" "a\bx"
| > | 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 |
expectMatch 13.11 LMP "a\\e" "a\033" "a\033"
expectMatch 13.12 P "a\\fb" "a\fb" "a\fb"
expectMatch 13.13 P "a\\nb" "a\nb" "a\nb"
expectMatch 13.14 P "a\\rb" "a\rb" "a\rb"
expectMatch 13.15 P "a\\tb" "a\tb" "a\tb"
expectMatch 13.16 P "a\\u0008x" "a\bx" "a\bx"
expectMatch 13.17 P {a\u008x} "a\bx" "a\bx"
expectError 13.17.1 - {a\ux} EESCAPE
expectMatch 13.18 P "a\\u00088x" "a\b8x" "a\b8x"
expectMatch 13.19 P "a\\U00000008x" "a\bx" "a\bx"
expectMatch 13.20 P {a\U0000008x} "a\bx" "a\bx"
expectMatch 13.21 P "a\\vb" "a\vb" "a\vb"
expectMatch 13.22 MP "a\\x08x" "a\bx" "a\bx"
expectError 13.23 - {a\xq} EESCAPE
expectMatch 13.24 MP "a\\x08x" "a\bx" "a\bx"
|
| ︙ | ︙ |
Changes to tests/regexp.test.
| ︙ | ︙ | |||
538 539 540 541 542 543 544 |
set junk [makeFile {puts [regexp {} foo]} junk.tcl]
} -body {
exec [interpreter] $junk
} -cleanup {
removeFile junk.tcl
} -result 1
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 |
set junk [makeFile {puts [regexp {} foo]} junk.tcl]
} -body {
exec [interpreter] $junk
} -cleanup {
removeFile junk.tcl
} -result 1
test regexp-15.1 {regexp -start} -body {
unset -nocomplain x
list [regexp -start -10 {\d} 1abc2de3 x] $x
} -result {1 1}
test regexp-15.2 {regexp -start} -body {
unset -nocomplain x
list [regexp -start 2 {\d} 1abc2de3 x] $x
} -result {1 2}
test regexp-15.3 {regexp -start} -body {
unset -nocomplain x
list [regexp -start 4 {\d} 1abc2de3 x] $x
} -result {1 2}
test regexp-15.4 {regexp -start} -body {
unset -nocomplain x
list [regexp -start 5 {\d} 1abc2de3 x] $x
} -result {1 3}
test regexp-15.5 {regexp -start, over end of string} -body {
unset -nocomplain x
list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x]
} -result {0 0}
test regexp-15.6 {regexp -start, loss of ^$ behavior} -body {
list [regexp -start 2 {^$} {}]
} -result {0}
test regexp-15.7 {regexp -start, double option} -body {
regexp -start 2 -start 0 a abc
} -result 1
test regexp-15.8 {regexp -start, double option} -body {
regexp -start 0 -start 2 a abc
} -result 0
test regexp-15.9 {regexp -start, end relative index} -body {
unset -nocomplain x
list [regexp -start end {\d} 1abc2de3 x] [info exists x]
} -result {0 0}
test regexp-15.10 {regexp -start, end relative index} -body {
unset -nocomplain x
list [regexp -start end-1 {\d} 1abc2de3 x] [info exists x] $x
} -result {1 1 3}
test regexp-15.11 {regexp -start, over end of string} -body {
set x NA
list [regexp -start 2 {.*} ab x] $x
} -result {1 {}}
test regexp-16.1 {regsub -start} -body {
unset -nocomplain x
list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x
} -result {4 a1b/2c/3d/4e/5}
test regexp-16.2 {regsub -start} -body {
unset -nocomplain x
list [regsub -all -start -25 {z} hello {/&} x] $x
} -result {0 hello}
test regexp-16.3 {regsub -start} -body {
unset -nocomplain x
list [regsub -all -start 3 {z} hello {/&} x] $x
} -result {0 hello}
test regexp-16.4 {regsub -start, \A behavior} -body {
set out {}
lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x
lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x
} -result {5 /a/b/c/d/e 3 ab/c/d/e}
test regexp-16.5 {regsub -start, double option} -body {
list [regsub -start 2 -start 0 a abc c x] $x
} -result {1 cbc}
test regexp-16.6 {regsub -start, double option} -body {
list [regsub -start 0 -start 2 a abc c x] $x
} -result {0 abc}
test regexp-16.7 {regexp -start, end relative index} -body {
list [regsub -start end a aaa b x] $x
} -result {0 aaa}
test regexp-16.8 {regexp -start, end relative index} -body {
list [regsub -start end-1 a aaa b x] $x
} -result {1 aab}
test regexp-16.9 {regsub -start and -all} -body {
set foo {}
list [regsub -start 0 -all x+ axxxbxx |&| foo] $foo
} -result {2 a|xxx|b|xx|}
test regexp-16.10 {regsub -start and -all} -body {
set foo {}
list [regsub -start 1 -all x+ axxxbxx |&| foo] $foo
} -result {2 a|xxx|b|xx|}
test regexp-16.11 {regsub -start and -all} -body {
set foo {}
list [regsub -start 4 -all x+ axxxbxx |&| foo] $foo
} -result {1 axxxb|xx|}
test regexp-16.12 {regsub -start} -body {
set foo {}
list [regsub -start 4 x+ axxxbxx |&| foo] $foo
} -result {1 axxxb|xx|}
test regexp-16.13 {regsub -start and -all} -body {
set foo {}
list [regsub -start 1 -all a+ "" & foo] $foo
} -result {0 {}}
test regexp-16.14 {regsub -start} -body {
set foo {}
list [regsub -start 1 a+ "" & foo] $foo
} -result {0 {}}
test regexp-16.15 {regsub -start and -all} -body {
set foo {}
list [regsub -start 2 -all a+ "xy" & foo] $foo
} -result {0 xy}
test regexp-16.16 {regsub -start} -body {
set foo {}
list [regsub -start 2 a+ "xy" & foo] $foo
} -result {0 xy}
test regexp-16.17 {regsub -start and -all} -body {
set foo {}
list [regsub -start 1 -all y+ "xy" & foo] $foo
} -result {1 xy}
test regexp-16.18 {regsub -start} -body {
set foo {}
list [regsub -start 1 y+ "xy" & foo] $foo
} -result {1 xy}
test regexp-16.19 {regsub -start} -body {
set foo {}
list [regsub -start -1 a+ "" & foo] $foo
} -result {0 {}}
test regexp-16.20 {regsub -start, loss of ^$ behavior} -body {
set foo NA
list [regsub -start 1 {^$} {} & foo] $foo
} -result {0 {}}
test regexp-16.21 {regsub -start, loss of ^$ behavior} -body {
set foo NA
list [regsub -start 1 {^.*$} abc & foo] $foo
} -result {0 abc}
test regexp-16.22 {regsub -start, loss of ^$ behavior} -body {
set foo NA
list [regsub -all -start 1 {^.*$} abc & foo] $foo
} -result {0 abc}
test regexp-17.1 {regexp -inline} {
regexp -inline b ababa
} {b}
test regexp-17.2 {regexp -inline} {
regexp -inline (b) ababa
} {b b}
|
| ︙ | ︙ | |||
750 751 752 753 754 755 756 |
test regexp-19.2 {regsub null replacement} {
regsub -all {@} {@hel@lo@} "\0a\0" result
set expected "\0a\0hel\0a\0lo\0a\0"
string equal $result $expected
} 1
| | | | | | | | | | | | | | | | | | | | | | | | 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 |
test regexp-19.2 {regsub null replacement} {
regsub -all {@} {@hel@lo@} "\0a\0" result
set expected "\0a\0hel\0a\0lo\0a\0"
string equal $result $expected
} 1
test regexp-20.1 {regsub shared object shimmering} -body {
# Bug #461322
set a abcdefghijklmnopqurstuvwxyz
set b $a
set c abcdefghijklmnopqurstuvwxyz0123456789
regsub $a $c $b d
list $d [string length $d] [string bytelength $d]
} -result [list abcdefghijklmnopqurstuvwxyz0123456789 37 37]
test regexp-20.2 {regsub shared object shimmering with -about} -body {
eval regexp -about abc
} -result {0 {}}
test regexp-21.1 {regsub works with empty string} -body {
regsub -- ^ {} foo
} -result {foo}
test regexp-21.2 {regsub works with empty string} -body {
regsub -- \$ {} foo
} -result {foo}
test regexp-21.3 {regsub works with empty string offset} -body {
regsub -start 0 -- ^ {} foo
} -result {foo}
test regexp-21.4 {regsub works with empty string offset} -body {
regsub -start 0 -- \$ {} foo
} -result {foo}
test regexp-21.5 {regsub works with empty string offset} -body {
regsub -start 3 -- \$ {123} foo
} -result {123foo}
test regexp-21.6 {regexp works with empty string} -body {
regexp -- ^ {}
} -result {1}
test regexp-21.7 {regexp works with empty string} -body {
regexp -start 0 -- ^ {}
} -result {1}
test regexp-21.8 {regexp works with empty string offset} -body {
regexp -start 3 -- ^ {123}
} -result {0}
test regexp-21.9 {regexp works with empty string offset} -body {
regexp -start 3 -- \$ {123}
} -result {1}
test regexp-21.10 {multiple matches handle newlines} {
regsub -all -lineanchor -- {^#[^\n]*\n} "#one\n#two\n#three\n" foo\n
} "foo\nfoo\nfoo\n"
test regexp-21.11 {multiple matches handle newlines} {
regsub -all -line -- ^ "a\nb\nc" \#
} "\#a\n\#b\n\#c"
test regexp-21.12 {multiple matches handle newlines} {
|
| ︙ | ︙ | |||
1092 1093 1094 1095 1096 1097 1098 |
test regexp-26.1 {matches start of line 1 time} {
regexp -all -inline -- {^a+} "aab\naaa"
} {aa}
test regexp-26.2 {matches start of line(s) 2 times} {
regexp -all -inline -line -- {^a+} "aab\naaa"
} {aa aaa}
| | | | 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 |
test regexp-26.1 {matches start of line 1 time} {
regexp -all -inline -- {^a+} "aab\naaa"
} {aa}
test regexp-26.2 {matches start of line(s) 2 times} {
regexp -all -inline -line -- {^a+} "aab\naaa"
} {aa aaa}
test regexp-26.3 {effect of -line -all and -start} -body {
list \
[regexp -all -inline -line -start 0 -- {^a+} "aab\naaa"] \
[regexp -all -inline -line -start 1 -- {^a+} "aab\naaa"] \
[regexp -all -inline -line -start 3 -- {^a+} "aab\naaa"] \
[regexp -all -inline -line -start 4 -- {^a+} "aab\naaa"] \
} -result {{aa aaa} aaa aaa aaa}
# No regexp-26.4
test regexp-26.5 {match length 0, match length 1} {
regexp -all -inline -line -- {^b*} "a\nb"
} {{} b}
test regexp-26.6 {non reporting capture group} {
regexp -all -inline -line -- {^(?:a+|b)} "aab\naaa"
} {aa aaa}
|
| ︙ | ︙ |
Changes to tests/regexpComp.test.
| ︙ | ︙ | |||
661 662 663 664 665 666 667 |
set junk [makeFile {puts [regexp {} foo]} junk.tcl]
} -body {
exec [interpreter] $junk
} -cleanup {
removeFile junk.tcl
} -result 1
| | | | | | | | | | | | | | | | | | | | | | | | | | 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 |
set junk [makeFile {puts [regexp {} foo]} junk.tcl]
} -body {
exec [interpreter] $junk
} -cleanup {
removeFile junk.tcl
} -result 1
test regexpComp-15.1 {regexp -start} -body {
unset -nocomplain x
list [regexp -start -10 {\d} 1abc2de3 x] $x
} -result {1 1}
test regexpComp-15.2 {regexp -start} -body {
unset -nocomplain x
list [regexp -start 2 {\d} 1abc2de3 x] $x
} -result {1 2}
test regexpComp-15.3 {regexp -start} -body {
unset -nocomplain x
list [regexp -start 4 {\d} 1abc2de3 x] $x
} -result {1 2}
test regexpComp-15.4 {regexp -start} -body {
unset -nocomplain x
list [regexp -start 5 {\d} 1abc2de3 x] $x
} -result {1 3}
test regexpComp-15.5 {regexp -start, over end of string} -body {
unset -nocomplain x
list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x]
} -result {0 0}
test regexpComp-15.6 {regexp -start, loss of ^$ behavior} -body {
list [regexp -start 2 {^$} {}]
} -result {0}
test regexpComp-16.1 {regsub -start} -body {
unset -nocomplain x
list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x
} -result {4 a1b/2c/3d/4e/5}
test regexpComp-16.2 {regsub -start} -body {
unset -nocomplain x
list [regsub -all -start -25 {z} hello {/&} x] $x
} -result {0 hello}
test regexpComp-16.3 {regsub -start} -body {
unset -nocomplain x
list [regsub -all -start 3 {z} hello {/&} x] $x
} -result {0 hello}
test regexpComp-16.4 {regsub -start, \A behavior} -body {
set out {}
lappend out [regsub -start 0 -all {\A(\w)} {abcde} {/\1} x] $x
lappend out [regsub -start 2 -all {\A(\w)} {abcde} {/\1} x] $x
} -result {5 /a/b/c/d/e 3 ab/c/d/e}
test regexpComp-17.1 {regexp -inline} -body {
regexp -inline b ababa
} -result {b}
test regexpComp-17.2 {regexp -inline} -body {
regexp -inline (b) ababa
} -result {b b}
test regexpComp-17.3 {regexp -inline -indices} {
regexp -inline -indices (b) ababa
} {{1 1} {1 1}}
test regexpComp-17.4 {regexp -inline} {
regexp -inline {\w(\d+)\w} " hello 23 there456def "
} {e456d 456}
test regexpComp-17.5 {regexp -inline no matches} {
|
| ︙ | ︙ |
Changes to tests/registry.test.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 |
namespace import -force ::tcltest::*
}
testConstraint reg 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
| | | | 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 |
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
}
}
# determine the current locale
testConstraint english [expr {
[llength [info commands testlocale]]
&& [string match "English*" [testlocale all ""]]
}]
test registry-1.0 {check if we are testing the right dll} {win reg} {
set ::regver
} {1.3.5}
test registry-1.1 {argument parsing for registry command} {win reg} {
list [catch {registry} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.1a {argument parsing for registry command} {win reg} {
list [catch {registry -32bit} msg] $msg
} {1 {wrong # args: should be "registry ?-32bit|-64bit? option ?arg ...?"}}
test registry-1.1b {argument parsing for registry command} {win reg} {
|
| ︙ | ︙ |
Changes to tests/result.test.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 |
testsaveresult small {set x 42} 0
} {small result}
test result-1.2 {Tcl_SaveInterpResult} {testsaveresult} {
testsaveresult append {set x 42} 0
} {append result}
test result-1.3 {Tcl_SaveInterpResult} {testsaveresult} {
testsaveresult dynamic {set x 42} 0
| | | | 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 |
testsaveresult small {set x 42} 0
} {small result}
test result-1.2 {Tcl_SaveInterpResult} {testsaveresult} {
testsaveresult append {set x 42} 0
} {append result}
test result-1.3 {Tcl_SaveInterpResult} {testsaveresult} {
testsaveresult dynamic {set x 42} 0
} {dynamic result presentOrFreed}
test result-1.4 {Tcl_SaveInterpResult} {testsaveresult} {
testsaveresult object {set x 42} 0
} {object result same}
test result-1.5 {Tcl_SaveInterpResult} {testsaveresult} {
testsaveresult small {set x 42} 1
} {42}
test result-1.6 {Tcl_SaveInterpResult} {testsaveresult} {
testsaveresult append {set x 42} 1
} {42}
test result-1.7 {Tcl_SaveInterpResult} {testsaveresult} {
testsaveresult dynamic {set x 42} 1
} {42 presentOrFreed}
test result-1.8 {Tcl_SaveInterpResult} {testsaveresult} {
testsaveresult object {set x 42} 1
} {42 different}
# Tcl_RestoreInterpResult is mostly tested by the previous tests except
# for the following case
|
| ︙ | ︙ |
Changes to tests/scan.test.
| ︙ | ︙ | |||
551 552 553 554 555 556 557 558 559 560 561 562 563 564 |
} -returnCodes 1 -result {unsigned bignum scans are invalid}
test scan-5.19 {bigint scanning invalid} -setup {
set a {};
} -body {
list [scan "207698809136909011942886895" \
%llu a] $a
} -result {1 207698809136909011942886895}
test scan-6.1 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
} -body {
list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d
} -result {3 2.1 -300000000.0 0.99962 {}}
test scan-6.2 {floating-point scanning} -setup {
| > > > > > | 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 |
} -returnCodes 1 -result {unsigned bignum scans are invalid}
test scan-5.19 {bigint scanning invalid} -setup {
set a {};
} -body {
list [scan "207698809136909011942886895" \
%llu a] $a
} -result {1 207698809136909011942886895}
test scan-5.20 {ignore digit separators} -setup {
set a {}; set b {}; set c {};
} -body {
list [scan "10_23_45" %d_%d_%d a b c] $a $b $c
} -result {3 10 23 45}
test scan-6.1 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
} -body {
list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d
} -result {3 2.1 -300000000.0 0.99962 {}}
test scan-6.2 {floating-point scanning} -setup {
|
| ︙ | ︙ | |||
596 597 598 599 600 601 602 603 604 605 606 607 608 609 |
list [scan "4.6abc" "%f %f %f %f" a b c d] $a $b $c $d
} -result {1 4.6 {} {} {}}
test scan-6.8 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
} -body {
list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d
} -result {2 4.6 5.2 {} {}}
test scan-7.1 {string and character scanning} -setup {
set a {}; set b {}; set c {}; set d {}
} -body {
list [scan "abc defghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d
} -result {4 abc def ghijk dum}
test scan-7.2 {string and character scanning} -setup {
| > > > > > | 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 |
list [scan "4.6abc" "%f %f %f %f" a b c d] $a $b $c $d
} -result {1 4.6 {} {} {}}
test scan-6.8 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
} -body {
list [scan "4.6 5.2" "%f %f %f %f" a b c d] $a $b $c $d
} -result {2 4.6 5.2 {} {}}
test scan-6.8 {disallow diget separator in floating-point} -setup {
set a {}; set b {}; set c {};
} -body {
list [scan "3.14_2.35_98.6" %f_%f_%f a b c ] $a $b $c
} -result {3 3.14 2.35 98.6}
test scan-7.1 {string and character scanning} -setup {
set a {}; set b {}; set c {}; set d {}
} -body {
list [scan "abc defghijk dum " "%s %3s %20s %s" a b c d] $a $b $c $d
} -result {4 abc def ghijk dum}
test scan-7.2 {string and character scanning} -setup {
|
| ︙ | ︙ |
Changes to tests/socket.test.
| ︙ | ︙ | |||
63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
if {[expr {[info exists ::env(TRAVIS_OSX_IMAGE)] && [string match xcode* $::env(TRAVIS_OSX_IMAGE)]}]} {
return
}
# 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]]
# 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 {
| > > | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
::tcltest::loadTestedCommands
if {[expr {[info exists ::env(TRAVIS_OSX_IMAGE)] && [string match xcode* $::env(TRAVIS_OSX_IMAGE)]}]} {
return
}
# 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(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
# 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 {
|
| ︙ | ︙ | |||
1079 1080 1081 1082 1083 1084 1085 |
after cancel $timer
close $s
close $s1
} -result {1 3}
test socket_$af-7.5 {testing socket specific options} -setup {
set timer [after 10000 "set x timed_out"]
set l ""
| | | 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 |
after cancel $timer
close $s
close $s1
} -result {1 3}
test socket_$af-7.5 {testing socket specific options} -setup {
set timer [after 10000 "set x timed_out"]
set l ""
} -constraints [list socket supported_$af unixOrWin] -body {
set s [socket -server accept 0]
proc accept {s a p} {
global x
set x [fconfigure $s -sockname]
close $s
}
set listen [lindex [fconfigure $s -sockname] 2]
|
| ︙ | ︙ | |||
1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 |
puts $s "hello"
gets $s result
}
close $s
thread::release $serverthread
append result " " [llength [thread::names]]
} -result {hello 1} -constraints [list socket supported_$af thread]
# ----------------------------------------------------------------------
removeFile script1
removeFile script2
# cleanup
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 |
puts $s "hello"
gets $s result
}
close $s
thread::release $serverthread
append result " " [llength [thread::names]]
} -result {hello 1} -constraints [list socket supported_$af thread]
proc transf_test {{testmode transfer} {maxIter 1000} {maxTime 10000}} {
try {
set ::count 0
set ::testmode $testmode
set port 0
set srvsock {}
# if binding on port 0 is not possible (system related, blocked on ISPs etc):
if {[catch {close [socket -async $::localhost $port]}]} {
# simplest server on random port (immediatelly closing a connect):
set port [randport]
set srvsock [socket -server {apply {{ch args} {close $ch}}} -myaddr $::localhost $port]
# socket on windows has some issues yet (e. g. bug [b6d0d8cc2c]), so we simply decrease iteration count (to 1/4):
if {$::tcl_platform(platform) eq "windows" && $maxIter > 50} {
set ::count [expr {$maxIter / 4 * 3 - 1}]; # bypass 3/4 iterations
}
}
tcltest::DebugPuts 1 "== test \[$::localhost\]:$port $testmode =="
set ::master [thread::id]
# helper thread creating async connection and initiating transfer (detach) to master:
set ::helper [thread::create]
thread::send -async $::helper [list \
lassign [list $::master $::localhost $port $testmode] \
::master ::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 $::master {set ::count "ERROR: invalid thread, $::helper is expecting"}
close $fd
return
}
}} $fd]
};#
thread::detach $fd
thread::send -async $::master [list transf_master $fd {*}$args]
}
iteration first
}
# master proc commiting transfer attempt (attach) and checking acquire was successful:
proc transf_master {fd args} {
tcltest::DebugPuts 1 "** trma / $::count ** $args **"
thread::attach $fd
if {"master-close" in $::testmode} {;# to test close during connect
set ::count $::count
close $fd
return
};#
fileevent $fd writable [list apply {{fd} {
if {[thread::id] ne $::master} {
thread::send -async $::master {set ::count "ERROR: invalid thread, $::master is expecting"}
close $fd
return
}
set ::count $::count
close $fd
}} $fd]
}
# repeat maxIter times (up to maxTime ms as timeout):
set tout [after $maxTime {set ::count "TIMEOUT"}]
while 1 {
vwait ::count
if {![string is integer $::count]} {
# if timeout just skip (test was successful until now):
if {$::count eq "TIMEOUT"} {::tcltest::Skip "timing issue"}
break
}
if {[incr ::count] >= $maxIter} break
tcltest::DebugPuts 1 "** iter / $::count **"
thread::send -async $::helper [list iteration nr $::count]
}
update
set ::count
} finally {
catch {after cancel $tout}
if {$srvsock ne {}} {close $srvsock}
if {[info exists ::helper]} {thread::release -wait $::helper}
tcltest::DebugPuts 1 "== stop / $::count =="
unset -nocomplain ::count ::testmode ::master ::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 {master-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 {master-close helper-writable} 100
} -result 100 -constraints [list socket supported_$af thread]
catch {rename transf_master {}}
rename transf_test {}
# ----------------------------------------------------------------------
removeFile script1
removeFile script2
# cleanup
|
| ︙ | ︙ | |||
2281 2282 2283 2284 2285 2286 2287 |
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} \
| | | 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 |
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 knownMsvcBug} \
-body {
set sock [socket -async localhost [randport]]
fconfigure $sock -blocking 0
puts $sock ok
fileevent $sock writable {set x 1}
vwait x
close $sock
|
| ︙ | ︙ |
Changes to tests/source.test.
| ︙ | ︙ | |||
236 237 238 239 240 241 242 |
# and use of the Control-Z character (\u001A) as a cross-platform
# EOF character by [source]. Here we write out and the [source] a
# file that contains the byte \x1A, although not the character \u001A in
# the indicated encoding.
set sourcefile [makeFile {} source.file]
file delete $sourcefile
set f [open $sourcefile w]
| | | | 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 |
# and use of the Control-Z character (\u001A) as a cross-platform
# EOF character by [source]. Here we write out and the [source] a
# file that contains the byte \x1A, although not the character \u001A in
# the indicated encoding.
set sourcefile [makeFile {} source.file]
file delete $sourcefile
set f [open $sourcefile w]
fconfigure $f -encoding utf-16
puts $f "set symbol(square-root) \u221A; set x correct"
close $f
} -body {
set x unset
source -encoding utf-16 $sourcefile
set x
} -cleanup {
removeFile source.file
} -result correct
test source-7.3 {source -encoding: syntax} -body {
# Have to spell out the -encoding option
source -e utf-8 no_file
|
| ︙ | ︙ |
Changes to tests/split.test.
| ︙ | ︙ | |||
67 68 69 70 71 72 73 |
test split-1.13 {basic split commands} {
split "12,34,56," {,}
} {12 34 56 {}}
test split-1.14 {basic split commands} {
split ",12,,,34,56," {,}
} {{} 12 {} {} 34 56 {}}
test split-1.15 {basic split commands} -body {
| | | > > > | 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 |
test split-1.13 {basic split commands} {
split "12,34,56," {,}
} {12 34 56 {}}
test split-1.14 {basic split commands} {
split ",12,,,34,56," {,}
} {{} 12 {} {} 34 56 {}}
test split-1.15 {basic split commands} -body {
split "a\U1F4A9b" {}
} -result "a \U1F4A9 b"
test split-1.16 {basic split commands} -body {
split "a\U1F4A9b" \U1F4A9
} -result "a b"
test split-2.1 {split errors} {
list [catch split msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} {TCL WRONGARGS}}
test split-2.2 {split errors} {
list [catch {split a b c} msg] $msg $errorCode
} {1 {wrong # args: should be "split string ?splitChars?"} {TCL WRONGARGS}}
|
| ︙ | ︙ |
Changes to tests/string.test.
| ︙ | ︙ | |||
27 28 29 30 31 32 33 |
proc makeShared {s} {uplevel 1 [list lappend copy $s]; return $s}
# Some tests require the testobj command
testConstraint testobj [expr {[info commands testobj] ne {}}]
testConstraint testindexobj [expr {[info commands testindexobj] ne {}}]
testConstraint testevalex [expr {[info commands testevalex] ne {}}]
| | > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
proc makeShared {s} {uplevel 1 [list lappend copy $s]; return $s}
# Some tests require the testobj command
testConstraint testobj [expr {[info commands testobj] ne {}}]
testConstraint testindexobj [expr {[info commands testindexobj] ne {}}]
testConstraint testevalex [expr {[info commands testevalex] ne {}}]
testConstraint utf16 [expr {[string length \U010000] == 2}]
testConstraint testbytestring [llength [info commands testbytestring]]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc getbytes {} {
set lines [split [memory info] \n]
return [lindex $lines 3 3]
|
| ︙ | ︙ | |||
117 118 119 120 121 122 123 |
test string-2.10.$noComp {string compare with special index} {
list [catch {run {string compare -length end-3 abcde abxyz}} msg] $msg
} {1 {expected integer but got "end-3"}}
test string-2.11.$noComp {string compare, unicode} {
run {string compare ab\u7266 ab\u7267}
} -1
test string-2.11.1.$noComp {string compare, unicode} {
| | | | 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 |
test string-2.10.$noComp {string compare with special index} {
list [catch {run {string compare -length end-3 abcde abxyz}} msg] $msg
} {1 {expected integer but got "end-3"}}
test string-2.11.$noComp {string compare, unicode} {
run {string compare ab\u7266 ab\u7267}
} -1
test string-2.11.1.$noComp {string compare, unicode} {
run {string compare \334 \xDC}
} 0
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 comparaison
# is using signed chars instead of unsigned chars.
|
| ︙ | ︙ | |||
147 148 149 150 151 152 153 |
test string-2.14.$noComp {string compare -nocase} {
run {string compare -nocase abcde ABCDE}
} 0
test string-2.15.$noComp {string compare -nocase} {
run {string compare -nocase abcde abcde}
} 0
test string-2.15.1.$noComp {string compare -nocase} {
| | | | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 |
test string-2.14.$noComp {string compare -nocase} {
run {string compare -nocase abcde ABCDE}
} 0
test string-2.15.$noComp {string compare -nocase} {
run {string compare -nocase abcde abcde}
} 0
test string-2.15.1.$noComp {string compare -nocase} {
run {string compare -nocase \334 \xDC}
} 0
test string-2.15.2.$noComp {string compare -nocase} {
run {string compare -nocase \334\334\334\374\xFC \334\334\334\334\334}
} 0
test string-2.16.$noComp {string compare -nocase with length} {
run {string compare -length 2 -nocase abcde Abxyz}
} 0
test string-2.17.$noComp {string compare -nocase with length} {
run {string compare -nocase -length 3 abcde Abxyz}
} -1
|
| ︙ | ︙ | |||
272 273 274 275 276 277 278 |
list [catch {run {string equal -length end-3 abcde abxyz}} msg] $msg
} {1 {expected integer but got "end-3"}}
test string-3.16.$noComp {string equal, unicode} {
run {string equal ab\u7266 ab\u7267}
} 0
test string-3.17.$noComp {string equal, unicode} {
| | | | | | 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 |
list [catch {run {string equal -length end-3 abcde abxyz}} msg] $msg
} {1 {expected integer but got "end-3"}}
test string-3.16.$noComp {string equal, unicode} {
run {string equal ab\u7266 ab\u7267}
} 0
test string-3.17.$noComp {string equal, unicode} {
run {string equal \334 \xDC}
} 1
test string-3.18.$noComp {string equal, unicode} {
run {string equal \334 \xFC}
} 0
test string-3.19.$noComp {string equal, unicode} {
run {string equal \334\334\334\374\374 \334\334\334\334\334}
} 0
test string-3.20.$noComp {string equal, high bit} {
# This test will fail if the underlying comparaison
# is using signed chars instead of unsigned chars.
# (like SunOS's default memcmp thus the compat/memcmp.c)
run {string equal "\x80" "@"}
# Nb this tests works also in utf8 space because \x80 is
# translated into a 2 or more bytelength but whose first byte has
# the high bit set.
} 0
test string-3.21.$noComp {string equal -nocase} {
run {string equal -nocase abcde Abdef}
} 0
test string-3.22.$noComp {string equal, -nocase unicode} {
run {string equal -nocase \334 \xDC}
} 1
test string-3.23.$noComp {string equal, -nocase unicode} {
run {string equal -nocase \334\334\334\374\xFC \334\334\334\334\334}
} 1
test string-3.24.$noComp {string equal -nocase with length} {
run {string equal -length 2 -nocase abcde Abxyz}
} 1
test string-3.25.$noComp {string equal -nocase with length} {
run {string equal -nocase -length 3 abcde Abxyz}
} 0
|
| ︙ | ︙ | |||
394 395 396 397 398 399 400 |
} 4
test string-4.10.$noComp {string first, unicode} {
run {string first \u7266 abc\u7266x}
} 3
test string-4.11.$noComp {string first, start index} {
run {string first \u7266 abc\u7266x 3}
} 3
| | | | | | | | | | | | | | | | | | | | | | | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 |
} 4
test string-4.10.$noComp {string first, unicode} {
run {string first \u7266 abc\u7266x}
} 3
test string-4.11.$noComp {string first, start index} {
run {string first \u7266 abc\u7266x 3}
} 3
test string-4.12.$noComp {string first, start index} -body {
run {string first \u7266 abc\u7266x 4}
} -result -1
test string-4.13.$noComp {string first, start index} -body {
run {string first \u7266 abc\u7266x end-2}
} -result 3
test string-4.14.$noComp {string first, negative start index} -body {
run {string first b abc -1}
} -result 1
test string-4.15.$noComp {string first, ability to two-byte encoded utf-8 chars} -body {
# Test for a bug in Tcl 8.3 where test for all-single-byte-encoded
# strings was incorrect, leading to an index returned by [string first]
# which pointed past the end of the string.
set uchar \u057E ;# character with two-byte encoding in utf-8
run {string first % %#$uchar$uchar#$uchar$uchar#% 3}
} -result 8
test string-4.16.$noComp {string first, normal string vs pure unicode string} -body {
set s hello
regexp ll $s m
# Representation checks are canaries
run {list [representationpoke $s] [representationpoke $m] \
[string first $m $s]}
} -result {{string 1} {string 0} 2}
test string-4.17.$noComp {string first, corner case} -body {
run {string first a aaa 4294967295}
} -result {-1}
test string-4.18.$noComp {string first, corner case} -body {
run {string first a aaa -1}
} -result {0}
test string-4.19.$noComp {string first, corner case} -body {
run {string first a aaa end-5}
} -result {0}
test string-4.20.$noComp {string last, corner case} -body {
run {string last a aaa 4294967295}
} -result {2}
test string-4.21.$noComp {string last, corner case} -body {
run {string last a aaa -1}
} -result {-1}
test string-4.22.$noComp {string last, corner case} {
run {string last a aaa end-5}
} {-1}
test string-5.1.$noComp {string index} {
list [catch {run {string index}} msg] $msg
} {1 {wrong # args: should be "string index string charIndex"}}
|
| ︙ | ︙ | |||
469 470 471 472 473 474 475 |
} b
test string-5.10.$noComp {string index, unicode} {
run {string index abc\u7266d 4}
} d
test string-5.11.$noComp {string index, unicode} {
run {string index abc\u7266d 3}
} \u7266
| | | | | | | | | | 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 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 |
} b
test string-5.10.$noComp {string index, unicode} {
run {string index abc\u7266d 4}
} d
test string-5.11.$noComp {string index, unicode} {
run {string index abc\u7266d 3}
} \u7266
test string-5.12.$noComp {string index, unicode over char length, under byte length} -body {
run {string index \334\374\334\374 6}
} -result {}
test string-5.13.$noComp {string index, bytearray object} {
run {string index [binary format a5 fuz] 0}
} f
test string-5.14.$noComp {string index, bytearray object} {
run {string index [binary format I* {0x50515253 0x52}] 3}
} S
test string-5.15.$noComp {string index, bytearray object} {
set b [binary format I* {0x50515253 0x52}]
set i1 [run {string index $b end-6}]
set i2 [run {string index $b 1}]
run {string compare $i1 $i2}
} 0
test string-5.16.$noComp {string index, bytearray object with string obj shimmering} {
set str "0123456789\x00 abcdedfghi"
binary scan $str H* dump
run {string compare [run {string index $str 10}] \x00}
} 0
test string-5.17.$noComp {string index, bad integer} -body {
list [catch {run {string index "abc" 0o8}} msg] $msg
} -match glob -result {1 {*invalid octal number*}}
test string-5.18.$noComp {string index, bad integer} -body {
list [catch {run {string index "abc" end-0o0289}} msg] $msg
} -match glob -result {1 {*invalid octal number*}}
test string-5.19.$noComp {string index, bytearray object out of bounds} {
run {string index [binary format I* {0x50515253 0x52}] -1}
} {}
test string-5.20.$noComp {string index, bytearray object out of bounds} -body {
run {string index [binary format I* {0x50515253 0x52}] 20}
} -result {}
test string-5.21.$noComp {string index, surrogates, bug [11ae2be95dac9417]} -constraints utf16 -body {
run {list [string index a\U100000b 1] [string index a\U100000b 2] [string index a\U100000b 3]}
} -result [list \U100000 {} b]
proc largest_int {} {
# This will give us what the largest valid int on this machine is,
# so we can test for overflow properly below on >32 bit systems
set int 1
set exp 7; # assume we get at least 8 bits
|
| ︙ | ︙ | |||
555 556 557 558 559 560 561 |
} 0
test string-6.12.$noComp {string is alnum, true} {
run {string is alnum abc123}
} 1
test string-6.13.$noComp {string is alnum, false} {
list [run {string is alnum -failindex var abc1.23}] $var
} {0 4}
| | | | | | 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 |
} 0
test string-6.12.$noComp {string is alnum, true} {
run {string is alnum abc123}
} 1
test string-6.13.$noComp {string is alnum, false} {
list [run {string is alnum -failindex var abc1.23}] $var
} {0 4}
test string-6.14.$noComp {string is alnum, unicode} "run {string is alnum abc\xFC}" 1
test string-6.15.$noComp {string is alpha, true} {
run {string is alpha abc}
} 1
test string-6.16.$noComp {string is alpha, false} {
list [run {string is alpha -fail var a1bcde}] $var
} {0 1}
test string-6.17.$noComp {string is alpha, unicode} {
run {string is alpha abc\374}
} 1
test string-6.18.$noComp {string is ascii, true} {
run {string is ascii abc\x7Fend\x00}
} 1
test string-6.19.$noComp {string is ascii, false} {
list [run {string is ascii -fail var abc\x00def\x80more}] $var
} {0 7}
test string-6.20.$noComp {string is boolean, true} {
run {string is boolean true}
} 1
test string-6.21.$noComp {string is boolean, true} {
run {string is boolean f}
} 1
test string-6.22.$noComp {string is boolean, true based on type} {
run {string is bool [run {string compare a a}]}
} 1
test string-6.23.$noComp {string is boolean, false} {
list [run {string is bool -fail var yada}] $var
} {0 0}
test string-6.24.$noComp {string is digit, true} {
run {string is digit 0123456789}
} 1
test string-6.25.$noComp {string is digit, false} {
list [run {string is digit -fail var 0123\xDC567}] $var
} {0 4}
test string-6.26.$noComp {string is digit, false} {
list [run {string is digit -fail var +123567}] $var
} {0 0}
test string-6.27.$noComp {string is double, true} {
run {string is double 1}
} 1
|
| ︙ | ︙ | |||
710 711 712 713 714 715 716 |
test string-6.59.$noComp {string is integer, false on bad hex} {
list [run {string is integer -fail var 0X345XYZ}] $var
} {0 5}
test string-6.60.$noComp {string is lower, true} {
run {string is lower abc}
} 1
test string-6.61.$noComp {string is lower, unicode true} {
| | | | 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 |
test string-6.59.$noComp {string is integer, false on bad hex} {
list [run {string is integer -fail var 0X345XYZ}] $var
} {0 5}
test string-6.60.$noComp {string is lower, true} {
run {string is lower abc}
} 1
test string-6.61.$noComp {string is lower, unicode true} {
run {string is lower abc\xFCue}
} 1
test string-6.62.$noComp {string is lower, false} {
list [run {string is lower -fail var aBc}] $var
} {0 1}
test string-6.63.$noComp {string is lower, false} {
list [run {string is lower -fail var abc1}] $var
} {0 3}
test string-6.64.$noComp {string is lower, unicode false} {
list [run {string is lower -fail var ab\xDCUE}] $var
} {0 2}
test string-6.65.$noComp {string is space, true} {
run {string is space " \t\n\v\f"}
} 1
test string-6.66.$noComp {string is space, false} {
list [run {string is space -fail var " \t\n\v1\f"}] $var
} {0 4}
|
| ︙ | ︙ | |||
757 758 759 760 761 762 763 |
catch {unset var}
list [run {string is true -fail var no}] $var
} {0 0}
test string-6.75.$noComp {string is upper, true} {
run {string is upper ABC}
} 1
test string-6.76.$noComp {string is upper, unicode true} {
| | | | | | | | | 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 |
catch {unset var}
list [run {string is true -fail var no}] $var
} {0 0}
test string-6.75.$noComp {string is upper, true} {
run {string is upper ABC}
} 1
test string-6.76.$noComp {string is upper, unicode true} {
run {string is upper ABC\xDCUE}
} 1
test string-6.77.$noComp {string is upper, false} {
list [run {string is upper -fail var AbC}] $var
} {0 1}
test string-6.78.$noComp {string is upper, false} {
list [run {string is upper -fail var AB2C}] $var
} {0 2}
test string-6.79.$noComp {string is upper, unicode false} {
list [run {string is upper -fail var ABC\xFCue}] $var
} {0 3}
test string-6.80.$noComp {string is wordchar, true} {
run {string is wordchar abc_123}
} 1
test string-6.81.$noComp {string is wordchar, unicode true} {
run {string is wordchar abc\xFCab\xDCAB\u5001\U1D7CA}
} 1
test string-6.82.$noComp {string is wordchar, false} {
list [run {string is wordchar -fail var abcd.ef}] $var
} {0 4}
test string-6.83.$noComp {string is wordchar, unicode false} {
list [run {string is wordchar -fail var abc\x80def}] $var
} {0 3}
test string-6.84.$noComp {string is control} {
## Control chars are in the ranges
## 00..1F && 7F..9F
list [run {string is control -fail var \x00\x01\x10\x1F\x7F\x80\x9F\x60}] $var
} {0 7}
test string-6.85.$noComp {string is control} {
run {string is control \u0100}
} 0
test string-6.86.$noComp {string is graph} {
## graph is any print char, except space
list [run {string is gra -fail var "0123abc!@#\$\u0100\UE0100\UE01EF "}] $var
} {0 14}
test string-6.87.$noComp {string is print} {
## basically any printable char
list [run {string is print -fail var "0123abc!@#\$\u0100 \UE0100\UE01EF\x10"}] $var
} {0 15}
test string-6.88.$noComp {string is punct} {
## any graph char that isn't alnum
list [run {string is punct -fail var "_!@#\xBEq0"}] $var
} {0 4}
test string-6.89.$noComp {string is xdigit} {
list [run {string is xdigit -fail var 0123456789\x61bcdefABCDEFg}] $var
} {0 22}
test string-6.90.$noComp {string is integer, bad integers} {
# SF bug #634856
set result ""
set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"]
foreach num $numbers {
|
| ︙ | ︙ | |||
891 892 893 894 895 896 897 |
} {1 1 0 0 0 1 0 0}
test string-6.108.$noComp {string is double, Bug 1382287} {
set x 2turtledoves
run {string is double $x}
run {string is double $x}
} 0
test string-6.109.$noComp {string is double, Bug 1360532} {
| | | 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 |
} {1 1 0 0 0 1 0 0}
test string-6.108.$noComp {string is double, Bug 1382287} {
set x 2turtledoves
run {string is double $x}
run {string is double $x}
} 0
test string-6.109.$noComp {string is double, Bug 1360532} {
run {string is double 1\xA0}
} 0
test string-6.110.$noComp {string is entier, true} {
run {string is entier +1234567890}
} 1
test string-6.111.$noComp {string is entier, true on type} {
run {string is entier [expr wide(50.0)]}
} 1
|
| ︙ | ︙ | |||
1026 1027 1028 1029 1030 1031 1032 |
test string-8.1.$noComp {string bytelength} {
list [catch {run {string bytelength}} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
test string-8.2.$noComp {string bytelength} {
list [catch {run {string bytelength a b}} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
test string-8.3.$noComp {string bytelength} {
| | | 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 |
test string-8.1.$noComp {string bytelength} {
list [catch {run {string bytelength}} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
test string-8.2.$noComp {string bytelength} {
list [catch {run {string bytelength a b}} msg] $msg
} {1 {wrong # args: should be "string bytelength string"}}
test string-8.3.$noComp {string bytelength} {
run {string bytelength "\xC7"}
} 2
test string-8.4.$noComp {string bytelength} {
run {string b ""}
} 0
test string-9.1.$noComp {string length} {
list [catch {run {string length}} msg] $msg
|
| ︙ | ︙ | |||
1374 1375 1376 1377 1378 1379 1380 |
test string-11.51.$noComp {string match; *, -nocase and UTF-8} {
run {string match -nocase [binary format I 717316707] \
[binary format I 2028036707]}
} 1
test string-11.52.$noComp {string match, null char in string} {
set out ""
set ptn "*abc*"
| | | | | | | | | | | | | 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 |
test string-11.51.$noComp {string match; *, -nocase and UTF-8} {
run {string match -nocase [binary format I 717316707] \
[binary format I 2028036707]}
} 1
test string-11.52.$noComp {string match, null char in string} {
set out ""
set ptn "*abc*"
foreach elem [list "\x00@abc" "@abc" "\x00@abc\x00" "blahabcblah"] {
lappend out [run {string match $ptn $elem}]
}
set out
} {1 1 1 1}
test string-11.53.$noComp {string match, null char in pattern} {
set out ""
foreach {ptn elem} [list \
"*\x00abc\x00" "\x00abc\x00" \
"*\x00abc\x00" "\x00abc\x00ef" \
"*\x00abc\x00*" "\x00abc\x00ef" \
"*\x00abc\x00" "@\x00abc\x00ef" \
"*\x00abc\x00*" "@\x00abc\x00ef" \
] {
lappend out [run {string match $ptn $elem}]
}
set out
} {1 0 1 0 1}
test string-11.54.$noComp {string match, failure} {
set longString ""
for {set i 0} {$i < 10} {incr i} {
append longString "abcdefghijklmnopqrstuvwxy\x00z01234567890123"
}
run {string first $longString 123}
list [run {string match *cba* $longString}] \
[run {string match *a*l*\x00* $longString}] \
[run {string match *a*l*\x00*123 $longString}] \
[run {string match *a*l*\x00*123* $longString}] \
[run {string match *a*l*\x00*cba* $longString}] \
[run {string match *===* $longString}]
} {0 1 1 1 0 0}
test string-11.55.$noComp {string match, invalid binary optimization} {
[format string] match \u0141 [binary format c 65]
} 0
test stringComp-12.1.0.$noComp {Bug 3588366: end-offsets before start} {
|
| ︙ | ︙ | |||
1475 1476 1477 1478 1479 1480 1481 |
test string-12.19.$noComp {string range, bytearray object} {
set b [binary format I* {0x50515253 0x52}]
set r1 [run {string range $b 1 end-1}]
set r2 [run {string range $b 1 6}]
run {string equal $r1 $r2}
} 1
test string-12.20.$noComp {string range, out of bounds indices} {
| | | | 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 |
test string-12.19.$noComp {string range, bytearray object} {
set b [binary format I* {0x50515253 0x52}]
set r1 [run {string range $b 1 end-1}]
set r2 [run {string range $b 1 6}]
run {string equal $r1 $r2}
} 1
test string-12.20.$noComp {string range, out of bounds indices} {
run {string range \xFF 0 1}
} \xFF
# Bug 1410553
test string-12.21.$noComp {string range, regenerates correct reps, bug 1410553} {
set bytes "\x00 \x03 \x41"
set rxBuffer {}
foreach ch $bytes {
append rxBuffer $ch
if {$ch eq "\x03"} {
|
| ︙ | ︙ | |||
1498 1499 1500 1501 1502 1503 1504 |
list $input_hex $rxBuffer_hex $rxCRC_hex
} {000341 000341 0341}
test string-12.22.$noComp {string range, shimmering binary/index} {
set s 0000000001
binary scan $s a* x
run {string range $s $s end}
} 000000001
| | | 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 |
list $input_hex $rxBuffer_hex $rxCRC_hex
} {000341 000341 0341}
test string-12.22.$noComp {string range, shimmering binary/index} {
set s 0000000001
binary scan $s a* x
run {string range $s $s end}
} 000000001
test string-12.23.$noComp {string range, surrogates, bug [11ae2be95dac9417]} utf16 {
run {list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3]}
} [list \U100000 {} b]
test string-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} {
|
| ︙ | ︙ | |||
1560 1561 1562 1563 1564 1565 1566 |
list [catch {run {string replace a 1 2 3 4}} msg] $msg
} {1 {wrong # args: should be "string replace string first last ?string?"}}
test string-14.4.$noComp {string replace} {
} {}
test string-14.5.$noComp {string replace} {
run {string replace abcdefghijklmnop 2 14}
} {abp}
| | | | | | 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 |
list [catch {run {string replace a 1 2 3 4}} msg] $msg
} {1 {wrong # args: should be "string replace string first last ?string?"}}
test string-14.4.$noComp {string replace} {
} {}
test string-14.5.$noComp {string replace} {
run {string replace abcdefghijklmnop 2 14}
} {abp}
test string-14.6.$noComp {string replace} -body {
run {string replace abcdefghijklmnop 7 1000}
} -result {abcdefg}
test string-14.7.$noComp {string replace} {
run {string replace abcdefghijklmnop 10 end}
} {abcdefghij}
test string-14.8.$noComp {string replace} {
run {string replace abcdefghijklmnop 10 9}
} {abcdefghijklmnop}
test string-14.9.$noComp {string replace} {
run {string replace abcdefghijklmnop -3 2}
} {defghijklmnop}
test string-14.10.$noComp {string replace} {
run {string replace abcdefghijklmnop -3 -2}
} {abcdefghijklmnop}
test string-14.11.$noComp {string replace} -body {
run {string replace abcdefghijklmnop 1000 1010}
} -result {abcdefghijklmnop}
test string-14.12.$noComp {string replace} {
run {string replace abcdefghijklmnop -100 end}
} {}
test string-14.13.$noComp {string replace} {
list [catch {run {string replace abc abc 1}} msg] $msg
} {1 {bad index "abc": must be integer?[+-]integer? or end?[+-]integer?}}
test string-14.14.$noComp {string replace} {
|
| ︙ | ︙ | |||
1644 1645 1646 1647 1648 1649 1650 |
for { set i 0 } { $i < $x } { incr i } {
set val [format "0%s" $val]
}
string replace $val[unset val] 1 1 $y
}} 4 x
} 0x00
test stringComp-14.25.$noComp {} {
| | | 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 |
for { set i 0 } { $i < $x } { incr i } {
set val [format "0%s" $val]
}
string replace $val[unset val] 1 1 $y
}} 4 x
} 0x00
test stringComp-14.25.$noComp {} {
string length [string replace [string repeat a\xFE 2] 3 end {}]
} 3
test string-15.1.$noComp {string tolower too few 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
|
| ︙ | ︙ | |||
1675 1676 1677 1678 1679 1680 1681 |
test string-15.8.$noComp {string tolower} {
run {string tolower ABC 1 end}
} Abc
test string-15.9.$noComp {string tolower} {
run {string tolower ABC 0 end-1}
} abC
test string-15.10.$noComp {string tolower, unicode} {
| | | | 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 |
test string-15.8.$noComp {string tolower} {
run {string tolower ABC 1 end}
} Abc
test string-15.9.$noComp {string tolower} {
run {string tolower ABC 0 end-1}
} abC
test string-15.10.$noComp {string tolower, unicode} {
run {string tolower ABCabc\xC7\xE7}
} "abcabc\xE7\xE7"
test string-15.11.$noComp {string tolower, compiled} {
lindex [run {string tolower [list A B [list C]]}] 1
} b
test string-16.1.$noComp {string toupper} {
list [catch {run {string toupper}} msg] $msg
} {1 {wrong # args: should be "string toupper string ?first? ?last?"}}
|
| ︙ | ︙ | |||
1709 1710 1711 1712 1713 1714 1715 |
test string-16.8.$noComp {string toupper} {
run {string toupper abc 1 end}
} aBC
test string-16.9.$noComp {string toupper} {
run {string toupper abc 0 end-1}
} ABc
test string-16.10.$noComp {string toupper, unicode} {
| | | | | | | | | 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 |
test string-16.8.$noComp {string toupper} {
run {string toupper abc 1 end}
} aBC
test string-16.9.$noComp {string toupper} {
run {string toupper abc 0 end-1}
} ABc
test string-16.10.$noComp {string toupper, unicode} {
run {string toupper ABCabc\xC7\xE7}
} "ABCABC\xC7\xC7"
test string-16.11.$noComp {string toupper, compiled} {
lindex [run {string toupper [list a b [list c]]}] 1
} B
test string-17.1.$noComp {string totitle} {
list [catch {run {string totitle}} msg] $msg
} {1 {wrong # args: should be "string totitle string ?first? ?last?"}}
test string-17.2.$noComp {string totitle} {
list [catch {run {string totitle a b}} msg] $msg
} {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}}
test string-17.3.$noComp {string totitle} {
run {string totitle abCDEf}
} {Abcdef}
test string-17.4.$noComp {string totitle} {
run {string totitle "abc xYz"}
} {Abc xyz}
test string-17.5.$noComp {string totitle} {
run {string totitle {123#$&*()}}
} {123#$&*()}
test string-17.6.$noComp {string totitle, unicode} {
run {string totitle ABCabc\xC7\xE7}
} "Abcabc\xE7\xE7"
test string-17.7.$noComp {string totitle, unicode} {
run {string totitle \u01F3BCabc\xC7\xE7}
} "\u01F2bcabc\xE7\xE7"
test string-17.8.$noComp {string totitle, compiled} {
lindex [run {string totitle [list aa bb [list cc]]}] 0
} Aa
test string-17.9.$noComp {string totitle, surrogates, bug [11ae2be95dac9417]} utf16 {
run {list [string totitle a\U118c0c 1 1] [string totitle a\U118c0c 2 2] \
[string totitle a\U118c0c 3 3]}
} [list a\U118a0c a\U118c0C a\U118c0C]
test string-18.1.$noComp {string trim} {
list [catch {run {string trim}} msg] $msg
} {1 {wrong # args: should be "string trim string ?chars?"}}
|
| ︙ | ︙ | |||
1775 1776 1777 1778 1779 1780 1781 |
test string-18.9.$noComp {string trim} {
run {string trim {}}
} {}
test string-18.10.$noComp {string trim} {
run {string trim ABC DEF}
} {ABC}
test string-18.11.$noComp {string trim, unicode} {
| | | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > > | 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 |
test string-18.9.$noComp {string trim} {
run {string trim {}}
} {}
test string-18.10.$noComp {string trim} {
run {string trim ABC DEF}
} {ABC}
test string-18.11.$noComp {string trim, unicode} {
run {string trim "\xE7\xE8 AB\xE7C \xE8\xE7" \xE7\xE8}
} " AB\xE7C "
test string-18.12.$noComp {string trim, unicode default} {
run {string trim \uFEFF\x00\x85\xA0\u1680\u180EABC\u1361\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000}
} ABC\u1361
test string-19.1.$noComp {string trimleft} {
list [catch {run {string trimleft}} msg] $msg
} {1 {wrong # args: should be "string trimleft string ?chars?"}}
test string-19.2.$noComp {string trimleft} {
run {string trimleft " XYZ "}
} {XYZ }
test string-19.3.$noComp {string trimleft, unicode default} {
run {string trimleft \uFEFF\x85\xA0\x00\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000\u1361ABC}
} \u1361ABC
test string-20.1.$noComp {string trimright errors} {
list [catch {run {string trimright}} msg] $msg
} {1 {wrong # args: should be "string trimright string ?chars?"}}
test string-20.2.$noComp {string trimright errors} {
list [catch {run {string trimg a}} msg] $msg
} {1 {unknown or ambiguous subcommand "trimg": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-20.3.$noComp {string trimright} {
run {string trimright " XYZ "}
} { XYZ}
test string-20.4.$noComp {string trimright} {
run {string trimright " "}
} {}
test string-20.5.$noComp {string trimright} {
run {string trimright ""}
} {}
test string-20.6.$noComp {string trimright, unicode default} {
run {string trimright ABC\u1361\x85\x00\xA0\u1680\u180E\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200A\u200B\u2028\u2029\u202F\u205F\u3000}
} ABC\u1361
test string-20.7.$noComp {string trim on not valid utf-8 sequence (consider NTS as continuation char), bug [c61818e4c9]} {testbytestring} {
set result {}
set a [testbytestring \xC0\x80\xA0]
set b foo$a
set m [list \x00 U \xA0 V [testbytestring \xA0] W]
lappend result [string map $m $b]
lappend result [string map $m [run {string trimright $b x}]]
lappend result [string map $m [run {string trimright $b \x00}]]
lappend result [string map $m [run {string trimleft $b fox}]]
lappend result [string map $m [run {string trimleft $b fo\x00}]]
lappend result [string map $m [run {string trim $b fox}]]
lappend result [string map $m [run {string trim $b fo\x00}]]
} [list {*}[lrepeat 3 fooUV] {*}[lrepeat 2 UV V]]
test string-20.8.$noComp {[c61818e4c9] [string trimright] fails when UtfPrev is ok} {testbytestring} {
set result {}
set a [testbytestring \xE8\xA0]
set b foo$a
set m [list \xE8 U \xA0 V [testbytestring \xE8] W [testbytestring \xA0] X]]
lappend result [string map $m $b]
lappend result [string map $m [run {string trimright $b x}]]
lappend result [string map $m [run {string trimright $b \xE8}]]
lappend result [string map $m [run {string trimright $b [testbytestring \xE8]}]]
lappend result [string map $m [run {string trimright $b \xA0}]]
lappend result [string map $m [run {string trimright $b [testbytestring \xA0]}]]
lappend result [string map $m [run {string trimright $b \xE8\xA0}]]
lappend result [string map $m [run {string trimright $b [testbytestring \xE8\xA0]}]]
lappend result [string map $m [run {string trimright $b \u0000}]]
} [list {*}[lrepeat 4 fooUV] {*}[lrepeat 2 fooU] {*}[lrepeat 2 foo] fooUV]
test string-21.1.$noComp {string wordend} -body {
list [catch {run {string wordend a}} msg] $msg
} -result {1 {wrong # args: should be "string wordend string index"}}
test string-21.2.$noComp {string wordend} -body {
list [catch {run {string wordend a b c}} msg] $msg
} -result {1 {wrong # args: should be "string wordend string index"}}
test string-21.3.$noComp {string wordend} -body {
list [catch {run {string wordend a gorp}} msg] $msg
} -result {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}}
test string-21.4.$noComp {string wordend} -body {
run {string wordend abc. -1}
} -result 3
test string-21.5.$noComp {string wordend} -body {
run {string wordend abc. 100}
} -result 4
test string-21.6.$noComp {string wordend} -body {
run {string wordend "word_one two three" 2}
} -result 8
test string-21.7.$noComp {string wordend} -body {
run {string wordend "one .&# three" 5}
} -result 6
test string-21.8.$noComp {string wordend} -body {
run {string worde "x.y" 0}
} -result 1
test string-21.9.$noComp {string wordend} -body {
run {string worde "x.y" end-1}
} -result 2
test string-21.10.$noComp {string wordend, unicode} -body {
run {string wordend "xyz\xC7de fg" 0}
} -result 6
test string-21.11.$noComp {string wordend, unicode} -body {
run {string wordend "xyz\uC700de fg" 0}
} -result 6
test string-21.12.$noComp {string wordend, unicode} -body {
run {string wordend "xyz\u203Fde fg" 0}
} -result 6
test string-21.13.$noComp {string wordend, unicode} -body {
run {string wordend "xyz\u2045de fg" 0}
} -result 3
test string-21.14.$noComp {string wordend, unicode} -body {
run {string wordend "\uC700\uC700 abc" 8}
} -result 6
test string-21.15.$noComp {string wordend, unicode} -body {
run {string wordend "\U1D7CA\U1D7CA abc" 0}
} -result 2
test string-21.16.$noComp {string wordend, unicode} -constraints utf16 -body {
run {string wordend "\U1D7CA\U1D7CA abc" 10}
} -result 8
test string-22.1.$noComp {string wordstart} -body {
list [catch {run {string word a}} msg] $msg
} -result {1 {unknown or ambiguous subcommand "word": must be bytelength, cat, compare, equal, first, index, insert, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}}
test string-22.2.$noComp {string wordstart} -body {
list [catch {run {string wordstart a}} msg] $msg
} -result {1 {wrong # args: should be "string wordstart string index"}}
test string-22.3.$noComp {string wordstart} -body {
list [catch {run {string wordstart a b c}} msg] $msg
} -result {1 {wrong # args: should be "string wordstart string index"}}
test string-22.4.$noComp {string wordstart} -body {
list [catch {run {string wordstart a gorp}} msg] $msg
} -result {1 {bad index "gorp": must be integer?[+-]integer? or end?[+-]integer?}}
test string-22.5.$noComp {string wordstart} -body {
run {string wordstart "one two three_words" 400}
} -result 8
test string-22.6.$noComp {string wordstart} -body {
run {string wordstart "one two three_words" 2}
} -result 0
test string-22.7.$noComp {string wordstart} -body {
run {string wordstart "one two three_words" -2}
} -result 0
test string-22.8.$noComp {string wordstart} -body {
run {string wordstart "one .*&^ three" 6}
} -result 6
test string-22.9.$noComp {string wordstart} -body {
run {string wordstart "one two three" 4}
} -result 4
test string-22.10.$noComp {string wordstart} -body {
run {string wordstart "one two three" end-5}
} -result 7
test string-22.11.$noComp {string wordstart, unicode} -body {
run {string wordstart "one tw\xC7o three" 7}
} -result 4
test string-22.12.$noComp {string wordstart, unicode} -body {
run {string wordstart "ab\uC700\uC700 cdef ghi" 12}
} -result 10
test string-22.13.$noComp {string wordstart, unicode} -body {
run {string wordstart "\uC700\uC700 abc" 8}
} -result 3
test string-22.14.$noComp {string wordstart, invalid UTF-8} -constraints testbytestring -body {
# See Bug c61818e4c9
set demo [testbytestring "abc def\xE0\xA9ghi"]
run {string index $demo [string wordstart $demo 10]}
} -result g
test string-22.15.$noComp {string wordstart, unicode} -body {
run {string wordstart "\U1D7CA\U1D7CA abc" 0}
} -result 0
test string-22.16.$noComp {string wordstart, unicode} -constraints utf16 -body {
run {string wordstart "\U1D7CA\U1D7CA abc" 10}
} -result 5
test string-23.0.$noComp {string is boolean, Bug 1187123} testindexobj {
set x 5
catch {testindexobj $x foo bar soom}
run {string is boolean $x}
} 0
test string-23.1.$noComp {string is command with empty string} {
|
| ︙ | ︙ | |||
1961 1962 1963 1964 1965 1966 1967 |
} edcba
test string-24.4.$noComp {string reverse command - unshared string} {
set x abc
set y de
run {string reverse $x$y}
} edcba
test string-24.5.$noComp {string reverse command - shared unicode string} {
| | | | | | | | | | | | | | | | | 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 |
} edcba
test string-24.4.$noComp {string reverse command - unshared string} {
set x abc
set y de
run {string reverse $x$y}
} edcba
test string-24.5.$noComp {string reverse command - shared unicode string} {
set x abcde\uD0AD
run {string reverse $x}
} \uD0ADedcba
test string-24.6.$noComp {string reverse command - unshared string} {
set x abc
set y de\uD0AD
run {string reverse $x$y}
} \uD0ADedcba
test string-24.7.$noComp {string reverse command - simple case} {
run {string reverse a}
} a
test string-24.8.$noComp {string reverse command - simple case} {
run {string reverse \uD0AD}
} \uD0AD
test string-24.9.$noComp {string reverse command - simple case} {
run {string reverse {}}
} {}
test string-24.10.$noComp {string reverse command - corner case} {
set x \uBEEF\uD0AD
run {string reverse $x}
} \uD0AD\uBEEF
test string-24.11.$noComp {string reverse command - corner case} {
set x \uBEEF
set y \uD0AD
run {string reverse $x$y}
} \uD0AD\uBEEF
test string-24.12.$noComp {string reverse command - corner case} {
set x \uBEEF
set y \uD0AD
run {string is ascii [run {string reverse $x$y}]}
} 0
test string-24.13.$noComp {string reverse command - pure Unicode string} {
run {string reverse [run {string range \uBEEF\uD0AD\uBEEF\uD0AD\uBEEF\uD0AD 1 5}]}
} \uD0AD\uBEEF\uD0AD\uBEEF\uD0AD
test string-24.14.$noComp {string reverse command - pure bytearray} {
binary scan [run {string reverse [binary format H* 010203]}] H* x
set x
} 030201
test string-24.15.$noComp {string reverse command - pure bytearray} {
binary scan [run {tcl::string::reverse [binary format H* 010203]}] H* x
set x
|
| ︙ | ︙ | |||
2050 2051 2052 2053 2054 2055 2056 |
} {1 {}}
test string-25.13.$noComp {string is list} {
set x {}
list [run {string is list -failindex x { {b c}d e}}] $x
} {0 2}
test string-25.14.$noComp {string is list} {
set x {}
| | | 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 |
} {1 {}}
test string-25.13.$noComp {string is list} {
set x {}
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, too few 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
|
| ︙ | ︙ | |||
2471 2472 2473 2474 2475 2476 2477 |
} {1 {}}
test string-32.13.$noComp {string is dict} {
set x {}
list [string is dict -failindex x { {b c}d e}] $x
} {0 2}
test string-32.14.$noComp {string is dict} {
set x {}
| | | 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 |
} {1 {}}
test string-32.13.$noComp {string is dict} {
set x {}
list [string is dict -failindex x { {b c}d e}] $x
} {0 2}
test string-32.14.$noComp {string is dict} {
set x {}
list [string is dict -failindex x "\uABCD {b c}d e"] $x
} {0 2}
test string-32.15.$noComp {string is dict, valid dict} {
string is dict {a b c d e f}
} 1
test string-32.16.$noComp {string is dict, invalid dict} {
string is dict a
} 0
|
| ︙ | ︙ |
Changes to tests/stringObj.test.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
::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]]
test stringObj-1.1 {string type registration} testobj {
set t [testobj types]
set first [string first "string" $t]
set result [expr {$first != -1}]
} {1}
| > > | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 |
::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 != -1}]
} {1}
|
| ︙ | ︙ | |||
435 436 437 438 439 440 441 |
} 1
test stringObj-13.8 {Tcl_GetCharLength with identity nulls} {testobj testbytestring} {
string length [testbytestring \x01\x00\x02]
} 3
test stringObj-14.1 {Tcl_SetObjLength on pure unicode object} testobj {
teststringobj set 1 foo
| | | | 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 |
} 1
test stringObj-13.8 {Tcl_GetCharLength with identity nulls} {testobj testbytestring} {
string length [testbytestring \x01\x00\x02]
} 3
test stringObj-14.1 {Tcl_SetObjLength on pure unicode object} testobj {
teststringobj set 1 foo
teststringobj maxchars 1
teststringobj append 1 bar -1
teststringobj maxchars 1
teststringobj append 1 bar -1
teststringobj setlength 1 0
teststringobj append 1 bar -1
teststringobj get 1
} {bar}
test stringObj-15.1 {Tcl_Append*ToObj: self appends} testobj {
|
| ︙ | ︙ | |||
460 461 462 463 464 465 466 |
teststringobj set 1 foo
teststringobj appendself 1 2
} fooo
test stringObj-15.4 {Tcl_Append*ToObj: self appends} testobj {
teststringobj set 1 foo
teststringobj appendself 1 3
} foo
| | | | | | 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 |
teststringobj set 1 foo
teststringobj appendself 1 2
} fooo
test stringObj-15.4 {Tcl_Append*ToObj: self appends} testobj {
teststringobj set 1 foo
teststringobj appendself 1 3
} foo
test stringObj-15.5 {Tcl_Append*ToObj: self appends} {testobj tip389 nodep} {
teststringobj set 1 foo
teststringobj appendself2 1 0
} foofoo
test stringObj-15.6 {Tcl_Append*ToObj: self appends} {testobj tip389 nodep} {
teststringobj set 1 foo
teststringobj appendself2 1 1
} foooo
test stringObj-15.7 {Tcl_Append*ToObj: self appends} {testobj tip389 nodep} {
teststringobj set 1 foo
teststringobj appendself2 1 2
} fooo
test stringObj-15.8 {Tcl_Append*ToObj: self appends} {testobj tip389 nodep} {
teststringobj set 1 foo
teststringobj appendself2 1 3
} foo
if {[testConstraint testobj]} {
testobj freeallvars
}
|
| ︙ | ︙ |
Changes to tests/tcltest.test.
| ︙ | ︙ | |||
94 95 96 97 98 99 100 |
removeFile error
if {[string length $err]} {
set code 1
append msg \n$err
}
return $code
}
| | | | | | | | | | | 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 |
removeFile error
if {[string length $err]} {
set code 1
append msg \n$err
}
return $code
}
test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrWin} {
set result [slave 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 [slave 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 [slave 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 [slave 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 [slave 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 [slave 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 [slave 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 [slave 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 [slave msg test.tcl -verbose start]
list $result $msg
}
-result {^0 .*a-1.0 start.*b-1.0 start}
-match regexp
}
|
| ︙ | ︙ | |||
172 173 174 175 176 177 178 |
verbose $oldVerbosity
list $currentVerbosity $newVerbosity
}
-result {body {}}
}
test tcltest-2.8 {tcltest -verbose 'error'} {
| | | | | | | | | | | | | | 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 |
verbose $oldVerbosity
list $currentVerbosity $newVerbosity
}
-result {body {}}
}
test tcltest-2.8 {tcltest -verbose 'error'} {
-constraints {unixOrWin}
-body {
set result [slave 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 [slave 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 [slave 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 [slave 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 [slave 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 [slave 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 [slave 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 [slave 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 [slave 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 [slave 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 [slave 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 [slave 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 {
|
| ︙ | ︙ | |||
351 352 353 354 355 356 357 |
::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} {
| | | | | | 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 |
::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 {
slave msg $printerror
return $msg
}
-result {a test.*a really}
-match regexp
}
test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrWin unixExecs} {
slave 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} {
slave 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} {
slave 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]
|
| ︙ | ︙ | |||
460 461 462 463 464 465 466 |
}
}
# -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
# slave interp
| | | | | | | 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 |
}
}
# -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
# slave 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] \
[regexp "Flags passed into tcltest" $msg]
} {1 0}
test tcltest-7.3 {tcltest test.tcl -debug 1} {unixOrWin} {
catch {exec [interpreter] test.tcl -debug 1 -match b*} msg
list [regexp userSpecifiedNonMatch $msg] \
[regexp "Flags passed into tcltest" $msg]
} {1 0}
test tcltest-7.4 {tcltest test.tcl -debug 2} {unixOrWin} {
catch {exec [interpreter] test.tcl -debug 2} msg
list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
} {1 0}
test tcltest-7.5 {tcltest test.tcl -debug 3} {unixOrWin} {
catch {exec [interpreter] test.tcl -debug 3} msg
list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
} {1 1}
test tcltest-7.6 {tcltest::debug} {
-setup {
set old $::tcltest::debug
|
| ︙ | ︙ | |||
518 519 520 521 522 523 524 |
set tdiaf [makeFile {} thisdirectoryisafile]
set normaldirectory [makeDirectory normaldirectory]
normalizePath normaldirectory
# -tmpdir, [temporaryDirectory]
| | | < | 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 |
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 {
slave 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 {
slave msg $a -tmpdir $tdiaf
return $msg
}
-result {*not a directory*}
-match glob
}
# Test non-writeable directories, non-readable directories with directory flags
set notReadableDir [file join [temporaryDirectory] notreadable]
set notWriteableDir [file join [temporaryDirectory] notwriteable]
makeDirectory notreadable
makeDirectory notwriteable
switch -- $::tcl_platform(platform) {
unix {
file attributes $notReadableDir -permissions 00333
file attributes $notWriteableDir -permissions 00555
}
default {
# note in FAT/NTFS we won't be able to protect directory with read-only attribute...
|
| ︙ | ︙ | |||
569 570 571 572 573 574 575 |
# 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} {
| | | | 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 |
# 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 {
slave msg $a -tmpdir $notWriteableDir
return $msg
}
-result {*not writeable*}
-match glob
}
test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {
-constraints unixOrWin
-body {
slave 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 {
|
| ︙ | ︙ | |||
621 622 623 624 625 626 627 |
list $f1 $f2 $f3
} -cleanup {
set ::tcltest::temporaryDirectory $old
} -result [list $normaldirectory [workingDirectory] [workingDirectory]]
cd [temporaryDirectory]
# -testdir, [testsDirectory]
test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {
| | | | | 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 |
list $f1 $f2 $f3
} -cleanup {
set ::tcltest::temporaryDirectory $old
} -result [list $normaldirectory [workingDirectory] [workingDirectory]]
cd [temporaryDirectory]
# -testdir, [testsDirectory]
test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {
-constraints unixOrWin
-setup {
file delete -force thisdirectorydoesnotexist
}
-body {
slave msg $a -testdir thisdirectorydoesnotexist
return $msg
}
-match glob
-result {*does not exist*}
}
test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {
-constraints unixOrWin
-body {
slave 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 {
slave msg $a -testdir $notReadableDir
return $msg
}
-match glob
-result {*not readable*}
}
test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {
-constraints unixOrWin
-body {
slave 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]]
}
|
| ︙ | ︙ | |||
728 729 730 731 732 733 734 | file delete -force -- $notReadableDir $notWriteableDir removeFile a.tcl removeFile thisdirectoryisafile removeDirectory normaldirectory # -file, -notfile, [matchFiles], [skipFiles] | | | | 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 |
file delete -force -- $notReadableDir $notWriteableDir
removeFile a.tcl
removeFile thisdirectoryisafile
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 {
slave 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 {
slave msg [file join [testsDirectory] all.tcl] \
-file d*.test -notfile dstring*
regexp {dstring\.test} $msg
} -cleanup {
|
| ︙ | ︙ | |||
803 804 805 806 807 808 809 |
close $f
} {}
::tcltest::cleanupTests
return
} makecore.tcl]
cd [temporaryDirectory]
| | | | | | 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 |
close $f
} {}
::tcltest::cleanupTests
return
} makecore.tcl]
cd [temporaryDirectory]
test tcltest-10.1 {-preservecore 0} {unixOrWin} {
slave msg $mc -preservecore 0
file delete core
regexp "Core file produced" $msg
} {0}
test tcltest-10.2 {-preservecore 1} {unixOrWin} {
slave msg $mc -preservecore 1
file delete core
regexp "Core file produced" $msg
} {1}
test tcltest-10.3 {-preservecore 2} {unixOrWin} {
slave 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} {
slave 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
|
| ︙ | ︙ | |||
850 851 852 853 854 855 856 |
package require tcltest
namespace import tcltest::*
puts [outputChannel] $::tcltest::loadScript
exit
}
set loadfile [makeFile $contents load.tcl]
| | | | 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 |
package require tcltest
namespace import tcltest::*
puts [outputChannel] $::tcltest::loadScript
exit
}
set loadfile [makeFile $contents load.tcl]
test tcltest-12.1 {-load xxx} {unixOrWin} {
slave 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 \
[regexp {tcltest} [join [list $msg] [split $msg \n]]] \
[regexp {loadScript} [join [list $msg] [split $msg \n]]]
} {1 1}
test tcltest-12.3 {loadScript} {
|
| ︙ | ︙ | |||
947 948 949 950 951 952 953 |
namespace import tcltest::*
testsDirectory [file join [temporaryDirectory] singleprocdir]
runAllTests
} all-single.tcl $spd]
cd [workingDirectory]
test tcltest-14.1 {-singleproc - single process} {
| | | | 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 |
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 {
slave 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 {
slave 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
}
|
| ︙ | ︙ | |||
1021 1022 1023 1024 1025 1026 1027 |
package require tcltest
namespace import -force tcltest::*
testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3]
runAllTests
} all.tcl $dtd3
test tcltest-15.1 {basic directory walking} {
| | | | | | | 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 |
package require tcltest
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 {[slave 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 {[slave 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 {[slave 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 {[slave 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 {[slave msg \
[file join $dtd all.tcl] \
-relateddir "dirtestdir2.1 dirtestdir2.2" \
-asidefromdir dirtestdir2.2 \
-tmpdir [temporaryDirectory]] == 1} {
error $msg
|
| ︙ | ︙ | |||
1170 1171 1172 1173 1174 1175 1176 |
} -result {^3$} -match regexp -output\
{tcltest::debug\s+= 2.*tcltest::debug\s+= 3}
# Begin testing of tcltest procs ...
cd [temporaryDirectory]
# PrintError
| | | 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 |
} -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 [slave 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
|
| ︙ | ︙ | |||
1406 1407 1408 1409 1410 1411 1412 |
}
cleanupTests
} test.test $atd
# Must use a child process because stdout/stderr parsing can't be
# duplicated in slave interp.
test tcltest-22.1 {runAllTests} {
| | | 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 |
}
cleanupTests
} test.test $atd
# Must use a child process because stdout/stderr parsing can't be
# duplicated in slave interp.
test tcltest-22.1 {runAllTests} {
-constraints {unixOrWin}
-body {
exec [interpreter] \
[file join $atd all.tcl] \
-verbose t -tmpdir [temporaryDirectory]
}
-match regexp
-result "Test files exiting with errors:.*error.test.*exit.test"
|
| ︙ | ︙ |
Changes to tests/tcltests.tcl.
1 2 3 4 | #! /usr/bin/env tclsh package require tcltest 2.2 namespace import ::tcltest::* | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | 1 2 3 4 5 6 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 |
#! /usr/bin/env tclsh
package require tcltest 2.2
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]}]
namespace eval ::tcltests {
proc init {} {
if {[namespace which ::tcl::file::tempdir] eq {}} {
interp alias {} [namespace current]::tempdir {} [
namespace current]::tempdir_alternate
} else {
interp alias {} [namespace current]::tempdir {} ::tcl::file::tempdir
}
}
proc tempdir_alternate {} {
close [file tempfile tempfile]
set tmpdir [file dirname $tempfile]
set execname [info nameofexecutable]
regsub -all {[^[:alpha:][:digit:]]} $execname _ execname
for {set i 0} {$i < 10000} {incr i} {
set time [clock milliseconds]
set name $tmpdir/${execname}_${time}_$i
if {![file exists $name]} {
file mkdir $name
return $name
}
}
error [list {could not create temporary directory}]
}
init
package provide tcltests 0.1
}
|
Changes to tests/tm.test.
| ︙ | ︙ | |||
196 197 198 199 200 201 202 |
::tcl::tm::path list
} -result {geode snarf foo}
proc genpaths {base} {
# Normalizing picks up drive letters on windows [Bug 1053568]
set base [file normalize $base]
| | | 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 |
::tcl::tm::path list
} -result {geode snarf foo}
proc genpaths {base} {
# Normalizing picks up drive letters on windows [Bug 1053568]
set base [file normalize $base]
regexp {^(\d+)\.(\d+)} [package provide Tcl] - major minor
set results {}
set base [file join $base tcl$major]
lappend results [file join $base site-tcl]
for {set i 0} {$i <= $minor} {incr i} {
lappend results [file join $base ${major}.$i]
}
return $results
|
| ︙ | ︙ |
Changes to tests/uplevel.test.
| ︙ | ︙ | |||
79 80 81 82 83 84 85 86 87 88 89 90 91 92 |
} 66
test uplevel-3.4 {uplevel to same level} {
set y zzz
proc a1 {} {set y 55; uplevel #1 set y}
a1
} 55
test uplevel-4.1 {error: non-existent level} -returnCodes error -body {
apply {{} {
uplevel #2 {set y 222}
}}
} -result {bad level "#2"}
test uplevel-4.2 {error: non-existent level} -returnCodes error -body {
apply {{} {
| > > > > > > > > > > | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 |
} 66
test uplevel-3.4 {uplevel to same level} {
set y zzz
proc a1 {} {set y 55; uplevel #1 set y}
a1
} 55
test uplevel-4.0.1 {error: non-existent level} -body {
uplevel #0 { uplevel { set y 222 } }
} -returnCodes error -result {bad level "1"}
test uplevel-4.0.2 {error: non-existent level} -setup {
interp create i
} -body {
i eval { uplevel { set y 222 } }
} -returnCodes error -result {bad level "1"} -cleanup {
interp delete i
}
test uplevel-4.1 {error: non-existent level} -returnCodes error -body {
apply {{} {
uplevel #2 {set y 222}
}}
} -result {bad level "#2"}
test uplevel-4.2 {error: non-existent level} -returnCodes error -body {
apply {{} {
|
| ︙ | ︙ |
Changes to tests/upvar.test.
| ︙ | ︙ | |||
300 301 302 303 304 305 306 307 308 309 310 311 312 313 |
test upvar-8.2.1 {upvar with numeric first argument} {
apply {{} {set 0 ok; apply {{} {upvar 0 x; return $x}}}}
} ok
test upvar-8.3 {errors in upvar command} -returnCodes error -body {
proc p1 {} {upvar a b c}
p1
} -result {bad level "a"}
test upvar-8.4 {errors in upvar command} -returnCodes error -body {
proc p1 {} {upvar 0 b b}
p1
} -result {can't upvar from variable to itself}
test upvar-8.5 {errors in upvar command} -returnCodes error -body {
proc p1 {} {upvar 0 a b; upvar 0 b a}
p1
| > > > > > > > > > > > | 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 |
test upvar-8.2.1 {upvar with numeric first argument} {
apply {{} {set 0 ok; apply {{} {upvar 0 x; return $x}}}}
} ok
test upvar-8.3 {errors in upvar command} -returnCodes error -body {
proc p1 {} {upvar a b c}
p1
} -result {bad level "a"}
test upvar-8.3.1 {bad level for upvar (upvar at top-level, bug [775ee88560])} -body {
proc p1 {} { uplevel { upvar b b; lappend b UNEXPECTED } }
uplevel #0 { p1 }
} -returnCodes error -result {bad level "1"}
test upvar-8.3.2 {bad level for upvar (upvar at top-level, bug [775ee88560])} -setup {
interp create i
} -body {
i eval { upvar b b; lappend b UNEXPECTED }
} -returnCodes error -result {bad level "1"} -cleanup {
interp delete i
}
test upvar-8.4 {errors in upvar command} -returnCodes error -body {
proc p1 {} {upvar 0 b b}
p1
} -result {can't upvar from variable to itself}
test upvar-8.5 {errors in upvar command} -returnCodes error -body {
proc p1 {} {upvar 0 a b; upvar 0 b a}
p1
|
| ︙ | ︙ | |||
351 352 353 354 355 356 357 |
} -body {
array set upvarArray {}
upvar 0 upvarArray(elem) upvarArrayElemAlias(elem)
} -returnCodes 1 -match glob -result *
test upvar-9.1 {Tcl_UpVar2 procedure} testupvar {
list [catch {testupvar xyz a {} x global} msg] $msg
| | | 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 |
} -body {
array set upvarArray {}
upvar 0 upvarArray(elem) upvarArrayElemAlias(elem)
} -returnCodes 1 -match glob -result *
test upvar-9.1 {Tcl_UpVar2 procedure} testupvar {
list [catch {testupvar xyz a {} x global} msg] $msg
} {1 {bad level "1"}}
test upvar-9.1.1 {TclGetFrame, via Tcl_UpVar2} testupvar {
apply {{} {testupvar xyz a {} x local; set x foo}}
set a
} foo
test upvar-9.2 {Tcl_UpVar2 procedure} testupvar {
catch {unset a}
catch {unset x}
|
| ︙ | ︙ |
Changes to tests/utf.test.
| ︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testbytestring [llength [info commands testbytestring]]
catch {unset x}
| > > > > > > > > > > > > > > > > > > > > < < < | | | | | | > > > | | | | | | | > > > > > > | | | | | | | | | | | | | | > > > | | | | | | > > > | | > | | | | < < < < | | | | | | | | | | | | | | | | | | | | > > > | | > > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | > > > | | | | | > > > > > > | > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > | | > > > > > > > > > > > > > > | | | | | | | | > | | | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 |
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint ucs2 [expr {[format %c 0x010000] eq "\uFFFD"}]
testConstraint fullutf [expr {[format %c 0x010000] ne "\uFFFD"}]
testConstraint utf16 [expr {[string length [format %c 0x10000]] == 2}]
testConstraint ucs4 [expr {[testConstraint fullutf]
&& [string length [format %c 0x10000]] == 1}]
testConstraint ucs2_utf16 [expr {![testConstraint ucs4]}]
testConstraint Uesc [expr {"\U0041" eq "A"}]
testConstraint pre388 [expr {"\x741" eq "A"}]
testConstraint pairsTo4bytes [expr {[llength [info commands teststringbytes]]
&& [string length [teststringbytes \uD83D\uDCA9]] == 4}]
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testfindfirst [llength [info commands testfindfirst]]
testConstraint testfindlast [llength [info commands testfindlast]]
testConstraint testnumutfchars [llength [info commands testnumutfchars]]
testConstraint teststringobj [llength [info commands teststringobj]]
testConstraint testutfnext [llength [info commands testutfnext]]
testConstraint testutfprev [llength [info commands testutfprev]]
testConstraint tip413 [expr {[string trim \x00] eq {}}]
catch {unset x}
test utf-1.1 {Tcl_UniCharToUtf: 1 byte sequences} testbytestring {
expr {"\x01" eq [testbytestring \x01]}
} 1
test utf-1.2 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring {
expr {"\x00" eq [testbytestring \xC0\x80]}
} 1
test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} testbytestring {
expr {"\xE0" eq [testbytestring \xC3\xA0]}
} 1
test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} testbytestring {
expr {"\u4E4E" eq [testbytestring \xE4\xB9\x8E]}
} 1
test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} testbytestring {
expr {[format %c 0x110000] eq [testbytestring \xEF\xBF\xBD]}
} 1
test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} testbytestring {
expr {[format %c -1] eq [testbytestring \xEF\xBF\xBD]}
} 1
test utf-1.7.0 {Tcl_UniCharToUtf: 4 byte sequences} {fullutf Uesc testbytestring} {
expr {"\U014E4E" eq [testbytestring \xF0\x94\xB9\x8E]}
} 1
test utf-1.7.1 {Tcl_UniCharToUtf: 4 byte sequences} {ucs2 Uesc testbytestring} {
expr {"\U014E4E" eq [testbytestring \xF0\x94\xB9\x8E]}
} 0
test utf-1.8 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring {
expr {"\uD842" eq [testbytestring \xED\xA1\x82]}
} 1
test utf-1.9 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring {
expr {"\uDC42" eq [testbytestring \xED\xB1\x82]}
} 1
test utf-1.10 {Tcl_UniCharToUtf: 3 byte sequence, high surrogate} testbytestring {
expr {[format %c 0xD842] eq [testbytestring \xED\xA1\x82]}
} 1
test utf-1.11 {Tcl_UniCharToUtf: 3 byte sequence, low surrogate} testbytestring {
expr {[format %c 0xDC42] eq [testbytestring \xED\xB1\x82]}
} 1
test utf-1.12 {Tcl_UniCharToUtf: 4 byte sequence, high/low surrogate} {pairsTo4bytes testbytestring} {
expr {"\uD842\uDC42" eq [testbytestring \xF0\xA0\xA1\x82]}
} 1
test utf-1.13 {Tcl_UniCharToUtf: Invalid surrogate} {Uesc testbytestring} {
expr {"\UD842" eq [testbytestring \xEF\xBF\xBD]}
} 1
test utf-2.1 {Tcl_UtfToUniChar: low ascii} {
string length "abc"
} 3
test utf-2.2 {Tcl_UtfToUniChar: naked trail bytes} testbytestring {
string length [testbytestring \x82\x83\x84]
} 3
test utf-2.3 {Tcl_UtfToUniChar: lead (2-byte) followed by non-trail} testbytestring {
string length [testbytestring \xC2]
} 1
test utf-2.4 {Tcl_UtfToUniChar: lead (2-byte) followed by trail} {
string length \xA2
} 1
test utf-2.5 {Tcl_UtfToUniChar: lead (3-byte) followed by non-trail} testbytestring {
string length [testbytestring \xE2]
} 1
test utf-2.6 {Tcl_UtfToUniChar: lead (3-byte) followed by 1 trail} testbytestring {
string length [testbytestring \xE2\xA2]
} 2
test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring {
string length [testbytestring \xE4\xB9\x8E]
} 1
test utf-2.8.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {testbytestring ucs2_utf16} {
string length [testbytestring \xF0\x90\x80\x80]
} 2
test utf-2.8.1 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {testbytestring ucs4} {
string length [testbytestring \xF0\x90\x80\x80]
} 1
test utf-2.9.0 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {testbytestring ucs2} {
string length [testbytestring \xF4\x8F\xBF\xBF]
} 2
test utf-2.9.1 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} {Uesc ucs4} {
string length \U10FFFF
} 1
test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring {
string length [testbytestring \xF0\x8F\xBF\xBF]
} 4
test utf-2.11 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, overflow} testbytestring {
# Would decode to U+110000 but that is outside the Unicode range.
string length [testbytestring \xF4\x90\x80\x80]
} 4
test utf-2.12 {Tcl_UtfToUniChar: longer UTF sequences not supported} testbytestring {
string length [testbytestring \xF8\xA2\xA2\xA2\xA2]
} 5
test utf-3.1 {Tcl_UtfCharComplete} {
} {}
test utf-4.1 {Tcl_NumUtfChars: zero length} testnumutfchars {
testnumutfchars ""
} 0
test utf-4.2 {Tcl_NumUtfChars: length 1} testnumutfchars {
testnumutfchars \xA2
} 1
test utf-4.3 {Tcl_NumUtfChars: long string} {testnumutfchars testbytestring} {
testnumutfchars abc\xA2[testbytestring \xE4\xB9\x8E\xA2\x4E]
} 7
test utf-4.4 {Tcl_NumUtfChars: #x00} testnumutfchars {
testnumutfchars \x00
} 1
test utf-4.5 {Tcl_NumUtfChars: zero length, calc len} testnumutfchars {
testnumutfchars "" 0
} 0
test utf-4.6 {Tcl_NumUtfChars: length 1, calc len} {testnumutfchars testbytestring} {
testnumutfchars \xA2 end
} 1
test utf-4.7 {Tcl_NumUtfChars: long string, calc len} {testnumutfchars testbytestring} {
testnumutfchars abc\xA2[testbytestring \xE4\xB9\x8E\xA2\x4E] end
} 7
test utf-4.8 {Tcl_NumUtfChars: #x00, calc len} testnumutfchars {
testnumutfchars \x00 end
} 1
# Bug [2738427]: Tcl_NumUtfChars(...) no overflow check
test utf-4.9 {Tcl_NumUtfChars: #u20AC, calc len, incomplete} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring \xE2\x82\xAC] end-1
} 2
test utf-4.10 {Tcl_NumUtfChars: #x00, calc len, overcomplete} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring \x00] end+1
} 2
test utf-4.11 {Tcl_NumUtfChars: 3 bytes of 4-byte UTF-8 characater} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end-1
} 3
test utf-4.12.0 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring ucs2} {
testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end
} 2
test utf-4.12.1 {Tcl_NumUtfChars: #4-byte UTF-8 character} {testnumutfchars testbytestring ucs4} {
testnumutfchars [testbytestring \xF0\x9F\x92\xA9] end
} 1
test utf-4.13 {Tcl_NumUtfChars: end of string} {testnumutfchars testbytestring} {
testnumutfchars foobar[testbytestring \xF2\xC2\xA0] end
} 8
test utf-4.14 {Tcl_NumUtfChars: 3 bytes of 4-byte UTF-8 characater} {testnumutfchars testbytestring} {
testnumutfchars [testbytestring \xF4\x90\x80\x80] end-1
} 3
test utf-5.1 {Tcl_UtfFindFirst} {testfindfirst testbytestring} {
testfindfirst [testbytestring abcbc] 98
} bcbc
test utf-5.2 {Tcl_UtfFindLast} {testfindlast testbytestring} {
testfindlast [testbytestring abcbc] 98
} bc
test utf-6.1 {Tcl_UtfNext} {testutfnext testbytestring} {
# This takes the pointer one past the terminating NUL.
# This is really an invalid call.
testutfnext [testbytestring \x00]
} 1
test utf-6.2 {Tcl_UtfNext} testutfnext {
testutfnext A
} 1
test utf-6.3 {Tcl_UtfNext} testutfnext {
testutfnext AA
} 1
test utf-6.4 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext A[testbytestring \xA0]
} 1
test utf-6.5 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext A[testbytestring \xD0]
} 1
test utf-6.6 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext A[testbytestring \xE8]
} 1
test utf-6.7 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext A[testbytestring \xF2]
} 1
test utf-6.8 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext A[testbytestring \xF8]
} 1
test utf-6.9 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\x00]
} 1
test utf-6.10 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0]G
} 1
test utf-6.11 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xA0\x00]
} 2
test utf-6.12 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xD0]
} 1
test utf-6.13 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xE8]
} 1
test utf-6.14 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xF2]
} 1
test utf-6.15 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xF8]
} 1
test utf-6.16 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\x00]
} 1
test utf-6.17 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0]G
} 1
test utf-6.18 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xA0]
} 2
test utf-6.19 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xD0]
} 1
test utf-6.20 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xE8]
} 1
test utf-6.21 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xF2]
} 1
test utf-6.22 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xF8]
} 1
test utf-6.23 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8]
} -1
test utf-6.24 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8]G
} 1
test utf-6.25 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xA0\x00]
} 1
test utf-6.26 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xD0]
} 1
test utf-6.27 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xE8]
} 1
test utf-6.28 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xF2]
} 1
test utf-6.29 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xF8]
} 1
test utf-6.30.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2]
} 1
test utf-6.30.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2]
} -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]
} -1
test utf-6.33 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xD0]
} 1
test utf-6.34 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xE8]
} 1
test utf-6.35 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xF2]
} 1
test utf-6.36 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xF8]
} 1
test utf-6.37 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF8]
} 1
test utf-6.38 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF8]G
} 1
test utf-6.39 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF8\xA0]
} 1
test utf-6.40 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF8\xD0]
} 1
test utf-6.41 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF8\xE8]
} 1
test utf-6.42 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF8\xF2]
} 1
test utf-6.43 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF8\xF8]
} 1
test utf-6.44 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xA0]G
} 2
test utf-6.45 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xA0\xA0]
} 2
test utf-6.46 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xA0\xD0]
} 2
test utf-6.47 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xA0\xE8]
} 2
test utf-6.48 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xA0\xF2]
} 2
test utf-6.49 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xD0\xA0\xF8]
} 2
test utf-6.50 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xA0]G
} 1
test utf-6.51 {Tcl_UtfNext} testutfnext {
testutfnext \u8820
} 3
test utf-6.52 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xA0\xD0]
} 1
test utf-6.53 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xA0\xE8]
} 1
test utf-6.54 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xA0\xF2]
} 1
test utf-6.55 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xE8\xA0\xF8]
} 1
test utf-6.56 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0]G
} 1
test utf-6.57 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\x00]
} 1
test utf-6.58 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xD0]
} 1
test utf-6.59 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xE8]
} 1
test utf-6.60 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xF2]
} 1
test utf-6.61 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xF8]
} 1
test utf-6.62 {Tcl_UtfNext} testutfnext {
testutfnext \u8820G
} 3
test utf-6.63 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext \u8820[testbytestring \xA0]
} 3
test utf-6.64 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext \u8820[testbytestring \xD0]
} 3
test utf-6.65 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext \u8820[testbytestring \xE8]
} 3
test utf-6.66 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext \u8820[testbytestring \xF2]
} 3
test utf-6.67 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext \u8820[testbytestring \xF8]
} 3
test utf-6.68 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0]G
} 1
test utf-6.69.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0]
} 1
test utf-6.69.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0]
} 4
test utf-6.70 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\xD0]
} 1
test utf-6.71 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\xE8]
} 1
test utf-6.72 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\xF2]
} 1
test utf-6.73 {Tcl_UtfNext} {testutfnext testbytestring} {
testutfnext [testbytestring \xF2\xA0\xA0\xF8]
} 1
test utf-6.74.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0]G
} 1
test utf-6.74.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0]G
} 4
test utf-6.75.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0]
} 1
test utf-6.75.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xA0]
} 4
test utf-6.76.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xD0]
} 1
test utf-6.76.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xD0]
} 4
test utf-6.77.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xE8]
} 1
test utf-6.77.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xE8]
} 4
test utf-6.78.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xF2]
} 1
test utf-6.78.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0\xF2]
} 4
test utf-6.79.0 {Tcl_UtfNext} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0G\xF8]
} 1
test utf-6.79.1 {Tcl_UtfNext} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF2\xA0\xA0\xA0G\xF8]
} 4
test utf-6.80 {Tcl_UtfNext - overlong sequences} testutfnext {
testutfnext \x00
} 2
test utf-6.81 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
testutfnext [testbytestring \xC0\x81]
} 1
test utf-6.82 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
testutfnext [testbytestring \xC1\x80]
} 1
test utf-6.83 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
testutfnext [testbytestring \xC2\x80]
} 2
test utf-6.84 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
testutfnext [testbytestring \xE0\x80\x80]
} 1
test utf-6.85 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
testutfnext [testbytestring \xE0\xA0\x80]
} 3
test utf-6.86 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring} {
testutfnext [testbytestring \xF0\x80\x80\x80]
} 1
test utf-6.87.0 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF0\x90\x80\x80]
} 1
test utf-6.87.1 {Tcl_UtfNext - overlong sequences} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF0\x90\x80\x80]
} 4
test utf-6.88 {Tcl_UtfNext, pointing to 2th byte of 3-byte valid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xA0\x00]
} 2
test utf-6.89 {Tcl_UtfNext, pointing to 2th byte of 3-byte invalid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \x80\x80\x00]
} 2
test utf-6.90.0 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring ucs2_utf16} {
testutfnext [testbytestring \xF4\x8F\xBF\xBF]
} 1
test utf-6.90.1 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring ucs4} {
testutfnext [testbytestring \xF4\x8F\xBF\xBF]
} 4
test utf-6.91 {Tcl_UtfNext, validity check [493dccc2de]} {testutfnext testbytestring} {
testutfnext [testbytestring \xF4\x90\x80\x80]
} 1
test utf-6.92 {Tcl_UtfNext, pointing to 2th byte of 4-byte valid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xA0\xA0]
} 3
test utf-6.93 {Tcl_UtfNext, pointing to 2th byte of 4-byte invalid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \x80\x80\x80]
} 3
test utf-6.94 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \xA0\xA0\xA0\xA0]
} 3
test utf-6.95 {Tcl_UtfNext, pointing to 2th byte of 5-byte invalid sequence} {testutfnext testbytestring} {
testutfnext [testbytestring \x80\x80\x80\x80]
} 3
test utf-7.1 {Tcl_UtfPrev} testutfprev {
testutfprev {}
} 0
test utf-7.2 {Tcl_UtfPrev} testutfprev {
testutfprev A
} 0
test utf-7.3 {Tcl_UtfPrev} testutfprev {
testutfprev AA
} 1
test utf-7.4 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8]
} 1
test utf-7.4.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 2
} 1
test utf-7.4.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xF8\xA0\xA0] 2
} 1
test utf-7.5 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF2]
} 1
test utf-7.5.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 2
} 1
test utf-7.5.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF2\xF8\xA0\xA0] 2
} 1
test utf-7.6 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE8]
} 1
test utf-7.6.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A\u8820[testbytestring \xA0] 2
} 1
test utf-7.6.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE8\xF8\xA0\xA0] 2
} 1
test utf-7.7 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0]
} 1
test utf-7.7.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0\xA0\xA0] 2
} 1
test utf-7.7.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xF8\xA0\xA0] 2
} 1
test utf-7.8 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xA0]
} 1
test utf-7.8.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 2
} 1
test utf-7.8.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xA0\xF8\xA0\xA0] 2
} 1
test utf-7.9 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0]
} 2
test utf-7.9.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 3
} 2
test utf-7.9.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0\xF8\xA0] 3
} 2
test utf-7.10.0 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF2\xA0]
} 2
test utf-7.10.1 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF2\xA0]
} 1
test utf-7.10.2 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 3
} 2
test utf-7.10.3 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 3
} 1
test utf-7.10.4 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF2\xA0\xF8\xA0] 3
} 2
test utf-7.10.5 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF2\xA0\xF8\xA0] 3
} 1
test utf-7.11 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE8\xA0]
} 1
test utf-7.11.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A\u8820[testbytestring \xA0] 3
} 1
test utf-7.11.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE8\xA0\xF8\xA0] 3
} 1
test utf-7.11.3 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE8\xA0\xF8] 3
} 1
test utf-7.12 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0]
} 1
test utf-7.12.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0\xA0\xA0] 3
} 1
test utf-7.12.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0\xF8\xA0] 3
} 1
test utf-7.13 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xA0\xA0]
} 2
test utf-7.13.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 3
} 2
test utf-7.13.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xA0\xA0\xF8\xA0] 3
} 2
test utf-7.14 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0\xA0]
} 3
test utf-7.14.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0\xA0\xA0] 4
} 3
test utf-7.14.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF8\xA0\xA0\xF8] 4
} 3
test utf-7.15.0 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF2\xA0\xA0]
} 3
test utf-7.15.1 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF2\xA0\xA0]
} 1
test utf-7.15.2 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 4
} 3
test utf-7.15.3 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF2\xA0\xA0\xA0] 4
} 1
test utf-7.15.4 {Tcl_UtfPrev} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF2\xA0\xA0\xF8] 4
} 3
test utf-7.15.5 {Tcl_UtfPrev} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF2\xA0\xA0\xF8] 4
} 1
test utf-7.16 {Tcl_UtfPrev} testutfprev {
testutfprev A\u8820
} 1
test utf-7.16.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A\u8820[testbytestring \xA0] 4
} 1
test utf-7.16.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A\u8820[testbytestring \xF8] 4
} 1
test utf-7.17 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0\xA0]
} 3
test utf-7.17.1 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0\xA0\xA0] 4
} 3
test utf-7.17.2 {Tcl_UtfPrev} {testutfprev testbytestring} {
testutfprev A[testbytestring \xD0\xA0\xA0\xF8] 4
} 3
test utf-7.18.0 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xA0\xA0\xA0]
} 1
test utf-7.18.1 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xA0\xA0\xA0\xA0] 4
} 1
test utf-7.18.2 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xA0\xA0\xA0\xF8] 4
} 1
test utf-7.19 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF8\xA0\xA0\xA0]
} 2
test utf-7.20 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF2\xA0\xA0\xA0]
} 2
test utf-7.21 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A\u8820[testbytestring \xA0]
} 2
test utf-7.22 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xD0\xA0\xA0\xA0]
} 2
test utf-7.23 {Tcl_UtfPrev} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xA0\xA0\xA0\xA0]
} 2
test utf-7.24 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xC0\x81]
} 2
test utf-7.25 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xC0\x81] 2
} 1
test utf-7.26 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\x80\x80]
} 3
test utf-7.27 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\x80]
} 2
test utf-7.27.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\x80\x80] 3
} 2
test utf-7.28 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0]
} 1
test utf-7.28.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\x80\x80] 2
} 1
test utf-7.29 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF0\x80\x80\x80]
} 2
test utf-7.30 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF0\x80\x80\x80] 4
} 3
test utf-7.31 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF0\x80\x80\x80] 3
} 2
test utf-7.32 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF0\x80\x80\x80] 2
} 1
test utf-7.33 {Tcl_UtfPrev -- overlong sequence} testutfprev {
testutfprev A\x00
} 1
test utf-7.34 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xC1\x80]
} 2
test utf-7.35 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xC2\x80]
} 1
test utf-7.36 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\xA0\x80]
} 1
test utf-7.37 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\xA0\x80] 3
} 1
test utf-7.38 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xE0\xA0\x80] 2
} 1
test utf-7.39 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF0\x90\x80\x80]
} 2
test utf-7.40.0 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF0\x90\x80\x80] 4
} 3
test utf-7.40.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF0\x90\x80\x80] 4
} 1
test utf-7.41.0 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF0\x90\x80\x80] 3
} 2
test utf-7.41.1 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF0\x90\x80\x80] 3
} 1
test utf-7.42 {Tcl_UtfPrev -- overlong sequence} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF0\x90\x80\x80] 2
} 1
test utf-7.43 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} {
testutfprev [testbytestring \xA0]
} 0
test utf-7.44 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} {
testutfprev [testbytestring \xA0\xA0]
} 1
test utf-7.45 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring} {
testutfprev [testbytestring \xA0\xA0\xA0]
} 2
test utf-7.46 {Tcl_UtfPrev -- no lead byte at start} {testutfprev testbytestring utf16} {
testutfprev [testbytestring \xA0\xA0\xA0\xA0]
} 1
test utf-7.47 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} {testutfprev testbytestring} {
testutfprev [testbytestring \xE8\xA0]
} 0
test utf-7.47.1 {Tcl_UtfPrev, pointing to 3th byte of 3-byte valid sequence} testutfprev {
testutfprev \u8820 2
} 0
test utf-7.47.2 {Tcl_UtfPrev, pointing to 3th byte of 3-byte invalid sequence} {testutfprev testbytestring} {
testutfprev [testbytestring \xE8\xA0\x00] 2
} 0
test utf-7.48.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF]
} 2
test utf-7.48.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 4
} 3
test utf-7.48.2 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 4
} 1
test utf-7.48.3 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring ucs2} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 3
} 2
test utf-7.48.4 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring fullutf} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 3
} 1
test utf-7.48.5 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF4\x8F\xBF\xBF] 2
} 1
test utf-7.49.0 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring utf16} {
testutfprev A[testbytestring \xF4\x90\x80\x80]
} 2
test utf-7.49.1 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF4\x90\x80\x80] 4
} 3
test utf-7.49.2 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF4\x90\x80\x80] 3
} 2
test utf-7.49.3 {Tcl_UtfPrev, validity check [493dccc2de]} {testutfprev testbytestring} {
testutfprev A[testbytestring \xF4\x90\x80\x80] 2
} 1
test utf-8.1 {Tcl_UniCharAtIndex: index = 0} {
string index abcd 0
} a
test utf-8.2 {Tcl_UniCharAtIndex: index = 0} {
string index \u4E4E\u25A 0
} \u4E4E
test utf-8.3 {Tcl_UniCharAtIndex: index > 0} {
string index abcd 2
} c
test utf-8.4 {Tcl_UniCharAtIndex: index > 0} {
string index \u4E4E\u25A\xFF\u543 2
} \xFF
test utf-8.5.0 {Tcl_UniCharAtIndex: high surrogate} ucs2 {
string index \uD842 0
} \uD842
test utf-8.5.1 {Tcl_UniCharAtIndex: high surrogate} ucs4 {
string index \uD842 0
} \uD842
test utf-8.5.2 {Tcl_UniCharAtIndex: high surrogate} utf16 {
string index \uD842 0
} \uD842
test utf-8.6 {Tcl_UniCharAtIndex: low surrogate} {
string index \uDC42 0
} \uDC42
test utf-8.7.0 {Tcl_UniCharAtIndex: Emoji} ucs2 {
string index \uD83D\uDE00G 0
} \uD83D
test utf-8.7.1 {Tcl_UniCharAtIndex: Emoji} ucs4 {
string index \uD83D\uDE00G 0
} \U1F600
test utf-8.7.2 {Tcl_UniCharAtIndex: Emoji} utf16 {
string index \uD83D\uDE00G 0
} \U1F600
test utf-8.8.0 {Tcl_UniCharAtIndex: Emoji} ucs2 {
string index \uD83D\uDE00G 1
} \uDE00
test utf-8.8.1 {Tcl_UniCharAtIndex: Emoji} ucs4 {
string index \uD83D\uDE00G 1
} G
test utf-8.8.2 {Tcl_UniCharAtIndex: Emoji} utf16 {
string index \uD83D\uDE00G 1
} {}
test utf-8.9.0 {Tcl_UniCharAtIndex: Emoji} ucs2 {
string index \uD83D\uDE00G 2
} G
test utf-8.9.1 {Tcl_UniCharAtIndex: Emoji} ucs4 {
string index \uD83D\uDE00G 2
} {}
test utf-8.9.2 {Tcl_UniCharAtIndex: Emoji} utf16 {
string index \uD83D\uDE00G 2
} G
test utf-8.10.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} {
string index \U1F600G 0
} \uFFFD
test utf-8.10.1 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs4} {
string index \U1F600G 0
} \U1F600
test utf-8.10.2 {Tcl_UniCharAtIndex: Emoji} {Uesc utf16} {
string index \U1F600G 0
} \U1F600
test utf-8.11.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} {
string index \U1F600G 1
} G
test utf-8.11.1 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs4} {
string index \U1F600G 1
} G
test utf-8.11.2 {Tcl_UniCharAtIndex: Emoji} {Uesc utf16} {
string index \U1F600G 1
} {}
test utf-8.12.0 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs2} {
string index \U1F600G 2
} {}
test utf-8.12.1 {Tcl_UniCharAtIndex: Emoji} {Uesc ucs4} {
string index \U1F600G 2
} {}
test utf-8.12.2 {Tcl_UniCharAtIndex: Emoji} {Uesc utf16} {
string index \U1F600G 2
} G
test utf-9.1 {Tcl_UtfAtIndex: index = 0} {
string range abcd 0 2
} abc
test utf-9.2 {Tcl_UtfAtIndex: index > 0} {
string range \u4E4E\u25A\xFF\u543klmnop 1 5
} \u25A\xFF\u543kl
test utf-9.3.0 {Tcl_UtfAtIndex: index = 0, Emoji} ucs2 {
string range \uD83D\uDE00G 0 0
} \uD83D
test utf-9.3.1 {Tcl_UtfAtIndex: index = 0, Emoji} ucs4 {
string range \uD83D\uDE00G 0 0
} \U1F600
test utf-9.3.2 {Tcl_UtfAtIndex: index = 0, Emoji} utf16 {
string range \uD83D\uDE00G 0 0
} \U1F600
test utf-9.4.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 {
string range \uD83D\uDE00G 1 1
} \uDE00
test utf-9.4.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 {
string range \uD83D\uDE00G 1 1
} G
test utf-9.4.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 {
string range \uD83D\uDE00G 1 1
} {}
test utf-9.5.0 {Tcl_UtfAtIndex: index > 0, Emoji} ucs2 {
string range \uD83D\uDE00G 2 2
} G
test utf-9.5.1 {Tcl_UtfAtIndex: index > 0, Emoji} ucs4 {
string range \uD83D\uDE00G 2 2
} {}
test utf-9.5.2 {Tcl_UtfAtIndex: index > 0, Emoji} utf16 {
string range \uD83D\uDE00G 2 2
} G
test utf-9.6.0 {Tcl_UtfAtIndex: index = 0, Emoji} {Uesc ucs2} {
string range \U1f600G 0 0
} \uFFFD
test utf-9.6.1 {Tcl_UtfAtIndex: index = 0, Emoji} {Uesc ucs4} {
string range \U1f600G 0 0
} \U1F600
test utf-9.6.2 {Tcl_UtfAtIndex: index = 0, Emoji} {Uesc utf16} {
string range \U1f600G 0 0
} \U1F600
test utf-9.7.0 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs2} {
string range \U1f600G 1 1
} G
test utf-9.7.1 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs4} {
string range \U1f600G 1 1
} G
test utf-9.7.2 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc utf16} {
string range \U1f600G 1 1
} {}
test utf-9.8.0 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs2} {
string range \U1f600G 2 2
} {}
test utf-9.8.1 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc ucs4} {
string range \U1f600G 2 2
} {}
test utf-9.8.2 {Tcl_UtfAtIndex: index > 0, Emoji} {Uesc utf16} {
string range \U1f600G 2 2
} G
test utf-10.1 {Tcl_UtfBackslash: dst == NULL} {
set x \n
} {
}
test utf-10.2 {Tcl_UtfBackslash: \u subst} testbytestring {
expr {"\uA2" eq [testbytestring \xC2\xA2]}
} 1
test utf-10.3 {Tcl_UtfBackslash: longer \u subst} testbytestring {
expr {"\u4E21" eq [testbytestring \xE4\xB8\xA1]}
} 1
test utf-10.4 {Tcl_UtfBackslash: stops at first non-hex} testbytestring {
expr {"\u4E2k" eq "[testbytestring \xD3\xA2]k"}
} 1
test utf-10.5 {Tcl_UtfBackslash: stops after 4 hex chars} testbytestring {
expr {"\u4E216" eq "[testbytestring \xE4\xB8\xA1]6"}
} 1
test utf-10.6 {Tcl_UtfBackslash: stops after 5 hex chars} {Uesc fullutf testbytestring} {
expr {"\U1E2165" eq "[testbytestring \xF0\x9E\x88\x96]5"}
} 1
test utf-10.7 {Tcl_UtfBackslash: stops after 6 hex chars} {Uesc fullutf testbytestring} {
expr {"\U10E2165" eq "[testbytestring \xF4\x8E\x88\x96]5"}
} 1
proc bsCheck {char num {constraints {}}} {
global errNum
test utf-10.$errNum {backslash substitution} $constraints {
scan $char %c value
set value
} $num
incr errNum
}
set errNum 8
bsCheck \b 8
|
| ︙ | ︙ | |||
228 229 230 231 232 233 234 | bsCheck \14 12 bsCheck \141 97 bsCheck b\0 98 bsCheck \x 120 bsCheck \xa 10 bsCheck \xA 10 bsCheck \x41 65 | > | | | | > | | | | | | | | | | | | | | | | | | | | | | | | | > > > | > > > | | | | | | | | | > > > > > > | | | | | | | | | | > > > > > > | | | | | | | | | | | > | > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > > > > > > > | | | | < < < | < < < < < < < < < < < < | | | | | | < | | | > > > | < | > | | | | | | | | > | | > | < < | < < | < | | | | | < | | | | | | 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 |
bsCheck \14 12
bsCheck \141 97
bsCheck b\0 98
bsCheck \x 120
bsCheck \xa 10
bsCheck \xA 10
bsCheck \x41 65
bsCheck \x541 65 pre388 ;# == \x41
bsCheck \x541 84 !pre388 ;# == \x54 1
bsCheck \u 117
bsCheck \uk 117
bsCheck \u41 65
bsCheck \ua 10
bsCheck \uA 10
bsCheck \340 224
bsCheck \uA1 161
bsCheck \u4E21 20001
bsCheck \741 225 pre388 ;# == \341
bsCheck \741 60 !pre388 ;# == \74 1
bsCheck \U 85
bsCheck \Uk 85
bsCheck \U41 65 Uesc
bsCheck \Ua 10 Uesc
bsCheck \UA 10 Uesc
bsCheck \UA1 161 Uesc
bsCheck \U4E21 20001 Uesc
bsCheck \U004E21 20001 Uesc
bsCheck \U00004E21 20001 Uesc
bsCheck \U0000004E21 78 Uesc
bsCheck \U00110000 69632 {Uesc fullutf}
bsCheck \U01100000 69632 {Uesc fullutf}
bsCheck \U11000000 69632 {Uesc fullutf}
bsCheck \U0010FFFF 1114111 {Uesc fullutf}
bsCheck \U010FFFF0 1114111 {Uesc fullutf}
bsCheck \U10FFFF00 1114111 {Uesc fullutf}
bsCheck \UFFFFFFFF 1048575 {Uesc fullutf}
test utf-11.1 {Tcl_UtfToUpper} {
string toupper {}
} {}
test utf-11.2 {Tcl_UtfToUpper} {
string toupper abc
} ABC
test utf-11.3 {Tcl_UtfToUpper} {
string toupper \xE3gh
} \xC3GH
test utf-11.4 {Tcl_UtfToUpper} {
string toupper \u01E3gh
} \u01E2GH
test utf-11.5 {Tcl_UtfToUpper Georgian (new in Unicode 11)} {
string toupper \u10D0\u1C90
} \u1C90\u1C90
test utf-11.6 {Tcl_UtfToUpper beyond U+FFFF} {Uesc fullutf} {
string toupper \U10428
} \U10400
test utf-11.7 {Tcl_UtfToUpper beyond U+FFFF} fullutf {
string toupper \uD801\uDC28
} \uD801\uDC00
test utf-11.8 {Tcl_UtfToUpper low/high surrogate)} {
string toupper \uDC24\uD824
} \uDC24\uD824
test utf-12.1 {Tcl_UtfToLower} {
string tolower {}
} {}
test utf-12.2 {Tcl_UtfToLower} {
string tolower ABC
} abc
test utf-12.3 {Tcl_UtfToLower} {
string tolower \xC3GH
} \xE3gh
test utf-12.4 {Tcl_UtfToLower} {
string tolower \u01E2GH
} \u01E3gh
test utf-12.5 {Tcl_UtfToLower Georgian (new in Unicode 11)} {
string tolower \u10D0\u1C90
} \u10D0\u10D0
test utf-12.6 {Tcl_UtfToLower low/high surrogate)} {
string tolower \uDC24\uD824
} \uDC24\uD824
test utf-12.7 {Tcl_UtfToLower beyond U+FFFF} {Uesc fullutf} {
string tolower \U10400
} \U10428
test utf-12.8 {Tcl_UtfToLower beyond U+FFFF} fullutf {
string tolower \uD801\uDC00
} \uD801\uDC28
test utf-13.1 {Tcl_UtfToTitle} {
string totitle {}
} {}
test utf-13.2 {Tcl_UtfToTitle} {
string totitle abc
} Abc
test utf-13.3 {Tcl_UtfToTitle} {
string totitle \xE3GH
} \xC3gh
test utf-13.4 {Tcl_UtfToTitle} {
string totitle \u01F3AB
} \u01F2ab
test utf-13.5 {Tcl_UtfToTitle Georgian (new in Unicode 11)} {
string totitle \u10D0\u1C90
} \u10D0\u1C90
test utf-13.6 {Tcl_UtfToTitle Georgian (new in Unicode 11)} {
string totitle \u1C90\u10D0
} \u1C90\u10D0
test utf-13.7 {Tcl_UtfToTitle low/high surrogate)} {
string totitle \uDC24\uD824
} \uDC24\uD824
test utf-13.8 {Tcl_UtfToTitle beyond U+FFFF} {Uesc fullutf} {
string totitle \U10428\U10400
} \U10400\U10428
test utf-13.9 {Tcl_UtfToTitle beyond U+FFFF} fullutf {
string totitle \uD801\uDC28\uD801\uDC00
} \uD801\uDC00\uD801\uDC28
test utf-14.1 {Tcl_UtfNcasecmp} {
string compare -nocase a b
} -1
test utf-14.2 {Tcl_UtfNcasecmp} {
string compare -nocase b a
} 1
test utf-14.3 {Tcl_UtfNcasecmp} {
string compare -nocase B a
} 1
test utf-14.4 {Tcl_UtfNcasecmp} {
string compare -nocase aBcB abca
} 1
test utf-15.1 {Tcl_UniCharToUpper, negative delta} {
string toupper aA
} AA
test utf-15.2 {Tcl_UniCharToUpper, positive delta} {
string toupper \u0178\xFF
} \u0178\u0178
test utf-15.3 {Tcl_UniCharToUpper, no delta} {
string toupper !
} !
test utf-16.1 {Tcl_UniCharToLower, negative delta} {
string tolower aA
} aa
test utf-16.2 {Tcl_UniCharToLower, positive delta} {
string tolower \u0178\xFF\uA78D\u01C5
} \xFF\xFF\u0265\u01C6
test utf-17.1 {Tcl_UniCharToLower, no delta} {
string tolower !
} !
test utf-18.1 {Tcl_UniCharToTitle, add one for title} {
string totitle \u01C4
} \u01C5
test utf-18.2 {Tcl_UniCharToTitle, subtract one for title} {
string totitle \u01C6
} \u01C5
test utf-18.3 {Tcl_UniCharToTitle, subtract delta for title (positive)} {
string totitle \u017F
} \x53
test utf-18.4 {Tcl_UniCharToTitle, subtract delta for title (negative)} {
string totitle \xFF
} \u0178
test utf-18.5 {Tcl_UniCharToTitle, no delta} {
string totitle !
} !
test utf-19.1 {TclUniCharLen} -body {
list [regexp \\d abc456def foo] $foo
} -cleanup {
unset -nocomplain foo
} -result {1 4}
test utf-20.1 {TclUniCharNcmp} ucs4 {
string compare [string range [format %c 0xFFFF] 0 0] [string range [format %c 0x10000] 0 0]
} -1
test utf-20.2 {[4c591fa487] TclUniCharNcmp/TclUtfNcmp} knownBug {
set one [format %c 0xFFFF]
set two [format %c 0x10000]
set first [string compare $one $two]
string range $one 0 0
string range $two 0 0
set second [string compare $one $two]
expr {($first == $second) ? "agree" : "disagree"}
} agree
test utf-21.1 {TclUniCharIsAlnum} {
# this returns 1 with Unicode 7 compliance
string is alnum \u1040\u021F\u0220
} 1
test utf-21.2 {unicode alnum char in regc_locale.c} {
# this returns 1 with Unicode 7 compliance
list [regexp {^[[:alnum:]]+$} \u1040\u021F\u0220] [regexp {^\w+$} \u1040\u021F\u0220_\u203F\u2040\u2054\uFE33\uFE34\uFE4D\uFE4E\uFE4F\uFF3F]
} {1 1}
test utf-21.3 {unicode print char in regc_locale.c} {
# this returns 1 with Unicode 7 compliance
regexp {^[[:print:]]+$} \uFBC1
} 1
test utf-21.4 {TclUniCharIsGraph} {
# [Bug 3464428]
string is graph \u0120
} 1
test utf-21.5 {unicode graph char in regc_locale.c} {
# [Bug 3464428]
regexp {^[[:graph:]]+$} \u0120
} 1
test utf-21.6 {TclUniCharIsGraph} {
# [Bug 3464428]
string is graph \xA0
} 0
test utf-21.7 {unicode graph char in regc_locale.c} {
# [Bug 3464428]
regexp {[[:graph:]]} \x20\xA0\u2028\u2029
} 0
test utf-21.8 {TclUniCharIsPrint} {
# [Bug 3464428]
string is print \x09
} 0
test utf-21.9 {unicode print char in regc_locale.c} {
# [Bug 3464428]
regexp {[[:print:]]} \x09
} 0
test utf-21.10 {unicode print char in regc_locale.c} {
# [Bug 3464428]
regexp {[[:print:]]} \x09
} 0
test utf-21.11 {TclUniCharIsControl} {
# [Bug 3464428]
string is control \x00\x1F\xAD\u0605\u061C\u180E\u2066\uFEFF
} 1
test utf-21.12 {unicode control char in regc_locale.c} {
# [Bug 3464428], [Bug a876646efe]
regexp {^[[:cntrl:]]*$} \x00\x1F\xAD\u0605\u061C\u180E\u2066\uFEFF
} 1
test utf-22.1 {TclUniCharIsWordChar} {
string wordend "xyz123_bar fg" 0
} 10
test utf-22.2 {TclUniCharIsWordChar} {
string wordend "x\u5080z123_bar\u203C fg" 0
} 10
test utf-23.1 {TclUniCharIsAlpha} {
# this returns 1 with Unicode 7 compliance
string is alpha \u021F\u0220\u037F\u052F
} 1
test utf-23.2 {unicode alpha char in regc_locale.c} {
# this returns 1 with Unicode 7 compliance
regexp {^[[:alpha:]]+$} \u021F\u0220\u037F\u052F
} 1
test utf-24.1 {TclUniCharIsDigit} {
# this returns 1 with Unicode 7 compliance
string is digit \u1040\uABF0
} 1
test utf-24.2 {unicode digit char in regc_locale.c} {
# this returns 1 with Unicode 7 compliance
list [regexp {^[[:digit:]]+$} \u1040\uABF0] [regexp {^\d+$} \u1040\uABF0]
} {1 1}
test utf-24.3 {TclUniCharIsSpace} {
# this returns 1 with Unicode 7 compliance
string is space \u1680\u180E\u202F
} 1
test utf-24.4 {unicode space char in regc_locale.c} {
# this returns 1 with Unicode 7 compliance
list [regexp {^[[:space:]]+$} \u1680\u180E\u202F] [regexp {^\s+$} \u1680\u180E\u202F]
} {1 1}
test utf-24.5 {TclUniCharIsSpace} tip413 {
# this returns 1 with Unicode 7/TIP 413 compliance
string is space \x85\u1680\u180E\u200B\u202F\u2060
} 1
test utf-24.6 {unicode space char in regc_locale.c} tip413 {
# this returns 1 with Unicode 7/TIP 413 compliance
list [regexp {^[[:space:]]+$} \x85\u1680\u180E\u200B\u202F\u2060] [regexp {^\s+$} \x85\u1680\u180E\u200B\u202F\u2060]
} {1 1}
proc UniCharCaseCmpTest {order one two {constraints {}}} {
variable count
test utf-25.$count {Tcl_UniCharNcasecmp} -setup {
testobj freeallvars
} -constraints [linsert $constraints 0 teststringobj] -cleanup {
testobj freeallvars
} -body {
teststringobj set 1 $one
teststringobj set 2 $two
teststringobj maxchars 1
teststringobj maxchars 2
set result [string compare -nocase [teststringobj get 1] [teststringobj get 2]]
if {$result eq [string map {< -1 = 0 > 1} $order]} {
set result ok
} else {
set result "'$one' should be $order '$two' (no case)"
}
set result
} -result ok
incr count
}
variable count 1
UniCharCaseCmpTest < a b
UniCharCaseCmpTest > b a
UniCharCaseCmpTest > B a
UniCharCaseCmpTest > aBcB abca
UniCharCaseCmpTest < \uFFFF [format %c 0x10000] ucs4
UniCharCaseCmpTest < \uFFFF \U10000 {Uesc ucs4}
UniCharCaseCmpTest > [format %c 0x10000] \uFFFF ucs4
UniCharCaseCmpTest > \U10000 \uFFFF {Uesc ucs4}
test utf-26.1 {Tcl_UniCharDString} -setup {
testobj freeallvars
} -constraints {teststringobj testbytestring} -cleanup {
testobj freeallvars
} -body {
teststringobj set 1 foo
teststringobj maxchars 1
teststringobj append 1 [testbytestring barsoom\xF2\xC2\x80] 10
scan [string index [teststringobj get 1] 11] %c
} -result 128
unset count
rename UniCharCaseCmpTest {}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/util.test.
| ︙ | ︙ | |||
17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
testConstraint controversialNaN 1
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testdstring [llength [info commands testdstring]]
testConstraint testconcatobj [llength [info commands testconcatobj]]
testConstraint testdoubledigits [llength [info commands testdoubledigits]]
testConstraint testprint [llength [info commands testprint]]
# Big test for correct ordering of data in [expr]
proc testIEEE {} {
variable ieeeValues
binary scan [binary format dd -1.0 1.0] c* c
switch -exact -- $c {
| > > > | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 |
testConstraint controversialNaN 1
testConstraint testbytestring [llength [info commands testbytestring]]
testConstraint testdstring [llength [info commands testdstring]]
testConstraint testconcatobj [llength [info commands testconcatobj]]
testConstraint testdoubledigits [llength [info commands testdoubledigits]]
testConstraint testprint [llength [info commands testprint]]
testConstraint precision [expr {![catch {set saved_precision $::tcl_precision}]}]
# Big test for correct ordering of data in [expr]
proc testIEEE {} {
variable ieeeValues
binary scan [binary format dd -1.0 1.0] c* c
switch -exact -- $c {
|
| ︙ | ︙ | |||
275 276 277 278 279 280 281 |
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# get 1 UTF-8 character
Wrapper_Tcl_StringMatch "a\[a\u4e4fc]c" "a\u4e4fc"
} 1
test util-5.18 {Tcl_StringMatch: UTF-8} testbytestring {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# proper advance: wrong answer would match on UTF trail byte of \u4e4f
| | | 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 |
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# get 1 UTF-8 character
Wrapper_Tcl_StringMatch "a\[a\u4e4fc]c" "a\u4e4fc"
} 1
test util-5.18 {Tcl_StringMatch: UTF-8} testbytestring {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# proper advance: wrong answer would match on UTF trail byte of \u4e4f
Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} [testbytestring a\x8fc]
} 0
test util-5.19 {Tcl_StringMatch: UTF-8} {
# pattern += Tcl_UtfToUniChar(pattern, &endChar);
# proper advance.
Wrapper_Tcl_StringMatch {a[a\u4e4fc]c} "acc"
} 1
test util-5.20 {Tcl_StringMatch} {
|
| ︙ | ︙ | |||
380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 |
} 1
test util-5.50 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch *. ""
} 0
test util-5.51 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch "" ""
} 1
test util-6.5 {Tcl_PrintDouble - make sure there's a decimal point} {
concat x[expr 2.0]
} {x2.0}
test util-6.6 {Tcl_PrintDouble - make sure there's a decimal point} {
concat x[expr 3.0e98]
} {x3e+98}
# This test always succeeded in the C locale anyway...
test util-8.1 {TclNeedSpace - correct UTF8 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]
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
} 1
test util-5.50 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch *. ""
} 0
test util-5.51 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch "" ""
} 1
test util-5.52 {Tcl_StringMatch} {
Wrapper_Tcl_StringMatch \[a\u0000 a\x80
} 0
test util-6.1 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup {
set old_precision $::tcl_precision
set ::tcl_precision 12
} -body {
concat x[expr 1.4]
} -cleanup {
set ::tcl_precision $old_precision
} -result {x1.4}
test util-6.2 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup {
set old_precision $::tcl_precision
set ::tcl_precision 12
} -body {
concat x[expr 1.39999999999]
} -cleanup {
set ::tcl_precision $old_precision
} -result {x1.39999999999}
test util-6.3 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup {
set old_precision $::tcl_precision
set ::tcl_precision 12
} -body {
concat x[expr 1.399999999999]
} -cleanup {
set ::tcl_precision $old_precision
} -result {x1.4}
test util-6.4 {Tcl_PrintDouble - using tcl_precision} -constraints precision -setup {
set old_precision $::tcl_precision
set ::tcl_precision 5
} -body {
concat x[expr 1.123412341234]
} -cleanup {
set tcl_precision $old_precision
} -result {x1.1234}
test util-6.5 {Tcl_PrintDouble - make sure there's a decimal point} {
concat x[expr 2.0]
} {x2.0}
test util-6.6 {Tcl_PrintDouble - make sure there's a decimal point} {
concat x[expr 3.0e98]
} {x3e+98}
test util-7.1 {TclPrecTraceProc - unset callbacks} -constraints precision -setup {
set old_precision $::tcl_precision
} -body {
set tcl_precision 7
set x $tcl_precision
unset tcl_precision
list $x $tcl_precision
} -cleanup {
set ::tcl_precision $old_precision
} -result {7 7}
test util-7.2 {TclPrecTraceProc - read traces, sharing among interpreters} -constraints precision -setup {
set old_precision $::tcl_precision
} -body {
set tcl_precision 12
interp create child
set x [child eval set tcl_precision]
child eval {set tcl_precision 6}
interp delete child
list $x $tcl_precision
} -cleanup {
set ::tcl_precision $old_precision
} -result {12 6}
test util-7.3 {TclPrecTraceProc - write traces, safe interpreters} -constraints precision -setup {
set old_precision $::tcl_precision
} -body {
set tcl_precision 12
interp create -safe child
set x [child eval {
list [catch {set tcl_precision 8} msg] $msg
}]
interp delete child
list $x $tcl_precision
} -cleanup {
set ::tcl_precision $old_precision
} -result {{1 {can't set "tcl_precision": can't modify precision from a safe interpreter}} 12}
test util-7.4 {TclPrecTraceProc - write traces, bogus values} -constraints precision -setup {
set old_precision $::tcl_precision
} -body {
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 UTF8 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]
|
| ︙ | ︙ | |||
429 430 431 432 433 434 435 |
testdstring free
testdstring append {\ } -1
testdstring append \{ -1
testdstring element foo
llength [testdstring get]
} 2
test util-8.5 {TclNeedSpace - correct UTF8 handling} testdstring {
| < < < < < | < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
testdstring free
testdstring append {\ } -1
testdstring append \{ -1
testdstring element foo
llength [testdstring get]
} 2
test util-8.5 {TclNeedSpace - correct UTF8 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 UTF8 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 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 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 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 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 free
testdstring append {\\\\\\\\ } -1
testdstring start
testdstring end
# Should make {\\\\\\\\ {}}
list [llength [testdstring get]] [string index [testdstring get] 9]
} {2 \{}
test util-9.0.0 {Tcl_GetIntForIndex} {
string index abcd 0
} a
test util-9.0.1 {Tcl_GetIntForIndex} {
string index abcd 0x0
} a
|
| ︙ | ︙ | |||
649 650 651 652 653 654 655 |
} -returnCodes error -match glob -result *
test util-9.43 {Tcl_GetIntForIndex} -body {
string index a 0+1.5e1
} -returnCodes error -match glob -result *
test util-9.44 {Tcl_GetIntForIndex} -body {
string index a 0+1000000000000
} -result {}
| | | | | | | | 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 |
} -returnCodes error -match glob -result *
test util-9.43 {Tcl_GetIntForIndex} -body {
string index a 0+1.5e1
} -returnCodes error -match glob -result *
test util-9.44 {Tcl_GetIntForIndex} -body {
string index a 0+1000000000000
} -result {}
test util-9.45 {Tcl_GetIntForIndex} -body {
string index abcd end+2305843009213693950
} -result {}
test util-9.46 {Tcl_GetIntForIndex} -body {
string index abcd end+4294967294
} -result {}
# TIP 502
test util-9.47 {Tcl_GetIntForIndex} -body {
string index abcd 0x10000000000000000
} -result {}
test util-9.48 {Tcl_GetIntForIndex} {
string index abcd -0x10000000000000000
} {}
test util-9.49 {Tcl_GetIntForIndex} -body {
string index abcd end*1
} -returnCodes error -match glob -result *
test util-9.50 {Tcl_GetIntForIndex} -body {
|
| ︙ | ︙ | |||
680 681 682 683 684 685 686 |
} -returnCodes error -match glob -result *
test util-9.53 {Tcl_GetIntForIndex} -body {
string index abcd end-0.1
} -returnCodes error -match glob -result *
test util-9.54 {Tcl_GetIntForIndex} {
string index abcd end-0x10000000000000000
} {}
| | | | | | | | 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 |
} -returnCodes error -match glob -result *
test util-9.53 {Tcl_GetIntForIndex} -body {
string index abcd end-0.1
} -returnCodes error -match glob -result *
test util-9.54 {Tcl_GetIntForIndex} {
string index abcd end-0x10000000000000000
} {}
test util-9.55 {Tcl_GetIntForIndex} -body {
string index abcd end+0x10000000000000000
} -result {}
test util-9.56 {Tcl_GetIntForIndex} -body {
string index abcd end--0x10000000000000000
} -result {}
test util-9.57 {Tcl_GetIntForIndex} {
string index abcd end+-0x10000000000000000
} {}
test util-9.58 {Tcl_GetIntForIndex} -body {
string index abcd end--0x8000000000000000
} -result {}
test util-10.1 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
convertDouble 0x0000000000000000
} {0.0}
test util-10.2 {Tcl_PrintDouble - rounding} {ieeeFloatingPoint} {
convertDouble 0x8000000000000000
} {-0.0}
|
| ︙ | ︙ | |||
2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 |
format %#lx $x
}
-result 0x8010000000000000
-cleanup {
unset x
}
}
test util-17.1 {bankers' rounding [Bug 3349507]} {ieeeFloatingPoint} {
set r {}
foreach {input} {
0x1ffffffffffffc000
0x1ffffffffffffc800
0x1ffffffffffffd000
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 3051 3052 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 3956 3957 3958 3959 3960 3961 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 4070 4071 4072 4073 4074 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 4090 4091 4092 4093 4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 |
format %#lx $x
}
-result 0x8010000000000000
-cleanup {
unset x
}
}
foreach ::tcl_precision {0 12} {
for {set e -312} {$e < -9} {incr e} {
test util-16.1.$::tcl_precision.$e {shortening of numbers} \
"expr 1.1e$e" 1.1e$e
}
}
set tcl_precision 0
for {set e -9} {$e < -4} {incr e} {
test util-16.1.$::tcl_precision.$e {shortening of numbers} \
"expr 1.1e$e" 1.1e$e
}
set tcl_precision 12
for {set e -9} {$e < -4} {incr e} {
test util-16.1.$::tcl_precision.$e {8.4 compatible formatting of doubles} precision \
"expr 1.1e$e" 1.1e[format %+03d $e]
}
foreach ::tcl_precision {0 12} {
test util-16.1.$::tcl_precision.-4 {shortening of numbers} \
{expr 1.1e-4} \
0.00011
test util-16.1.$::tcl_precision.-3 {shortening of numbers} \
{expr 1.1e-3} \
0.0011
test util-16.1.$::tcl_precision.-2 {shortening of numbers} \
{expr 1.1e-2} \
0.011
test util-16.1.$::tcl_precision.-1 {shortening of numbers} \
{expr 1.1e-1} \
0.11
test util-16.1.$::tcl_precision.0 {shortening of numbers} \
{expr 1.1} \
1.1
for {set e 1} {$e < 17} {incr e} {
test util-16.1.$::tcl_precision.$e {shortening of numbers} \
"expr 11[string repeat 0 [expr {$e-1}]].0" \
11[string repeat 0 [expr {$e-1}]].0
}
for {set e 17} {$e < 309} {incr e} {
test util-16.1.$::tcl_precision.$e {shortening of numbers} \
"expr 1.1e$e" 1.1e+$e
}
}
set tcl_precision 17
test util-16.1.17.-300 {8.4 compatible formatting of doubles} precision \
{expr 1e-300} \
1e-300
test util-16.1.17.-299 {8.4 compatible formatting of doubles} precision \
{expr 1e-299} \
9.9999999999999999e-300
test util-16.1.17.-298 {8.4 compatible formatting of doubles} precision \
{expr 1e-298} \
9.9999999999999991e-299
test util-16.1.17.-297 {8.4 compatible formatting of doubles} precision \
{expr 1e-297} \
1e-297
test util-16.1.17.-296 {8.4 compatible formatting of doubles} precision \
{expr 1e-296} \
1e-296
test util-16.1.17.-295 {8.4 compatible formatting of doubles} precision \
{expr 1e-295} \
1.0000000000000001e-295
test util-16.1.17.-294 {8.4 compatible formatting of doubles} precision \
{expr 1e-294} \
1e-294
test util-16.1.17.-293 {8.4 compatible formatting of doubles} precision \
{expr 1e-293} \
1.0000000000000001e-293
test util-16.1.17.-292 {8.4 compatible formatting of doubles} precision \
{expr 1e-292} \
1.0000000000000001e-292
test util-16.1.17.-291 {8.4 compatible formatting of doubles} precision \
{expr 1e-291} \
9.9999999999999996e-292
test util-16.1.17.-290 {8.4 compatible formatting of doubles} precision \
{expr 1e-290} \
1.0000000000000001e-290
test util-16.1.17.-289 {8.4 compatible formatting of doubles} precision \
{expr 1e-289} \
1e-289
test util-16.1.17.-288 {8.4 compatible formatting of doubles} precision \
{expr 1e-288} \
1.0000000000000001e-288
test util-16.1.17.-287 {8.4 compatible formatting of doubles} precision \
{expr 1e-287} \
1e-287
test util-16.1.17.-286 {8.4 compatible formatting of doubles} precision \
{expr 1e-286} \
1.0000000000000001e-286
test util-16.1.17.-285 {8.4 compatible formatting of doubles} precision \
{expr 1e-285} \
1.0000000000000001e-285
test util-16.1.17.-284 {8.4 compatible formatting of doubles} precision \
{expr 1e-284} \
1e-284
test util-16.1.17.-283 {8.4 compatible formatting of doubles} precision \
{expr 1e-283} \
9.9999999999999995e-284
test util-16.1.17.-282 {8.4 compatible formatting of doubles} precision \
{expr 1e-282} \
1e-282
test util-16.1.17.-281 {8.4 compatible formatting of doubles} precision \
{expr 1e-281} \
1e-281
test util-16.1.17.-280 {8.4 compatible formatting of doubles} precision \
{expr 1e-280} \
9.9999999999999996e-281
test util-16.1.17.-279 {8.4 compatible formatting of doubles} precision \
{expr 1e-279} \
1.0000000000000001e-279
test util-16.1.17.-278 {8.4 compatible formatting of doubles} precision \
{expr 1e-278} \
9.9999999999999994e-279
test util-16.1.17.-277 {8.4 compatible formatting of doubles} precision \
{expr 1e-277} \
9.9999999999999997e-278
test util-16.1.17.-276 {8.4 compatible formatting of doubles} precision \
{expr 1e-276} \
1.0000000000000001e-276
test util-16.1.17.-275 {8.4 compatible formatting of doubles} precision \
{expr 1e-275} \
9.9999999999999993e-276
test util-16.1.17.-274 {8.4 compatible formatting of doubles} precision \
{expr 1e-274} \
9.9999999999999997e-275
test util-16.1.17.-273 {8.4 compatible formatting of doubles} precision \
{expr 1e-273} \
1.0000000000000001e-273
test util-16.1.17.-272 {8.4 compatible formatting of doubles} precision \
{expr 1e-272} \
9.9999999999999993e-273
test util-16.1.17.-271 {8.4 compatible formatting of doubles} precision \
{expr 1e-271} \
9.9999999999999996e-272
test util-16.1.17.-270 {8.4 compatible formatting of doubles} precision \
{expr 1e-270} \
1e-270
test util-16.1.17.-269 {8.4 compatible formatting of doubles} precision \
{expr 1e-269} \
9.9999999999999996e-270
test util-16.1.17.-268 {8.4 compatible formatting of doubles} precision \
{expr 1e-268} \
9.9999999999999996e-269
test util-16.1.17.-267 {8.4 compatible formatting of doubles} precision \
{expr 1e-267} \
9.9999999999999998e-268
test util-16.1.17.-266 {8.4 compatible formatting of doubles} precision \
{expr 1e-266} \
9.9999999999999998e-267
test util-16.1.17.-265 {8.4 compatible formatting of doubles} precision \
{expr 1e-265} \
9.9999999999999998e-266
test util-16.1.17.-264 {8.4 compatible formatting of doubles} precision \
{expr 1e-264} \
1e-264
test util-16.1.17.-263 {8.4 compatible formatting of doubles} precision \
{expr 1e-263} \
1e-263
test util-16.1.17.-262 {8.4 compatible formatting of doubles} precision \
{expr 1e-262} \
1e-262
test util-16.1.17.-261 {8.4 compatible formatting of doubles} precision \
{expr 1e-261} \
9.9999999999999998e-262
test util-16.1.17.-260 {8.4 compatible formatting of doubles} precision \
{expr 1e-260} \
9.9999999999999996e-261
test util-16.1.17.-259 {8.4 compatible formatting of doubles} precision \
{expr 1e-259} \
1.0000000000000001e-259
test util-16.1.17.-258 {8.4 compatible formatting of doubles} precision \
{expr 1e-258} \
9.9999999999999995e-259
test util-16.1.17.-257 {8.4 compatible formatting of doubles} precision \
{expr 1e-257} \
9.9999999999999998e-258
test util-16.1.17.-256 {8.4 compatible formatting of doubles} precision \
{expr 1e-256} \
9.9999999999999998e-257
test util-16.1.17.-255 {8.4 compatible formatting of doubles} precision \
{expr 1e-255} \
1e-255
test util-16.1.17.-254 {8.4 compatible formatting of doubles} precision \
{expr 1e-254} \
9.9999999999999991e-255
test util-16.1.17.-253 {8.4 compatible formatting of doubles} precision \
{expr 1e-253} \
1.0000000000000001e-253
test util-16.1.17.-252 {8.4 compatible formatting of doubles} precision \
{expr 1e-252} \
9.9999999999999994e-253
test util-16.1.17.-251 {8.4 compatible formatting of doubles} precision \
{expr 1e-251} \
1e-251
test util-16.1.17.-250 {8.4 compatible formatting of doubles} precision \
{expr 1e-250} \
1.0000000000000001e-250
test util-16.1.17.-249 {8.4 compatible formatting of doubles} precision \
{expr 1e-249} \
1.0000000000000001e-249
test util-16.1.17.-248 {8.4 compatible formatting of doubles} precision \
{expr 1e-248} \
9.9999999999999998e-249
test util-16.1.17.-247 {8.4 compatible formatting of doubles} precision \
{expr 1e-247} \
1e-247
test util-16.1.17.-246 {8.4 compatible formatting of doubles} precision \
{expr 1e-246} \
9.9999999999999996e-247
test util-16.1.17.-245 {8.4 compatible formatting of doubles} precision \
{expr 1e-245} \
9.9999999999999993e-246
test util-16.1.17.-244 {8.4 compatible formatting of doubles} precision \
{expr 1e-244} \
9.9999999999999993e-245
test util-16.1.17.-243 {8.4 compatible formatting of doubles} precision \
{expr 1e-243} \
1e-243
test util-16.1.17.-242 {8.4 compatible formatting of doubles} precision \
{expr 1e-242} \
9.9999999999999997e-243
test util-16.1.17.-241 {8.4 compatible formatting of doubles} precision \
{expr 1e-241} \
9.9999999999999997e-242
test util-16.1.17.-240 {8.4 compatible formatting of doubles} precision \
{expr 1e-240} \
9.9999999999999997e-241
test util-16.1.17.-239 {8.4 compatible formatting of doubles} precision \
{expr 1e-239} \
1.0000000000000001e-239
test util-16.1.17.-238 {8.4 compatible formatting of doubles} precision \
{expr 1e-238} \
9.9999999999999999e-239
test util-16.1.17.-237 {8.4 compatible formatting of doubles} precision \
{expr 1e-237} \
9.9999999999999999e-238
test util-16.1.17.-236 {8.4 compatible formatting of doubles} precision \
{expr 1e-236} \
1e-236
test util-16.1.17.-235 {8.4 compatible formatting of doubles} precision \
{expr 1e-235} \
9.9999999999999996e-236
test util-16.1.17.-234 {8.4 compatible formatting of doubles} precision \
{expr 1e-234} \
9.9999999999999996e-235
test util-16.1.17.-233 {8.4 compatible formatting of doubles} precision \
{expr 1e-233} \
9.9999999999999996e-234
test util-16.1.17.-232 {8.4 compatible formatting of doubles} precision \
{expr 1e-232} \
1e-232
test util-16.1.17.-231 {8.4 compatible formatting of doubles} precision \
{expr 1e-231} \
9.9999999999999999e-232
test util-16.1.17.-230 {8.4 compatible formatting of doubles} precision \
{expr 1e-230} \
1e-230
test util-16.1.17.-229 {8.4 compatible formatting of doubles} precision \
{expr 1e-229} \
1.0000000000000001e-229
test util-16.1.17.-228 {8.4 compatible formatting of doubles} precision \
{expr 1e-228} \
1e-228
test util-16.1.17.-227 {8.4 compatible formatting of doubles} precision \
{expr 1e-227} \
9.9999999999999994e-228
test util-16.1.17.-226 {8.4 compatible formatting of doubles} precision \
{expr 1e-226} \
9.9999999999999992e-227
test util-16.1.17.-225 {8.4 compatible formatting of doubles} precision \
{expr 1e-225} \
9.9999999999999996e-226
test util-16.1.17.-224 {8.4 compatible formatting of doubles} precision \
{expr 1e-224} \
1e-224
test util-16.1.17.-223 {8.4 compatible formatting of doubles} precision \
{expr 1e-223} \
9.9999999999999997e-224
test util-16.1.17.-222 {8.4 compatible formatting of doubles} precision \
{expr 1e-222} \
1e-222
test util-16.1.17.-221 {8.4 compatible formatting of doubles} precision \
{expr 1e-221} \
1e-221
test util-16.1.17.-220 {8.4 compatible formatting of doubles} precision \
{expr 1e-220} \
9.9999999999999999e-221
test util-16.1.17.-219 {8.4 compatible formatting of doubles} precision \
{expr 1e-219} \
1e-219
test util-16.1.17.-218 {8.4 compatible formatting of doubles} precision \
{expr 1e-218} \
1e-218
test util-16.1.17.-217 {8.4 compatible formatting of doubles} precision \
{expr 1e-217} \
1.0000000000000001e-217
test util-16.1.17.-216 {8.4 compatible formatting of doubles} precision \
{expr 1e-216} \
1e-216
test util-16.1.17.-215 {8.4 compatible formatting of doubles} precision \
{expr 1e-215} \
1e-215
test util-16.1.17.-214 {8.4 compatible formatting of doubles} precision \
{expr 1e-214} \
9.9999999999999991e-215
test util-16.1.17.-213 {8.4 compatible formatting of doubles} precision \
{expr 1e-213} \
9.9999999999999995e-214
test util-16.1.17.-212 {8.4 compatible formatting of doubles} precision \
{expr 1e-212} \
9.9999999999999995e-213
test util-16.1.17.-211 {8.4 compatible formatting of doubles} precision \
{expr 1e-211} \
1.0000000000000001e-211
test util-16.1.17.-210 {8.4 compatible formatting of doubles} precision \
{expr 1e-210} \
1e-210
test util-16.1.17.-209 {8.4 compatible formatting of doubles} precision \
{expr 1e-209} \
1e-209
test util-16.1.17.-208 {8.4 compatible formatting of doubles} precision \
{expr 1e-208} \
1.0000000000000001e-208
test util-16.1.17.-207 {8.4 compatible formatting of doubles} precision \
{expr 1e-207} \
9.9999999999999993e-208
test util-16.1.17.-206 {8.4 compatible formatting of doubles} precision \
{expr 1e-206} \
1e-206
test util-16.1.17.-205 {8.4 compatible formatting of doubles} precision \
{expr 1e-205} \
1e-205
test util-16.1.17.-204 {8.4 compatible formatting of doubles} precision \
{expr 1e-204} \
1e-204
test util-16.1.17.-203 {8.4 compatible formatting of doubles} precision \
{expr 1e-203} \
1e-203
test util-16.1.17.-202 {8.4 compatible formatting of doubles} precision \
{expr 1e-202} \
1e-202
test util-16.1.17.-201 {8.4 compatible formatting of doubles} precision \
{expr 1e-201} \
9.9999999999999995e-202
test util-16.1.17.-200 {8.4 compatible formatting of doubles} precision \
{expr 1e-200} \
9.9999999999999998e-201
test util-16.1.17.-199 {8.4 compatible formatting of doubles} precision \
{expr 1e-199} \
9.9999999999999998e-200
test util-16.1.17.-198 {8.4 compatible formatting of doubles} precision \
{expr 1e-198} \
9.9999999999999991e-199
test util-16.1.17.-197 {8.4 compatible formatting of doubles} precision \
{expr 1e-197} \
9.9999999999999999e-198
test util-16.1.17.-196 {8.4 compatible formatting of doubles} precision \
{expr 1e-196} \
1e-196
test util-16.1.17.-195 {8.4 compatible formatting of doubles} precision \
{expr 1e-195} \
1.0000000000000001e-195
test util-16.1.17.-194 {8.4 compatible formatting of doubles} precision \
{expr 1e-194} \
1e-194
test util-16.1.17.-193 {8.4 compatible formatting of doubles} precision \
{expr 1e-193} \
1e-193
test util-16.1.17.-192 {8.4 compatible formatting of doubles} precision \
{expr 1e-192} \
1.0000000000000001e-192
test util-16.1.17.-191 {8.4 compatible formatting of doubles} precision \
{expr 1e-191} \
1e-191
test util-16.1.17.-190 {8.4 compatible formatting of doubles} precision \
{expr 1e-190} \
1e-190
test util-16.1.17.-189 {8.4 compatible formatting of doubles} precision \
{expr 1e-189} \
1.0000000000000001e-189
test util-16.1.17.-188 {8.4 compatible formatting of doubles} precision \
{expr 1e-188} \
9.9999999999999995e-189
test util-16.1.17.-187 {8.4 compatible formatting of doubles} precision \
{expr 1e-187} \
1e-187
test util-16.1.17.-186 {8.4 compatible formatting of doubles} precision \
{expr 1e-186} \
9.9999999999999991e-187
test util-16.1.17.-185 {8.4 compatible formatting of doubles} precision \
{expr 1e-185} \
9.9999999999999999e-186
test util-16.1.17.-184 {8.4 compatible formatting of doubles} precision \
{expr 1e-184} \
1.0000000000000001e-184
test util-16.1.17.-183 {8.4 compatible formatting of doubles} precision \
{expr 1e-183} \
1e-183
test util-16.1.17.-182 {8.4 compatible formatting of doubles} precision \
{expr 1e-182} \
1e-182
test util-16.1.17.-181 {8.4 compatible formatting of doubles} precision \
{expr 1e-181} \
1e-181
test util-16.1.17.-180 {8.4 compatible formatting of doubles} precision \
{expr 1e-180} \
1e-180
test util-16.1.17.-179 {8.4 compatible formatting of doubles} precision \
{expr 1e-179} \
1e-179
test util-16.1.17.-178 {8.4 compatible formatting of doubles} precision \
{expr 1e-178} \
9.9999999999999995e-179
test util-16.1.17.-177 {8.4 compatible formatting of doubles} precision \
{expr 1e-177} \
9.9999999999999995e-178
test util-16.1.17.-176 {8.4 compatible formatting of doubles} precision \
{expr 1e-176} \
1e-176
test util-16.1.17.-175 {8.4 compatible formatting of doubles} precision \
{expr 1e-175} \
1e-175
test util-16.1.17.-174 {8.4 compatible formatting of doubles} precision \
{expr 1e-174} \
1e-174
test util-16.1.17.-173 {8.4 compatible formatting of doubles} precision \
{expr 1e-173} \
1e-173
test util-16.1.17.-172 {8.4 compatible formatting of doubles} precision \
{expr 1e-172} \
1e-172
test util-16.1.17.-171 {8.4 compatible formatting of doubles} precision \
{expr 1e-171} \
9.9999999999999998e-172
test util-16.1.17.-170 {8.4 compatible formatting of doubles} precision \
{expr 1e-170} \
9.9999999999999998e-171
test util-16.1.17.-169 {8.4 compatible formatting of doubles} precision \
{expr 1e-169} \
1e-169
test util-16.1.17.-168 {8.4 compatible formatting of doubles} precision \
{expr 1e-168} \
1e-168
test util-16.1.17.-167 {8.4 compatible formatting of doubles} precision \
{expr 1e-167} \
1e-167
test util-16.1.17.-166 {8.4 compatible formatting of doubles} precision \
{expr 1e-166} \
1e-166
test util-16.1.17.-165 {8.4 compatible formatting of doubles} precision \
{expr 1e-165} \
1e-165
test util-16.1.17.-164 {8.4 compatible formatting of doubles} precision \
{expr 1e-164} \
9.9999999999999996e-165
test util-16.1.17.-163 {8.4 compatible formatting of doubles} precision \
{expr 1e-163} \
9.9999999999999992e-164
test util-16.1.17.-162 {8.4 compatible formatting of doubles} precision \
{expr 1e-162} \
9.9999999999999995e-163
test util-16.1.17.-161 {8.4 compatible formatting of doubles} precision \
{expr 1e-161} \
1e-161
test util-16.1.17.-160 {8.4 compatible formatting of doubles} precision \
{expr 1e-160} \
9.9999999999999999e-161
test util-16.1.17.-159 {8.4 compatible formatting of doubles} precision \
{expr 1e-159} \
9.9999999999999999e-160
test util-16.1.17.-158 {8.4 compatible formatting of doubles} precision \
{expr 1e-158} \
1.0000000000000001e-158
test util-16.1.17.-157 {8.4 compatible formatting of doubles} precision \
{expr 1e-157} \
9.9999999999999994e-158
test util-16.1.17.-156 {8.4 compatible formatting of doubles} precision \
{expr 1e-156} \
1e-156
test util-16.1.17.-155 {8.4 compatible formatting of doubles} precision \
{expr 1e-155} \
1e-155
test util-16.1.17.-154 {8.4 compatible formatting of doubles} precision \
{expr 1e-154} \
9.9999999999999997e-155
test util-16.1.17.-153 {8.4 compatible formatting of doubles} precision \
{expr 1e-153} \
1e-153
test util-16.1.17.-152 {8.4 compatible formatting of doubles} precision \
{expr 1e-152} \
1.0000000000000001e-152
test util-16.1.17.-151 {8.4 compatible formatting of doubles} precision \
{expr 1e-151} \
9.9999999999999994e-152
test util-16.1.17.-150 {8.4 compatible formatting of doubles} precision \
{expr 1e-150} \
1e-150
test util-16.1.17.-149 {8.4 compatible formatting of doubles} precision \
{expr 1e-149} \
9.9999999999999998e-150
test util-16.1.17.-148 {8.4 compatible formatting of doubles} precision \
{expr 1e-148} \
9.9999999999999994e-149
test util-16.1.17.-147 {8.4 compatible formatting of doubles} precision \
{expr 1e-147} \
9.9999999999999997e-148
test util-16.1.17.-146 {8.4 compatible formatting of doubles} precision \
{expr 1e-146} \
1e-146
test util-16.1.17.-145 {8.4 compatible formatting of doubles} precision \
{expr 1e-145} \
9.9999999999999991e-146
test util-16.1.17.-144 {8.4 compatible formatting of doubles} precision \
{expr 1e-144} \
9.9999999999999995e-145
test util-16.1.17.-143 {8.4 compatible formatting of doubles} precision \
{expr 1e-143} \
9.9999999999999995e-144
test util-16.1.17.-142 {8.4 compatible formatting of doubles} precision \
{expr 1e-142} \
1e-142
test util-16.1.17.-141 {8.4 compatible formatting of doubles} precision \
{expr 1e-141} \
1e-141
test util-16.1.17.-140 {8.4 compatible formatting of doubles} precision \
{expr 1e-140} \
9.9999999999999998e-141
test util-16.1.17.-139 {8.4 compatible formatting of doubles} precision \
{expr 1e-139} \
1e-139
test util-16.1.17.-138 {8.4 compatible formatting of doubles} precision \
{expr 1e-138} \
1.0000000000000001e-138
test util-16.1.17.-137 {8.4 compatible formatting of doubles} precision \
{expr 1e-137} \
9.9999999999999998e-138
test util-16.1.17.-136 {8.4 compatible formatting of doubles} precision \
{expr 1e-136} \
1e-136
test util-16.1.17.-135 {8.4 compatible formatting of doubles} precision \
{expr 1e-135} \
1e-135
test util-16.1.17.-134 {8.4 compatible formatting of doubles} precision \
{expr 1e-134} \
1e-134
test util-16.1.17.-133 {8.4 compatible formatting of doubles} precision \
{expr 1e-133} \
1.0000000000000001e-133
test util-16.1.17.-132 {8.4 compatible formatting of doubles} precision \
{expr 1e-132} \
9.9999999999999999e-133
test util-16.1.17.-131 {8.4 compatible formatting of doubles} precision \
{expr 1e-131} \
9.9999999999999999e-132
test util-16.1.17.-130 {8.4 compatible formatting of doubles} precision \
{expr 1e-130} \
1.0000000000000001e-130
test util-16.1.17.-129 {8.4 compatible formatting of doubles} precision \
{expr 1e-129} \
9.9999999999999993e-130
test util-16.1.17.-128 {8.4 compatible formatting of doubles} precision \
{expr 1e-128} \
1.0000000000000001e-128
test util-16.1.17.-127 {8.4 compatible formatting of doubles} precision \
{expr 1e-127} \
1e-127
test util-16.1.17.-126 {8.4 compatible formatting of doubles} precision \
{expr 1e-126} \
9.9999999999999995e-127
test util-16.1.17.-125 {8.4 compatible formatting of doubles} precision \
{expr 1e-125} \
1e-125
test util-16.1.17.-124 {8.4 compatible formatting of doubles} precision \
{expr 1e-124} \
9.9999999999999993e-125
test util-16.1.17.-123 {8.4 compatible formatting of doubles} precision \
{expr 1e-123} \
1.0000000000000001e-123
test util-16.1.17.-122 {8.4 compatible formatting of doubles} precision \
{expr 1e-122} \
1.0000000000000001e-122
test util-16.1.17.-121 {8.4 compatible formatting of doubles} precision \
{expr 1e-121} \
9.9999999999999998e-122
test util-16.1.17.-120 {8.4 compatible formatting of doubles} precision \
{expr 1e-120} \
9.9999999999999998e-121
test util-16.1.17.-119 {8.4 compatible formatting of doubles} precision \
{expr 1e-119} \
1e-119
test util-16.1.17.-118 {8.4 compatible formatting of doubles} precision \
{expr 1e-118} \
9.9999999999999999e-119
test util-16.1.17.-117 {8.4 compatible formatting of doubles} precision \
{expr 1e-117} \
1e-117
test util-16.1.17.-116 {8.4 compatible formatting of doubles} precision \
{expr 1e-116} \
9.9999999999999999e-117
test util-16.1.17.-115 {8.4 compatible formatting of doubles} precision \
{expr 1e-115} \
1.0000000000000001e-115
test util-16.1.17.-114 {8.4 compatible formatting of doubles} precision \
{expr 1e-114} \
1.0000000000000001e-114
test util-16.1.17.-113 {8.4 compatible formatting of doubles} precision \
{expr 1e-113} \
9.9999999999999998e-114
test util-16.1.17.-112 {8.4 compatible formatting of doubles} precision \
{expr 1e-112} \
9.9999999999999995e-113
test util-16.1.17.-111 {8.4 compatible formatting of doubles} precision \
{expr 1e-111} \
1.0000000000000001e-111
test util-16.1.17.-110 {8.4 compatible formatting of doubles} precision \
{expr 1e-110} \
1.0000000000000001e-110
test util-16.1.17.-109 {8.4 compatible formatting of doubles} precision \
{expr 1e-109} \
9.9999999999999999e-110
test util-16.1.17.-108 {8.4 compatible formatting of doubles} precision \
{expr 1e-108} \
1e-108
test util-16.1.17.-107 {8.4 compatible formatting of doubles} precision \
{expr 1e-107} \
1e-107
test util-16.1.17.-106 {8.4 compatible formatting of doubles} precision \
{expr 1e-106} \
9.9999999999999994e-107
test util-16.1.17.-105 {8.4 compatible formatting of doubles} precision \
{expr 1e-105} \
9.9999999999999997e-106
test util-16.1.17.-104 {8.4 compatible formatting of doubles} precision \
{expr 1e-104} \
9.9999999999999993e-105
test util-16.1.17.-103 {8.4 compatible formatting of doubles} precision \
{expr 1e-103} \
9.9999999999999996e-104
test util-16.1.17.-102 {8.4 compatible formatting of doubles} precision \
{expr 1e-102} \
9.9999999999999993e-103
test util-16.1.17.-101 {8.4 compatible formatting of doubles} precision \
{expr 1e-101} \
1.0000000000000001e-101
test util-16.1.17.-100 {8.4 compatible formatting of doubles} precision \
{expr 1e-100} \
1e-100
test util-16.1.17.-99 {8.4 compatible formatting of doubles} precision \
{expr 1e-99} \
1e-99
test util-16.1.17.-98 {8.4 compatible formatting of doubles} precision \
{expr 1e-98} \
9.9999999999999994e-99
test util-16.1.17.-97 {8.4 compatible formatting of doubles} precision \
{expr 1e-97} \
1e-97
test util-16.1.17.-96 {8.4 compatible formatting of doubles} precision \
{expr 1e-96} \
9.9999999999999991e-97
test util-16.1.17.-95 {8.4 compatible formatting of doubles} precision \
{expr 1e-95} \
9.9999999999999999e-96
test util-16.1.17.-94 {8.4 compatible formatting of doubles} precision \
{expr 1e-94} \
9.9999999999999996e-95
test util-16.1.17.-93 {8.4 compatible formatting of doubles} precision \
{expr 1e-93} \
9.999999999999999e-94
test util-16.1.17.-92 {8.4 compatible formatting of doubles} precision \
{expr 1e-92} \
9.9999999999999999e-93
test util-16.1.17.-91 {8.4 compatible formatting of doubles} precision \
{expr 1e-91} \
1e-91
test util-16.1.17.-90 {8.4 compatible formatting of doubles} precision \
{expr 1e-90} \
9.9999999999999999e-91
test util-16.1.17.-89 {8.4 compatible formatting of doubles} precision \
{expr 1e-89} \
1e-89
test util-16.1.17.-88 {8.4 compatible formatting of doubles} precision \
{expr 1e-88} \
9.9999999999999993e-89
test util-16.1.17.-87 {8.4 compatible formatting of doubles} precision \
{expr 1e-87} \
1e-87
test util-16.1.17.-86 {8.4 compatible formatting of doubles} precision \
{expr 1e-86} \
1.0000000000000001e-86
test util-16.1.17.-85 {8.4 compatible formatting of doubles} precision \
{expr 1e-85} \
9.9999999999999998e-86
test util-16.1.17.-84 {8.4 compatible formatting of doubles} precision \
{expr 1e-84} \
1e-84
test util-16.1.17.-83 {8.4 compatible formatting of doubles} precision \
{expr 1e-83} \
1e-83
test util-16.1.17.-82 {8.4 compatible formatting of doubles} precision \
{expr 1e-82} \
9.9999999999999996e-83
test util-16.1.17.-81 {8.4 compatible formatting of doubles} precision \
{expr 1e-81} \
9.9999999999999996e-82
test util-16.1.17.-80 {8.4 compatible formatting of doubles} precision \
{expr 1e-80} \
9.9999999999999996e-81
test util-16.1.17.-79 {8.4 compatible formatting of doubles} precision \
{expr 1e-79} \
1e-79
test util-16.1.17.-78 {8.4 compatible formatting of doubles} precision \
{expr 1e-78} \
1e-78
test util-16.1.17.-77 {8.4 compatible formatting of doubles} precision \
{expr 1e-77} \
9.9999999999999993e-78
test util-16.1.17.-76 {8.4 compatible formatting of doubles} precision \
{expr 1e-76} \
9.9999999999999993e-77
test util-16.1.17.-75 {8.4 compatible formatting of doubles} precision \
{expr 1e-75} \
9.9999999999999996e-76
test util-16.1.17.-74 {8.4 compatible formatting of doubles} precision \
{expr 1e-74} \
9.9999999999999996e-75
test util-16.1.17.-73 {8.4 compatible formatting of doubles} precision \
{expr 1e-73} \
1e-73
test util-16.1.17.-72 {8.4 compatible formatting of doubles} precision \
{expr 1e-72} \
9.9999999999999997e-73
test util-16.1.17.-71 {8.4 compatible formatting of doubles} precision \
{expr 1e-71} \
9.9999999999999992e-72
test util-16.1.17.-70 {8.4 compatible formatting of doubles} precision \
{expr 1e-70} \
1e-70
test util-16.1.17.-69 {8.4 compatible formatting of doubles} precision \
{expr 1e-69} \
9.9999999999999996e-70
test util-16.1.17.-68 {8.4 compatible formatting of doubles} precision \
{expr 1e-68} \
1.0000000000000001e-68
test util-16.1.17.-67 {8.4 compatible formatting of doubles} precision \
{expr 1e-67} \
9.9999999999999994e-68
test util-16.1.17.-66 {8.4 compatible formatting of doubles} precision \
{expr 1e-66} \
9.9999999999999998e-67
test util-16.1.17.-65 {8.4 compatible formatting of doubles} precision \
{expr 1e-65} \
9.9999999999999992e-66
test util-16.1.17.-64 {8.4 compatible formatting of doubles} precision \
{expr 1e-64} \
9.9999999999999997e-65
test util-16.1.17.-63 {8.4 compatible formatting of doubles} precision \
{expr 1e-63} \
1.0000000000000001e-63
test util-16.1.17.-62 {8.4 compatible formatting of doubles} precision \
{expr 1e-62} \
1e-62
test util-16.1.17.-61 {8.4 compatible formatting of doubles} precision \
{expr 1e-61} \
1e-61
test util-16.1.17.-60 {8.4 compatible formatting of doubles} precision \
{expr 1e-60} \
9.9999999999999997e-61
test util-16.1.17.-59 {8.4 compatible formatting of doubles} precision \
{expr 1e-59} \
1e-59
test util-16.1.17.-58 {8.4 compatible formatting of doubles} precision \
{expr 1e-58} \
1e-58
test util-16.1.17.-57 {8.4 compatible formatting of doubles} precision \
{expr 1e-57} \
9.9999999999999995e-58
test util-16.1.17.-56 {8.4 compatible formatting of doubles} precision \
{expr 1e-56} \
1e-56
test util-16.1.17.-55 {8.4 compatible formatting of doubles} precision \
{expr 1e-55} \
9.9999999999999999e-56
test util-16.1.17.-54 {8.4 compatible formatting of doubles} precision \
{expr 1e-54} \
1e-54
test util-16.1.17.-53 {8.4 compatible formatting of doubles} precision \
{expr 1e-53} \
1e-53
test util-16.1.17.-52 {8.4 compatible formatting of doubles} precision \
{expr 1e-52} \
1e-52
test util-16.1.17.-51 {8.4 compatible formatting of doubles} precision \
{expr 1e-51} \
1e-51
test util-16.1.17.-50 {8.4 compatible formatting of doubles} precision \
{expr 1e-50} \
1e-50
test util-16.1.17.-49 {8.4 compatible formatting of doubles} precision \
{expr 1e-49} \
9.9999999999999994e-50
test util-16.1.17.-48 {8.4 compatible formatting of doubles} precision \
{expr 1e-48} \
9.9999999999999997e-49
test util-16.1.17.-47 {8.4 compatible formatting of doubles} precision \
{expr 1e-47} \
9.9999999999999997e-48
test util-16.1.17.-46 {8.4 compatible formatting of doubles} precision \
{expr 1e-46} \
1e-46
test util-16.1.17.-45 {8.4 compatible formatting of doubles} precision \
{expr 1e-45} \
9.9999999999999998e-46
test util-16.1.17.-44 {8.4 compatible formatting of doubles} precision \
{expr 1e-44} \
9.9999999999999995e-45
test util-16.1.17.-43 {8.4 compatible formatting of doubles} precision \
{expr 1e-43} \
1.0000000000000001e-43
test util-16.1.17.-42 {8.4 compatible formatting of doubles} precision \
{expr 1e-42} \
1e-42
test util-16.1.17.-41 {8.4 compatible formatting of doubles} precision \
{expr 1e-41} \
1e-41
test util-16.1.17.-40 {8.4 compatible formatting of doubles} precision \
{expr 1e-40} \
9.9999999999999993e-41
test util-16.1.17.-39 {8.4 compatible formatting of doubles} precision \
{expr 1e-39} \
9.9999999999999993e-40
test util-16.1.17.-38 {8.4 compatible formatting of doubles} precision \
{expr 1e-38} \
9.9999999999999996e-39
test util-16.1.17.-37 {8.4 compatible formatting of doubles} precision \
{expr 1e-37} \
1.0000000000000001e-37
test util-16.1.17.-36 {8.4 compatible formatting of doubles} precision \
{expr 1e-36} \
9.9999999999999994e-37
test util-16.1.17.-35 {8.4 compatible formatting of doubles} precision \
{expr 1e-35} \
1e-35
test util-16.1.17.-34 {8.4 compatible formatting of doubles} precision \
{expr 1e-34} \
9.9999999999999993e-35
test util-16.1.17.-33 {8.4 compatible formatting of doubles} precision \
{expr 1e-33} \
1.0000000000000001e-33
test util-16.1.17.-32 {8.4 compatible formatting of doubles} precision \
{expr 1e-32} \
1.0000000000000001e-32
test util-16.1.17.-31 {8.4 compatible formatting of doubles} precision \
{expr 1e-31} \
1.0000000000000001e-31
test util-16.1.17.-30 {8.4 compatible formatting of doubles} precision \
{expr 1e-30} \
1.0000000000000001e-30
test util-16.1.17.-29 {8.4 compatible formatting of doubles} precision \
{expr 1e-29} \
9.9999999999999994e-30
test util-16.1.17.-28 {8.4 compatible formatting of doubles} precision \
{expr 1e-28} \
9.9999999999999997e-29
test util-16.1.17.-27 {8.4 compatible formatting of doubles} precision \
{expr 1e-27} \
1e-27
test util-16.1.17.-26 {8.4 compatible formatting of doubles} precision \
{expr 1e-26} \
1e-26
test util-16.1.17.-25 {8.4 compatible formatting of doubles} precision \
{expr 1e-25} \
1e-25
test util-16.1.17.-24 {8.4 compatible formatting of doubles} precision \
{expr 1e-24} \
9.9999999999999992e-25
test util-16.1.17.-23 {8.4 compatible formatting of doubles} precision \
{expr 1e-23} \
9.9999999999999996e-24
test util-16.1.17.-22 {8.4 compatible formatting of doubles} precision \
{expr 1e-22} \
1e-22
test util-16.1.17.-21 {8.4 compatible formatting of doubles} precision \
{expr 1e-21} \
9.9999999999999991e-22
test util-16.1.17.-20 {8.4 compatible formatting of doubles} precision \
{expr 1e-20} \
9.9999999999999995e-21
test util-16.1.17.-19 {8.4 compatible formatting of doubles} precision \
{expr 1e-19} \
9.9999999999999998e-20
test util-16.1.17.-18 {8.4 compatible formatting of doubles} precision \
{expr 1e-18} \
1.0000000000000001e-18
test util-16.1.17.-17 {8.4 compatible formatting of doubles} precision \
{expr 1e-17} \
1.0000000000000001e-17
test util-16.1.17.-16 {8.4 compatible formatting of doubles} precision \
{expr 1e-16} \
9.9999999999999998e-17
test util-16.1.17.-15 {8.4 compatible formatting of doubles} precision \
{expr 1e-15} \
1.0000000000000001e-15
test util-16.1.17.-14 {8.4 compatible formatting of doubles} precision \
{expr 1e-14} \
1e-14
test util-16.1.17.-13 {8.4 compatible formatting of doubles} precision \
{expr 1e-13} \
1e-13
test util-16.1.17.-12 {8.4 compatible formatting of doubles} precision \
{expr 1e-12} \
9.9999999999999998e-13
test util-16.1.17.-11 {8.4 compatible formatting of doubles} precision \
{expr 1e-11} \
9.9999999999999994e-12
test util-16.1.17.-10 {8.4 compatible formatting of doubles} precision \
{expr 1e-10} \
1e-10
test util-16.1.17.-9 {8.4 compatible formatting of doubles} precision \
{expr 1e-9} \
1.0000000000000001e-09
test util-16.1.17.-8 {8.4 compatible formatting of doubles} precision \
{expr 1e-8} \
1e-08
test util-16.1.17.-7 {8.4 compatible formatting of doubles} precision \
{expr 1e-7} \
9.9999999999999995e-08
test util-16.1.17.-6 {8.4 compatible formatting of doubles} precision \
{expr 1e-6} \
9.9999999999999995e-07
test util-16.1.17.-5 {8.4 compatible formatting of doubles} precision \
{expr 1e-5} \
1.0000000000000001e-05
test util-16.1.17.-4 {8.4 compatible formatting of doubles} precision \
{expr 1e-4} \
0.0001
test util-16.1.17.-3 {8.4 compatible formatting of doubles} precision \
{expr 1e-3} \
0.001
test util-16.1.17.-2 {8.4 compatible formatting of doubles} precision \
{expr 1e-2} \
0.01
test util-16.1.17.-1 {8.4 compatible formatting of doubles} precision \
{expr 1e-1} \
0.10000000000000001
test util-16.1.17.0 {8.4 compatible formatting of doubles} precision \
{expr 1e0} \
1.0
test util-16.1.17.1 {8.4 compatible formatting of doubles} precision \
{expr 1e1} \
10.0
test util-16.1.17.2 {8.4 compatible formatting of doubles} precision \
{expr 1e2} \
100.0
test util-16.1.17.3 {8.4 compatible formatting of doubles} precision \
{expr 1e3} \
1000.0
test util-16.1.17.4 {8.4 compatible formatting of doubles} precision \
{expr 1e4} \
10000.0
test util-16.1.17.5 {8.4 compatible formatting of doubles} precision \
{expr 1e5} \
100000.0
test util-16.1.17.6 {8.4 compatible formatting of doubles} precision \
{expr 1e6} \
1000000.0
test util-16.1.17.7 {8.4 compatible formatting of doubles} precision \
{expr 1e7} \
10000000.0
test util-16.1.17.8 {8.4 compatible formatting of doubles} precision \
{expr 1e8} \
100000000.0
test util-16.1.17.9 {8.4 compatible formatting of doubles} precision \
{expr 1e9} \
1000000000.0
test util-16.1.17.10 {8.4 compatible formatting of doubles} precision \
{expr 1e10} \
10000000000.0
test util-16.1.17.11 {8.4 compatible formatting of doubles} precision \
{expr 1e11} \
100000000000.0
test util-16.1.17.12 {8.4 compatible formatting of doubles} precision \
{expr 1e12} \
1000000000000.0
test util-16.1.17.13 {8.4 compatible formatting of doubles} precision \
{expr 1e13} \
10000000000000.0
test util-16.1.17.14 {8.4 compatible formatting of doubles} precision \
{expr 1e14} \
100000000000000.0
test util-16.1.17.15 {8.4 compatible formatting of doubles} precision \
{expr 1e15} \
1000000000000000.0
test util-16.1.17.16 {8.4 compatible formatting of doubles} precision \
{expr 1e16} \
10000000000000000.0
test util-16.1.17.17 {8.4 compatible formatting of doubles} precision \
{expr 1e17} \
1e+17
test util-16.1.17.18 {8.4 compatible formatting of doubles} precision \
{expr 1e18} \
1e+18
test util-16.1.17.19 {8.4 compatible formatting of doubles} precision \
{expr 1e19} \
1e+19
test util-16.1.17.20 {8.4 compatible formatting of doubles} precision \
{expr 1e20} \
1e+20
test util-16.1.17.21 {8.4 compatible formatting of doubles} precision \
{expr 1e21} \
1e+21
test util-16.1.17.22 {8.4 compatible formatting of doubles} precision \
{expr 1e22} \
1e+22
test util-16.1.17.23 {8.4 compatible formatting of doubles} precision \
{expr 1e23} \
9.9999999999999992e+22
test util-16.1.17.24 {8.4 compatible formatting of doubles} precision \
{expr 1e24} \
9.9999999999999998e+23
test util-16.1.17.25 {8.4 compatible formatting of doubles} precision \
{expr 1e25} \
1.0000000000000001e+25
test util-16.1.17.26 {8.4 compatible formatting of doubles} precision \
{expr 1e26} \
1e+26
test util-16.1.17.27 {8.4 compatible formatting of doubles} precision \
{expr 1e27} \
1e+27
test util-16.1.17.28 {8.4 compatible formatting of doubles} precision \
{expr 1e28} \
9.9999999999999996e+27
test util-16.1.17.29 {8.4 compatible formatting of doubles} precision \
{expr 1e29} \
9.9999999999999991e+28
test util-16.1.17.30 {8.4 compatible formatting of doubles} precision \
{expr 1e30} \
1e+30
test util-16.1.17.31 {8.4 compatible formatting of doubles} precision \
{expr 1e31} \
9.9999999999999996e+30
test util-16.1.17.32 {8.4 compatible formatting of doubles} precision \
{expr 1e32} \
1.0000000000000001e+32
test util-16.1.17.33 {8.4 compatible formatting of doubles} precision \
{expr 1e33} \
9.9999999999999995e+32
test util-16.1.17.34 {8.4 compatible formatting of doubles} precision \
{expr 1e34} \
9.9999999999999995e+33
test util-16.1.17.35 {8.4 compatible formatting of doubles} precision \
{expr 1e35} \
9.9999999999999997e+34
test util-16.1.17.36 {8.4 compatible formatting of doubles} precision \
{expr 1e36} \
1e+36
test util-16.1.17.37 {8.4 compatible formatting of doubles} precision \
{expr 1e37} \
9.9999999999999995e+36
test util-16.1.17.38 {8.4 compatible formatting of doubles} precision \
{expr 1e38} \
9.9999999999999998e+37
test util-16.1.17.39 {8.4 compatible formatting of doubles} precision \
{expr 1e39} \
9.9999999999999994e+38
test util-16.1.17.40 {8.4 compatible formatting of doubles} precision \
{expr 1e40} \
1e+40
test util-16.1.17.41 {8.4 compatible formatting of doubles} precision \
{expr 1e41} \
1e+41
test util-16.1.17.42 {8.4 compatible formatting of doubles} precision \
{expr 1e42} \
1e+42
test util-16.1.17.43 {8.4 compatible formatting of doubles} precision \
{expr 1e43} \
1e+43
test util-16.1.17.44 {8.4 compatible formatting of doubles} precision \
{expr 1e44} \
1.0000000000000001e+44
test util-16.1.17.45 {8.4 compatible formatting of doubles} precision \
{expr 1e45} \
9.9999999999999993e+44
test util-16.1.17.46 {8.4 compatible formatting of doubles} precision \
{expr 1e46} \
9.9999999999999999e+45
test util-16.1.17.47 {8.4 compatible formatting of doubles} precision \
{expr 1e47} \
1e+47
test util-16.1.17.48 {8.4 compatible formatting of doubles} precision \
{expr 1e48} \
1e+48
test util-16.1.17.49 {8.4 compatible formatting of doubles} precision \
{expr 1e49} \
9.9999999999999995e+48
test util-16.1.17.50 {8.4 compatible formatting of doubles} precision \
{expr 1e50} \
1.0000000000000001e+50
test util-16.1.17.51 {8.4 compatible formatting of doubles} precision \
{expr 1e51} \
9.9999999999999999e+50
test util-16.1.17.52 {8.4 compatible formatting of doubles} precision \
{expr 1e52} \
9.9999999999999999e+51
test util-16.1.17.53 {8.4 compatible formatting of doubles} precision \
{expr 1e53} \
9.9999999999999999e+52
test util-16.1.17.54 {8.4 compatible formatting of doubles} precision \
{expr 1e54} \
1.0000000000000001e+54
test util-16.1.17.55 {8.4 compatible formatting of doubles} precision \
{expr 1e55} \
1e+55
test util-16.1.17.56 {8.4 compatible formatting of doubles} precision \
{expr 1e56} \
1.0000000000000001e+56
test util-16.1.17.57 {8.4 compatible formatting of doubles} precision \
{expr 1e57} \
1e+57
test util-16.1.17.58 {8.4 compatible formatting of doubles} precision \
{expr 1e58} \
9.9999999999999994e+57
test util-16.1.17.59 {8.4 compatible formatting of doubles} precision \
{expr 1e59} \
9.9999999999999997e+58
test util-16.1.17.60 {8.4 compatible formatting of doubles} precision \
{expr 1e60} \
9.9999999999999995e+59
test util-16.1.17.61 {8.4 compatible formatting of doubles} precision \
{expr 1e61} \
9.9999999999999995e+60
test util-16.1.17.62 {8.4 compatible formatting of doubles} precision \
{expr 1e62} \
1e+62
test util-16.1.17.63 {8.4 compatible formatting of doubles} precision \
{expr 1e63} \
1.0000000000000001e+63
test util-16.1.17.64 {8.4 compatible formatting of doubles} precision \
{expr 1e64} \
1e+64
test util-16.1.17.65 {8.4 compatible formatting of doubles} precision \
{expr 1e65} \
9.9999999999999999e+64
test util-16.1.17.66 {8.4 compatible formatting of doubles} precision \
{expr 1e66} \
9.9999999999999995e+65
test util-16.1.17.67 {8.4 compatible formatting of doubles} precision \
{expr 1e67} \
9.9999999999999998e+66
test util-16.1.17.68 {8.4 compatible formatting of doubles} precision \
{expr 1e68} \
9.9999999999999995e+67
test util-16.1.17.69 {8.4 compatible formatting of doubles} precision \
{expr 1e69} \
1.0000000000000001e+69
test util-16.1.17.70 {8.4 compatible formatting of doubles} precision \
{expr 1e70} \
1.0000000000000001e+70
test util-16.1.17.71 {8.4 compatible formatting of doubles} precision \
{expr 1e71} \
1e+71
test util-16.1.17.72 {8.4 compatible formatting of doubles} precision \
{expr 1e72} \
9.9999999999999994e+71
test util-16.1.17.73 {8.4 compatible formatting of doubles} precision \
{expr 1e73} \
9.9999999999999998e+72
test util-16.1.17.74 {8.4 compatible formatting of doubles} precision \
{expr 1e74} \
9.9999999999999995e+73
test util-16.1.17.75 {8.4 compatible formatting of doubles} precision \
{expr 1e75} \
9.9999999999999993e+74
test util-16.1.17.76 {8.4 compatible formatting of doubles} precision \
{expr 1e76} \
1e+76
test util-16.1.17.77 {8.4 compatible formatting of doubles} precision \
{expr 1e77} \
9.9999999999999998e+76
test util-16.1.17.78 {8.4 compatible formatting of doubles} precision \
{expr 1e78} \
1e+78
test util-16.1.17.79 {8.4 compatible formatting of doubles} precision \
{expr 1e79} \
9.9999999999999997e+78
test util-16.1.17.80 {8.4 compatible formatting of doubles} precision \
{expr 1e80} \
1e+80
test util-16.1.17.81 {8.4 compatible formatting of doubles} precision \
{expr 1e81} \
9.9999999999999992e+80
test util-16.1.17.82 {8.4 compatible formatting of doubles} precision \
{expr 1e82} \
9.9999999999999996e+81
test util-16.1.17.83 {8.4 compatible formatting of doubles} precision \
{expr 1e83} \
1e+83
test util-16.1.17.84 {8.4 compatible formatting of doubles} precision \
{expr 1e84} \
1.0000000000000001e+84
test util-16.1.17.85 {8.4 compatible formatting of doubles} precision \
{expr 1e85} \
1e+85
test util-16.1.17.86 {8.4 compatible formatting of doubles} precision \
{expr 1e86} \
1e+86
test util-16.1.17.87 {8.4 compatible formatting of doubles} precision \
{expr 1e87} \
9.9999999999999996e+86
test util-16.1.17.88 {8.4 compatible formatting of doubles} precision \
{expr 1e88} \
9.9999999999999996e+87
test util-16.1.17.89 {8.4 compatible formatting of doubles} precision \
{expr 1e89} \
9.9999999999999999e+88
test util-16.1.17.90 {8.4 compatible formatting of doubles} precision \
{expr 1e90} \
9.9999999999999997e+89
test util-16.1.17.91 {8.4 compatible formatting of doubles} precision \
{expr 1e91} \
1.0000000000000001e+91
test util-16.1.17.92 {8.4 compatible formatting of doubles} precision \
{expr 1e92} \
1e+92
test util-16.1.17.93 {8.4 compatible formatting of doubles} precision \
{expr 1e93} \
1e+93
test util-16.1.17.94 {8.4 compatible formatting of doubles} precision \
{expr 1e94} \
1e+94
test util-16.1.17.95 {8.4 compatible formatting of doubles} precision \
{expr 1e95} \
1e+95
test util-16.1.17.96 {8.4 compatible formatting of doubles} precision \
{expr 1e96} \
1e+96
test util-16.1.17.97 {8.4 compatible formatting of doubles} precision \
{expr 1e97} \
1.0000000000000001e+97
test util-16.1.17.98 {8.4 compatible formatting of doubles} precision \
{expr 1e98} \
1e+98
test util-16.1.17.99 {8.4 compatible formatting of doubles} precision \
{expr 1e99} \
9.9999999999999997e+98
test util-16.1.17.100 {8.4 compatible formatting of doubles} precision \
{expr 1e100} \
1e+100
test util-16.1.17.101 {8.4 compatible formatting of doubles} precision \
{expr 1e101} \
9.9999999999999998e+100
test util-16.1.17.102 {8.4 compatible formatting of doubles} precision \
{expr 1e102} \
9.9999999999999998e+101
test util-16.1.17.103 {8.4 compatible formatting of doubles} precision \
{expr 1e103} \
1e+103
test util-16.1.17.104 {8.4 compatible formatting of doubles} precision \
{expr 1e104} \
1e+104
test util-16.1.17.105 {8.4 compatible formatting of doubles} precision \
{expr 1e105} \
9.9999999999999994e+104
test util-16.1.17.106 {8.4 compatible formatting of doubles} precision \
{expr 1e106} \
1.0000000000000001e+106
test util-16.1.17.107 {8.4 compatible formatting of doubles} precision \
{expr 1e107} \
9.9999999999999997e+106
test util-16.1.17.108 {8.4 compatible formatting of doubles} precision \
{expr 1e108} \
1e+108
test util-16.1.17.109 {8.4 compatible formatting of doubles} precision \
{expr 1e109} \
9.9999999999999998e+108
test util-16.1.17.110 {8.4 compatible formatting of doubles} precision \
{expr 1e110} \
1e+110
test util-16.1.17.111 {8.4 compatible formatting of doubles} precision \
{expr 1e111} \
9.9999999999999996e+110
test util-16.1.17.112 {8.4 compatible formatting of doubles} precision \
{expr 1e112} \
9.9999999999999993e+111
test util-16.1.17.113 {8.4 compatible formatting of doubles} precision \
{expr 1e113} \
1e+113
test util-16.1.17.114 {8.4 compatible formatting of doubles} precision \
{expr 1e114} \
1e+114
test util-16.1.17.115 {8.4 compatible formatting of doubles} precision \
{expr 1e115} \
1e+115
test util-16.1.17.116 {8.4 compatible formatting of doubles} precision \
{expr 1e116} \
1e+116
test util-16.1.17.117 {8.4 compatible formatting of doubles} precision \
{expr 1e117} \
1.0000000000000001e+117
test util-16.1.17.118 {8.4 compatible formatting of doubles} precision \
{expr 1e118} \
9.9999999999999997e+117
test util-16.1.17.119 {8.4 compatible formatting of doubles} precision \
{expr 1e119} \
9.9999999999999994e+118
test util-16.1.17.120 {8.4 compatible formatting of doubles} precision \
{expr 1e120} \
9.9999999999999998e+119
test util-16.1.17.121 {8.4 compatible formatting of doubles} precision \
{expr 1e121} \
1e+121
test util-16.1.17.122 {8.4 compatible formatting of doubles} precision \
{expr 1e122} \
1e+122
test util-16.1.17.123 {8.4 compatible formatting of doubles} precision \
{expr 1e123} \
9.9999999999999998e+122
test util-16.1.17.124 {8.4 compatible formatting of doubles} precision \
{expr 1e124} \
9.9999999999999995e+123
test util-16.1.17.125 {8.4 compatible formatting of doubles} precision \
{expr 1e125} \
9.9999999999999992e+124
test util-16.1.17.126 {8.4 compatible formatting of doubles} precision \
{expr 1e126} \
9.9999999999999992e+125
test util-16.1.17.127 {8.4 compatible formatting of doubles} precision \
{expr 1e127} \
9.9999999999999995e+126
test util-16.1.17.128 {8.4 compatible formatting of doubles} precision \
{expr 1e128} \
1.0000000000000001e+128
test util-16.1.17.129 {8.4 compatible formatting of doubles} precision \
{expr 1e129} \
1e+129
test util-16.1.17.130 {8.4 compatible formatting of doubles} precision \
{expr 1e130} \
1.0000000000000001e+130
test util-16.1.17.131 {8.4 compatible formatting of doubles} precision \
{expr 1e131} \
9.9999999999999991e+130
test util-16.1.17.132 {8.4 compatible formatting of doubles} precision \
{expr 1e132} \
9.9999999999999999e+131
test util-16.1.17.133 {8.4 compatible formatting of doubles} precision \
{expr 1e133} \
1e+133
test util-16.1.17.134 {8.4 compatible formatting of doubles} precision \
{expr 1e134} \
9.9999999999999992e+133
test util-16.1.17.135 {8.4 compatible formatting of doubles} precision \
{expr 1e135} \
9.9999999999999996e+134
test util-16.1.17.136 {8.4 compatible formatting of doubles} precision \
{expr 1e136} \
1.0000000000000001e+136
test util-16.1.17.137 {8.4 compatible formatting of doubles} precision \
{expr 1e137} \
1e+137
test util-16.1.17.138 {8.4 compatible formatting of doubles} precision \
{expr 1e138} \
1e+138
test util-16.1.17.139 {8.4 compatible formatting of doubles} precision \
{expr 1e139} \
1e+139
test util-16.1.17.140 {8.4 compatible formatting of doubles} precision \
{expr 1e140} \
1.0000000000000001e+140
test util-16.1.17.141 {8.4 compatible formatting of doubles} precision \
{expr 1e141} \
1e+141
test util-16.1.17.142 {8.4 compatible formatting of doubles} precision \
{expr 1e142} \
1.0000000000000001e+142
test util-16.1.17.143 {8.4 compatible formatting of doubles} precision \
{expr 1e143} \
1e+143
test util-16.1.17.144 {8.4 compatible formatting of doubles} precision \
{expr 1e144} \
1e+144
test util-16.1.17.145 {8.4 compatible formatting of doubles} precision \
{expr 1e145} \
9.9999999999999999e+144
test util-16.1.17.146 {8.4 compatible formatting of doubles} precision \
{expr 1e146} \
9.9999999999999993e+145
test util-16.1.17.147 {8.4 compatible formatting of doubles} precision \
{expr 1e147} \
9.9999999999999998e+146
test util-16.1.17.148 {8.4 compatible formatting of doubles} precision \
{expr 1e148} \
1e+148
test util-16.1.17.149 {8.4 compatible formatting of doubles} precision \
{expr 1e149} \
1e+149
test util-16.1.17.150 {8.4 compatible formatting of doubles} precision \
{expr 1e150} \
9.9999999999999998e+149
test util-16.1.17.151 {8.4 compatible formatting of doubles} precision \
{expr 1e151} \
1e+151
test util-16.1.17.152 {8.4 compatible formatting of doubles} precision \
{expr 1e152} \
1e+152
test util-16.1.17.153 {8.4 compatible formatting of doubles} precision \
{expr 1e153} \
1e+153
test util-16.1.17.154 {8.4 compatible formatting of doubles} precision \
{expr 1e154} \
1e+154
test util-16.1.17.155 {8.4 compatible formatting of doubles} precision \
{expr 1e155} \
1e+155
test util-16.1.17.156 {8.4 compatible formatting of doubles} precision \
{expr 1e156} \
9.9999999999999998e+155
test util-16.1.17.157 {8.4 compatible formatting of doubles} precision \
{expr 1e157} \
9.9999999999999998e+156
test util-16.1.17.158 {8.4 compatible formatting of doubles} precision \
{expr 1e158} \
9.9999999999999995e+157
test util-16.1.17.159 {8.4 compatible formatting of doubles} precision \
{expr 1e159} \
9.9999999999999993e+158
test util-16.1.17.160 {8.4 compatible formatting of doubles} precision \
{expr 1e160} \
1e+160
test util-16.1.17.161 {8.4 compatible formatting of doubles} precision \
{expr 1e161} \
1e+161
test util-16.1.17.162 {8.4 compatible formatting of doubles} precision \
{expr 1e162} \
9.9999999999999994e+161
test util-16.1.17.163 {8.4 compatible formatting of doubles} precision \
{expr 1e163} \
9.9999999999999994e+162
test util-16.1.17.164 {8.4 compatible formatting of doubles} precision \
{expr 1e164} \
1e+164
test util-16.1.17.165 {8.4 compatible formatting of doubles} precision \
{expr 1e165} \
9.999999999999999e+164
test util-16.1.17.166 {8.4 compatible formatting of doubles} precision \
{expr 1e166} \
9.9999999999999994e+165
test util-16.1.17.167 {8.4 compatible formatting of doubles} precision \
{expr 1e167} \
1e+167
test util-16.1.17.168 {8.4 compatible formatting of doubles} precision \
{expr 1e168} \
9.9999999999999993e+167
test util-16.1.17.169 {8.4 compatible formatting of doubles} precision \
{expr 1e169} \
9.9999999999999993e+168
test util-16.1.17.170 {8.4 compatible formatting of doubles} precision \
{expr 1e170} \
1e+170
test util-16.1.17.171 {8.4 compatible formatting of doubles} precision \
{expr 1e171} \
9.9999999999999995e+170
test util-16.1.17.172 {8.4 compatible formatting of doubles} precision \
{expr 1e172} \
1.0000000000000001e+172
test util-16.1.17.173 {8.4 compatible formatting of doubles} precision \
{expr 1e173} \
1e+173
test util-16.1.17.174 {8.4 compatible formatting of doubles} precision \
{expr 1e174} \
1.0000000000000001e+174
test util-16.1.17.175 {8.4 compatible formatting of doubles} precision \
{expr 1e175} \
9.9999999999999994e+174
test util-16.1.17.176 {8.4 compatible formatting of doubles} precision \
{expr 1e176} \
1e+176
test util-16.1.17.177 {8.4 compatible formatting of doubles} precision \
{expr 1e177} \
1e+177
test util-16.1.17.178 {8.4 compatible formatting of doubles} precision \
{expr 1e178} \
1.0000000000000001e+178
test util-16.1.17.179 {8.4 compatible formatting of doubles} precision \
{expr 1e179} \
9.9999999999999998e+178
test util-16.1.17.180 {8.4 compatible formatting of doubles} precision \
{expr 1e180} \
1e+180
test util-16.1.17.181 {8.4 compatible formatting of doubles} precision \
{expr 1e181} \
9.9999999999999992e+180
test util-16.1.17.182 {8.4 compatible formatting of doubles} precision \
{expr 1e182} \
1.0000000000000001e+182
test util-16.1.17.183 {8.4 compatible formatting of doubles} precision \
{expr 1e183} \
9.9999999999999995e+182
test util-16.1.17.184 {8.4 compatible formatting of doubles} precision \
{expr 1e184} \
1e+184
test util-16.1.17.185 {8.4 compatible formatting of doubles} precision \
{expr 1e185} \
9.9999999999999998e+184
test util-16.1.17.186 {8.4 compatible formatting of doubles} precision \
{expr 1e186} \
9.9999999999999998e+185
test util-16.1.17.187 {8.4 compatible formatting of doubles} precision \
{expr 1e187} \
9.9999999999999991e+186
test util-16.1.17.188 {8.4 compatible formatting of doubles} precision \
{expr 1e188} \
1e+188
test util-16.1.17.189 {8.4 compatible formatting of doubles} precision \
{expr 1e189} \
1e+189
test util-16.1.17.190 {8.4 compatible formatting of doubles} precision \
{expr 1e190} \
1.0000000000000001e+190
test util-16.1.17.191 {8.4 compatible formatting of doubles} precision \
{expr 1e191} \
1.0000000000000001e+191
test util-16.1.17.192 {8.4 compatible formatting of doubles} precision \
{expr 1e192} \
1e+192
test util-16.1.17.193 {8.4 compatible formatting of doubles} precision \
{expr 1e193} \
1.0000000000000001e+193
test util-16.1.17.194 {8.4 compatible formatting of doubles} precision \
{expr 1e194} \
9.9999999999999994e+193
test util-16.1.17.195 {8.4 compatible formatting of doubles} precision \
{expr 1e195} \
9.9999999999999998e+194
test util-16.1.17.196 {8.4 compatible formatting of doubles} precision \
{expr 1e196} \
9.9999999999999995e+195
test util-16.1.17.197 {8.4 compatible formatting of doubles} precision \
{expr 1e197} \
9.9999999999999995e+196
test util-16.1.17.198 {8.4 compatible formatting of doubles} precision \
{expr 1e198} \
1e+198
test util-16.1.17.199 {8.4 compatible formatting of doubles} precision \
{expr 1e199} \
1.0000000000000001e+199
test util-16.1.17.200 {8.4 compatible formatting of doubles} precision \
{expr 1e200} \
9.9999999999999997e+199
test util-16.1.17.201 {8.4 compatible formatting of doubles} precision \
{expr 1e201} \
1e+201
test util-16.1.17.202 {8.4 compatible formatting of doubles} precision \
{expr 1e202} \
9.999999999999999e+201
test util-16.1.17.203 {8.4 compatible formatting of doubles} precision \
{expr 1e203} \
9.9999999999999999e+202
test util-16.1.17.204 {8.4 compatible formatting of doubles} precision \
{expr 1e204} \
9.9999999999999999e+203
test util-16.1.17.205 {8.4 compatible formatting of doubles} precision \
{expr 1e205} \
1e+205
test util-16.1.17.206 {8.4 compatible formatting of doubles} precision \
{expr 1e206} \
1e+206
test util-16.1.17.207 {8.4 compatible formatting of doubles} precision \
{expr 1e207} \
1e+207
test util-16.1.17.208 {8.4 compatible formatting of doubles} precision \
{expr 1e208} \
9.9999999999999998e+207
test util-16.1.17.209 {8.4 compatible formatting of doubles} precision \
{expr 1e209} \
1.0000000000000001e+209
test util-16.1.17.210 {8.4 compatible formatting of doubles} precision \
{expr 1e210} \
9.9999999999999993e+209
test util-16.1.17.211 {8.4 compatible formatting of doubles} precision \
{expr 1e211} \
9.9999999999999996e+210
test util-16.1.17.212 {8.4 compatible formatting of doubles} precision \
{expr 1e212} \
9.9999999999999991e+211
test util-16.1.17.213 {8.4 compatible formatting of doubles} precision \
{expr 1e213} \
9.9999999999999998e+212
test util-16.1.17.214 {8.4 compatible formatting of doubles} precision \
{expr 1e214} \
9.9999999999999995e+213
test util-16.1.17.215 {8.4 compatible formatting of doubles} precision \
{expr 1e215} \
9.9999999999999991e+214
test util-16.1.17.216 {8.4 compatible formatting of doubles} precision \
{expr 1e216} \
1e+216
test util-16.1.17.217 {8.4 compatible formatting of doubles} precision \
{expr 1e217} \
9.9999999999999996e+216
test util-16.1.17.218 {8.4 compatible formatting of doubles} precision \
{expr 1e218} \
1.0000000000000001e+218
test util-16.1.17.219 {8.4 compatible formatting of doubles} precision \
{expr 1e219} \
9.9999999999999997e+218
test util-16.1.17.220 {8.4 compatible formatting of doubles} precision \
{expr 1e220} \
1e+220
test util-16.1.17.221 {8.4 compatible formatting of doubles} precision \
{expr 1e221} \
1e+221
test util-16.1.17.222 {8.4 compatible formatting of doubles} precision \
{expr 1e222} \
1e+222
test util-16.1.17.223 {8.4 compatible formatting of doubles} precision \
{expr 1e223} \
1e+223
test util-16.1.17.224 {8.4 compatible formatting of doubles} precision \
{expr 1e224} \
9.9999999999999997e+223
test util-16.1.17.225 {8.4 compatible formatting of doubles} precision \
{expr 1e225} \
9.9999999999999993e+224
test util-16.1.17.226 {8.4 compatible formatting of doubles} precision \
{expr 1e226} \
9.9999999999999996e+225
test util-16.1.17.227 {8.4 compatible formatting of doubles} precision \
{expr 1e227} \
1.0000000000000001e+227
test util-16.1.17.228 {8.4 compatible formatting of doubles} precision \
{expr 1e228} \
9.9999999999999992e+227
test util-16.1.17.229 {8.4 compatible formatting of doubles} precision \
{expr 1e229} \
9.9999999999999999e+228
test util-16.1.17.230 {8.4 compatible formatting of doubles} precision \
{expr 1e230} \
1.0000000000000001e+230
test util-16.1.17.231 {8.4 compatible formatting of doubles} precision \
{expr 1e231} \
1.0000000000000001e+231
test util-16.1.17.232 {8.4 compatible formatting of doubles} precision \
{expr 1e232} \
1.0000000000000001e+232
test util-16.1.17.233 {8.4 compatible formatting of doubles} precision \
{expr 1e233} \
9.9999999999999997e+232
test util-16.1.17.234 {8.4 compatible formatting of doubles} precision \
{expr 1e234} \
1e+234
test util-16.1.17.235 {8.4 compatible formatting of doubles} precision \
{expr 1e235} \
1.0000000000000001e+235
test util-16.1.17.236 {8.4 compatible formatting of doubles} precision \
{expr 1e236} \
1.0000000000000001e+236
test util-16.1.17.237 {8.4 compatible formatting of doubles} precision \
{expr 1e237} \
9.9999999999999994e+236
test util-16.1.17.238 {8.4 compatible formatting of doubles} precision \
{expr 1e238} \
1e+238
test util-16.1.17.239 {8.4 compatible formatting of doubles} precision \
{expr 1e239} \
9.9999999999999999e+238
test util-16.1.17.240 {8.4 compatible formatting of doubles} precision \
{expr 1e240} \
1e+240
test util-16.1.17.241 {8.4 compatible formatting of doubles} precision \
{expr 1e241} \
1.0000000000000001e+241
test util-16.1.17.242 {8.4 compatible formatting of doubles} precision \
{expr 1e242} \
1.0000000000000001e+242
test util-16.1.17.243 {8.4 compatible formatting of doubles} precision \
{expr 1e243} \
1.0000000000000001e+243
test util-16.1.17.244 {8.4 compatible formatting of doubles} precision \
{expr 1e244} \
1.0000000000000001e+244
test util-16.1.17.245 {8.4 compatible formatting of doubles} precision \
{expr 1e245} \
1e+245
test util-16.1.17.246 {8.4 compatible formatting of doubles} precision \
{expr 1e246} \
1.0000000000000001e+246
test util-16.1.17.247 {8.4 compatible formatting of doubles} precision \
{expr 1e247} \
9.9999999999999995e+246
test util-16.1.17.248 {8.4 compatible formatting of doubles} precision \
{expr 1e248} \
1e+248
test util-16.1.17.249 {8.4 compatible formatting of doubles} precision \
{expr 1e249} \
9.9999999999999992e+248
test util-16.1.17.250 {8.4 compatible formatting of doubles} precision \
{expr 1e250} \
9.9999999999999992e+249
test util-16.1.17.251 {8.4 compatible formatting of doubles} precision \
{expr 1e251} \
1e+251
test util-16.1.17.252 {8.4 compatible formatting of doubles} precision \
{expr 1e252} \
1.0000000000000001e+252
test util-16.1.17.253 {8.4 compatible formatting of doubles} precision \
{expr 1e253} \
9.9999999999999994e+252
test util-16.1.17.254 {8.4 compatible formatting of doubles} precision \
{expr 1e254} \
9.9999999999999994e+253
test util-16.1.17.255 {8.4 compatible formatting of doubles} precision \
{expr 1e255} \
9.9999999999999999e+254
test util-16.1.17.256 {8.4 compatible formatting of doubles} precision \
{expr 1e256} \
1e+256
test util-16.1.17.257 {8.4 compatible formatting of doubles} precision \
{expr 1e257} \
1e+257
test util-16.1.17.258 {8.4 compatible formatting of doubles} precision \
{expr 1e258} \
1.0000000000000001e+258
test util-16.1.17.259 {8.4 compatible formatting of doubles} precision \
{expr 1e259} \
9.9999999999999993e+258
test util-16.1.17.260 {8.4 compatible formatting of doubles} precision \
{expr 1e260} \
1.0000000000000001e+260
test util-16.1.17.261 {8.4 compatible formatting of doubles} precision \
{expr 1e261} \
9.9999999999999993e+260
test util-16.1.17.262 {8.4 compatible formatting of doubles} precision \
{expr 1e262} \
1e+262
test util-16.1.17.263 {8.4 compatible formatting of doubles} precision \
{expr 1e263} \
1e+263
test util-16.1.17.264 {8.4 compatible formatting of doubles} precision \
{expr 1e264} \
1e+264
test util-16.1.17.265 {8.4 compatible formatting of doubles} precision \
{expr 1e265} \
1.0000000000000001e+265
test util-16.1.17.266 {8.4 compatible formatting of doubles} precision \
{expr 1e266} \
1e+266
test util-16.1.17.267 {8.4 compatible formatting of doubles} precision \
{expr 1e267} \
9.9999999999999997e+266
test util-16.1.17.268 {8.4 compatible formatting of doubles} precision \
{expr 1e268} \
9.9999999999999997e+267
test util-16.1.17.269 {8.4 compatible formatting of doubles} precision \
{expr 1e269} \
1e+269
test util-16.1.17.270 {8.4 compatible formatting of doubles} precision \
{expr 1e270} \
1e+270
test util-16.1.17.271 {8.4 compatible formatting of doubles} precision \
{expr 1e271} \
9.9999999999999995e+270
test util-16.1.17.272 {8.4 compatible formatting of doubles} precision \
{expr 1e272} \
1.0000000000000001e+272
test util-16.1.17.273 {8.4 compatible formatting of doubles} precision \
{expr 1e273} \
9.9999999999999995e+272
test util-16.1.17.274 {8.4 compatible formatting of doubles} precision \
{expr 1e274} \
9.9999999999999992e+273
test util-16.1.17.275 {8.4 compatible formatting of doubles} precision \
{expr 1e275} \
9.9999999999999996e+274
test util-16.1.17.276 {8.4 compatible formatting of doubles} precision \
{expr 1e276} \
1.0000000000000001e+276
test util-16.1.17.277 {8.4 compatible formatting of doubles} precision \
{expr 1e277} \
1e+277
test util-16.1.17.278 {8.4 compatible formatting of doubles} precision \
{expr 1e278} \
9.9999999999999996e+277
test util-16.1.17.279 {8.4 compatible formatting of doubles} precision \
{expr 1e279} \
1.0000000000000001e+279
test util-16.1.17.280 {8.4 compatible formatting of doubles} precision \
{expr 1e280} \
1e+280
test util-16.1.17.281 {8.4 compatible formatting of doubles} precision \
{expr 1e281} \
1e+281
test util-16.1.17.282 {8.4 compatible formatting of doubles} precision \
{expr 1e282} \
1e+282
test util-16.1.17.283 {8.4 compatible formatting of doubles} precision \
{expr 1e283} \
9.9999999999999996e+282
test util-16.1.17.284 {8.4 compatible formatting of doubles} precision \
{expr 1e284} \
1.0000000000000001e+284
test util-16.1.17.285 {8.4 compatible formatting of doubles} precision \
{expr 1e285} \
9.9999999999999998e+284
test util-16.1.17.286 {8.4 compatible formatting of doubles} precision \
{expr 1e286} \
1e+286
test util-16.1.17.287 {8.4 compatible formatting of doubles} precision \
{expr 1e287} \
1.0000000000000001e+287
test util-16.1.17.288 {8.4 compatible formatting of doubles} precision \
{expr 1e288} \
1e+288
test util-16.1.17.289 {8.4 compatible formatting of doubles} precision \
{expr 1e289} \
1.0000000000000001e+289
test util-16.1.17.290 {8.4 compatible formatting of doubles} precision \
{expr 1e290} \
1.0000000000000001e+290
test util-16.1.17.291 {8.4 compatible formatting of doubles} precision \
{expr 1e291} \
9.9999999999999996e+290
test util-16.1.17.292 {8.4 compatible formatting of doubles} precision \
{expr 1e292} \
1e+292
test util-16.1.17.293 {8.4 compatible formatting of doubles} precision \
{expr 1e293} \
9.9999999999999992e+292
test util-16.1.17.294 {8.4 compatible formatting of doubles} precision \
{expr 1e294} \
1.0000000000000001e+294
test util-16.1.17.295 {8.4 compatible formatting of doubles} precision \
{expr 1e295} \
9.9999999999999998e+294
test util-16.1.17.296 {8.4 compatible formatting of doubles} precision \
{expr 1e296} \
9.9999999999999998e+295
test util-16.1.17.297 {8.4 compatible formatting of doubles} precision \
{expr 1e297} \
1e+297
test util-16.1.17.298 {8.4 compatible formatting of doubles} precision \
{expr 1e298} \
9.9999999999999996e+297
test util-16.1.17.299 {8.4 compatible formatting of doubles} precision \
{expr 1e299} \
1.0000000000000001e+299
test util-16.1.17.300 {8.4 compatible formatting of doubles} precision \
{expr 1e300} \
1.0000000000000001e+300
test util-16.1.17.301 {8.4 compatible formatting of doubles} precision \
{expr 1e301} \
1.0000000000000001e+301
test util-16.1.17.302 {8.4 compatible formatting of doubles} precision \
{expr 1e302} \
1.0000000000000001e+302
test util-16.1.17.303 {8.4 compatible formatting of doubles} precision \
{expr 1e303} \
1e+303
test util-16.1.17.304 {8.4 compatible formatting of doubles} precision \
{expr 1e304} \
9.9999999999999994e+303
test util-16.1.17.305 {8.4 compatible formatting of doubles} precision \
{expr 1e305} \
9.9999999999999994e+304
test util-16.1.17.306 {8.4 compatible formatting of doubles} precision \
{expr 1e306} \
1e+306
test util-16.1.17.307 {8.4 compatible formatting of doubles} precision \
{expr 1e307} \
9.9999999999999999e+306
test util-17.1 {bankers' rounding [Bug 3349507]} {ieeeFloatingPoint} {
set r {}
foreach {input} {
0x1ffffffffffffc000
0x1ffffffffffffc800
0x1ffffffffffffd000
|
| ︙ | ︙ | |||
2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 |
test util-18.11 {Tcl_ObjPrintf} {testprint} {
testprint "%I64d %td" 65536
} {65536 65536}
test util-18.12 {Tcl_ObjPrintf} {testprint} {
testprint "%I64d %Id" 65537
} {65537 65537}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
| > > > > | 4167 4168 4169 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 4185 |
test util-18.11 {Tcl_ObjPrintf} {testprint} {
testprint "%I64d %td" 65536
} {65536 65536}
test util-18.12 {Tcl_ObjPrintf} {testprint} {
testprint "%I64d %Id" 65537
} {65537 65537}
if {[catch {set ::tcl_precision $saved_precision}]} {
unset ::tcl_precision
}
# cleanup
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
Changes to tests/var.test.
| ︙ | ︙ | |||
265 266 267 268 269 270 271 |
catch {unset a}
} -constraints testupvar -body {
set a 456
namespace eval test_ns_var {
catch {unset ::test_ns_var::vv}
proc p {} {
# create namespace var vv linked to global a
| | < | 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 |
catch {unset a}
} -constraints testupvar -body {
set a 456
namespace eval test_ns_var {
catch {unset ::test_ns_var::vv}
proc p {} {
# create namespace var vv linked to global a
testupvar 1 a {} vv namespace
}
p
}
list $test_ns_var::vv [set test_ns_var::vv 123] $a
} -result {456 123 123}
test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} -setup {
catch {unset aaaaa}
catch {unset xxxxx}
} -body {
set aaaaa 77777
|
| ︙ | ︙ | |||
461 462 463 464 465 466 467 |
catch {unset six}
} -body {
set a ""
set five 555
set six 666
namespace eval test_ns_var {
variable five 5 six
| | | 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 |
catch {unset six}
} -body {
set a ""
set five 555
set six 666
namespace eval test_ns_var {
variable five 5 six
lappend a $five
}
lappend a $test_ns_var::five \
[set test_ns_var::six 6] [set test_ns_var::six] $six
} -cleanup {
catch {unset five}
catch {unset six}
} -result {5 5 6 6 666}
|
| ︙ | ︙ | |||
488 489 490 491 492 493 494 |
variable sev:::en 7
}
} -result {can't define "sev:::en": parent namespace doesn't exist}
test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, leave value unchanged} {
set a ""
namespace eval test_ns_var {
variable eight 8
| | | | 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 |
variable sev:::en 7
}
} -result {can't define "sev:::en": parent namespace doesn't exist}
test var-7.8 {Tcl_VariableObjCmd, if var already exists and no value is given, leave value unchanged} {
set a ""
namespace eval test_ns_var {
variable eight 8
lappend a $eight
variable eight
lappend a $eight
}
set a
} {8 8}
test var-7.9 {Tcl_VariableObjCmd, mark as namespace var so var persists until namespace is destroyed or var is unset} -setup {
catch {namespace delete test_ns_var2}
} -body {
set a ""
|
| ︙ | ︙ |
Changes to tests/while-old.test.
| ︙ | ︙ | |||
88 89 90 91 92 93 94 |
test while-old-4.3 {errors in while loops} {
set err [catch {while 1 2 3} msg]
list $err $msg
} {1 {wrong # args: should be "while test command"}}
test while-old-4.4 {errors in while loops} {
set err [catch {while {"a"+"b"} {error "loop aborted"}} msg]
list $err $msg
| | | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 |
test while-old-4.3 {errors in while loops} {
set err [catch {while 1 2 3} msg]
list $err $msg
} {1 {wrong # args: should be "while test command"}}
test while-old-4.4 {errors in while loops} {
set err [catch {while {"a"+"b"} {error "loop aborted"}} msg]
list $err $msg
} {1 {can't use non-numeric string as operand of "+"}}
test while-old-4.5 {errors in while loops} {
catch {unset x}
set x 1
set err [catch {while {$x} {set x foo}} msg]
list $err $msg
} {1 {expected boolean value but got "foo"}}
test while-old-4.6 {errors in while loops} {
|
| ︙ | ︙ |
Changes to tests/while.test.
| ︙ | ︙ | |||
28 29 30 31 32 33 34 |
catch {while {$i<} break}
return $::errorInfo
} -cleanup {
unset i
} -match glob -result {*"while {$i<} break"}
test while-1.3 {TclCompileWhileCmd: error in test expression} -body {
while {"a"+"b"} {error "loop aborted"}
| | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 |
catch {while {$i<} break}
return $::errorInfo
} -cleanup {
unset i
} -match glob -result {*"while {$i<} break"}
test while-1.3 {TclCompileWhileCmd: error in test expression} -body {
while {"a"+"b"} {error "loop aborted"}
} -returnCodes error -result {can't use non-numeric string as operand of "+"}
test while-1.4 {TclCompileWhileCmd: multiline test expr} -body {
set value 1
while {($tcl_platform(platform) != "foobar1") && \
($tcl_platform(platform) != "foobar2")} {
incr value
break
}
|
| ︙ | ︙ | |||
339 340 341 342 343 344 345 |
return $::errorInfo
} -match glob -cleanup {
unset i z
} -result {*"$z {$i<} {set x 1}"}
test while-4.4 {while (not compiled): error in test expression} -body {
set z while
$z {"a"+"b"} {error "loop aborted"}
| | | 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 |
return $::errorInfo
} -match glob -cleanup {
unset i z
} -result {*"$z {$i<} {set x 1}"}
test while-4.4 {while (not compiled): error in test expression} -body {
set z while
$z {"a"+"b"} {error "loop aborted"}
} -returnCodes error -result {can't use non-numeric string as operand of "+"}
test while-4.5 {while (not compiled): multiline test expr} -body {
set value 1
set z while
$z {($tcl_platform(platform) != "foobar1") && \
($tcl_platform(platform) != "foobar2")} {
incr value
break
|
| ︙ | ︙ |
Changes to tests/winDde.test.
| ︙ | ︙ | |||
16 17 18 19 20 21 22 |
}
testConstraint debug [::tcl::pkgconfig get debug]
testConstraint dde 0
if {[testConstraint win]} {
if {![catch {
::tcltest::loadTestedCommands
| | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 |
}
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 [lindex [package ifneeded dde $::ddever] 1]}]} {
testConstraint dde 1
}
}
# -------------------------------------------------------------------------
|
| ︙ | ︙ | |||
100 101 102 103 104 105 106 |
gets $f line
return $f
}
# -------------------------------------------------------------------------
test winDde-1.0 {check if we are testing the right dll} {win dde} {
set ::ddever
| | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 |
gets $f line
return $f
}
# -------------------------------------------------------------------------
test winDde-1.0 {check if we are testing the right dll} {win dde} {
set ::ddever
} {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
|
| ︙ | ︙ |
Changes to tests/winFCmd.test.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 31 32 33 34 35 36 37 |
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
proc createfile {file {string a}} {
set f [open $file w]
puts -nonewline $f $string
close $f
return $string
}
| > | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 |
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
testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
proc createfile {file {string a}} {
set f [open $file w]
puts -nonewline $f $string
close $f
return $string
}
|
| ︙ | ︙ | |||
88 89 90 91 92 93 94 |
}
}
}
# NB: filename is chosen to be short but unlikely to clash with other apps
if {[file exists c:/] && [file exists d:/]} {
catch {file delete d:/TclTmpF.1}
| > > | > > > | | 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 |
}
}
}
# NB: filename is chosen to be short but unlikely to clash with other apps
if {[file exists c:/] && [file exists d:/]} {
catch {file delete d:/TclTmpF.1}
catch {file delete d:/TclTmpD.1}
catch {file delete c:/TclTmpC.1}
if {![catch {createfile d:/TclTmpF.1 {}}] && [file isfile d:/TclTmpF.1]
&& ![catch {file mkdir d:/TclTmpD.1}] && [file isdirectory d:/TclTmpD.1]
&& ![catch {file mkdir c:/TclTmpC.1}] && [file isdirectory c:/TclTmpC.1]
} {
file delete d:/TclTmpF.1 d:/TclTmpD.1 c:/TclTmpC.1
testConstraint exdev 1
}
}
file delete -force -- td1
if {![catch {open td1 w} testfile]} {
close $testfile
|
| ︙ | ︙ | |||
169 170 171 172 173 174 175 |
cleanup
} -constraints {win testfile} -body {
file mkdir td1
createfile tf1
testfile mv td1 tf1
} -returnCodes error -result ENOTDIR
test winFCmd-1.10 {TclpRenameFile: errno: EXDEV} -setup {
| | | | | | 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 |
cleanup
} -constraints {win testfile} -body {
file mkdir td1
createfile tf1
testfile mv td1 tf1
} -returnCodes error -result ENOTDIR
test winFCmd-1.10 {TclpRenameFile: errno: EXDEV} -setup {
file delete -force d:/TclTmpD.1
} -constraints {win exdev testfile} -body {
file mkdir c:/TclTmpC.1
testfile mv c:/TclTmpC.1 d:/TclTmpD.1
} -cleanup {
file delete -force c:/TclTmpC.1
} -returnCodes error -result EXDEV
test winFCmd-1.11 {TclpRenameFile: errno: EACCES} -setup {
cleanup
} -constraints {win testfile} -body {
set fd [open tf1 w]
testfile mv tf1 tf2
} -cleanup {
|
| ︙ | ︙ | |||
312 313 314 315 316 317 318 |
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 {
| | | | | | | | | | 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 |
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 {
file mkdir d:/TclTmpD.1
testchmod 0 d:/TclTmpD.1
file mkdir c:/TclTmpC.1
catch {testfile mv c:/TclTmpC.1 d:/TclTmpD.1} msg
list $msg [file writable d:/TclTmpD.1]
} -cleanup {
catch {testchmod 0o666 d:/TclTmpD.1}
file delete d:/TclTmpD.1
file delete -force c:/TclTmpC.1
} -result {EXDEV 0}
test winFCmd-1.34 {TclpRenameFile: src is dir, dst is not} -setup {
cleanup
} -constraints {win testfile} -body {
file mkdir td1
createfile tf1
testfile mv td1 tf1
|
| ︙ | ︙ | |||
384 385 386 387 388 389 390 |
lappend inodes $stat(ino)
unset stat
}
}
test winFCmd-1.38 {TclpRenameFile: check rename of conflicting inodes} -setup {
cleanup
| | | 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 |
lappend inodes $stat(ino)
unset stat
}
}
test winFCmd-1.38 {TclpRenameFile: check rename of conflicting inodes} -setup {
cleanup
} -constraints {win winNonZeroInodes knownMsvcBug} -body {
file mkdir td1
foreach {a b} [MakeFiles td1] break
file rename -force $a $b
file exists $a
} -cleanup {
cleanup
} -result {0}
|
| ︙ | ︙ | |||
629 630 631 632 633 634 635 |
list [file type td1] [file type td2]
} -cleanup {
cleanup
} -result {directory directory}
test winFCmd-6.1 {TclpRemoveDirectory: errno: EACCES} -setup {
cleanup
| | | 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 |
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} -body {
file mkdir td1
testchmod 0 td1
testfile rmdir td1
file exists td1
} -returnCodes error -cleanup {
catch {testchmod 0o666 td1}
cleanup
|
| ︙ | ︙ | |||
683 684 685 686 687 688 689 |
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
| | | | 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 |
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} -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} -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} -body {
file mkdir td1
testchmod 0 td1
testfile rmdir td1
file exists td1
} -cleanup {
catch {testchmod 0o666 td1}
cleanup
|
| ︙ | ︙ | |||
930 931 932 933 934 935 936 |
} -constraints {win testfile} -body {
file mkdir td1
createfile td1/tf1
testfile rmdir -force td1
} -result {}
test winFCmd-9.3 {TraversalDelete: DOTREE_PRED} -setup {
cleanup
| | | 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 |
} -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} -body {
file mkdir td1/td2
testchmod 0 td1
testfile rmdir -force td1
file exists td1
} -cleanup {
catch {testchmod 0o666 td1}
cleanup
|
| ︙ | ︙ | |||
1044 1045 1046 1047 1048 1049 1050 |
} -cleanup {
cleanup
} -result {./td1}
test winFCmd-12.5 {ConvertFileNameFormat: absolute path} -body {
list [file attributes / -longname] [file attributes \\ -longname]
} -constraints {win} -result {/ /}
test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} -setup {
| | | | | | | 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 |
} -cleanup {
cleanup
} -result {./td1}
test winFCmd-12.5 {ConvertFileNameFormat: absolute path} -body {
list [file attributes / -longname] [file attributes \\ -longname]
} -constraints {win} -result {/ /}
test winFCmd-12.6 {ConvertFileNameFormat: absolute path with drive} -setup {
catch {file delete -force -- c:/TclTmpC.1}
} -constraints {win winXP} -body {
createfile c:/TclTmpC.1 {}
string tolower [file attributes c:/TclTmpC.1 -longname]
} -cleanup {
file delete -force -- c:/TclTmpC.1
} -result [string tolower {c:/TclTmpC.1}]
test winFCmd-12.6.2 {ConvertFileNameFormat: absolute path with drive (in temp folder)} -setup {
catch {file delete -force -- $::env(TEMP)/td1}
} -constraints {win} -body {
createfile $::env(TEMP)/td1 {}
string equal [string tolower [file attributes $::env(TEMP)/td1 -longname]] \
[string tolower [file normalize $::env(TEMP)]/td1]
} -cleanup {
|
| ︙ | ︙ |
Changes to tests/winTime.test.
| ︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 |
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testwinclock [llength [info commands testwinclock]]
# 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]
| > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 |
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testwinclock [llength [info commands testwinclock]]
testConstraint knownMsvcBug [expr {![info exists ::env(TRAVIS_OS_NAME)] || ![string match windows $::env(TRAVIS_OS_NAME)]}]
# 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]
|
| ︙ | ︙ | |||
36 37 38 39 40 41 42 |
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?
| | | | 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 |
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 knownMsvcBug} {
# 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
set diff [expr { $tcl_sec - $sys_sec
+ 1.0e-6 * ( $tcl_usec - $sys_usec ) }]
if { abs($diff) > 0.1 } {
set failed "Tcl clock differs from system clock by $diff sec"
break
} else {
testwinsleep 1
}
if { $sys_sec - $start_sec >= 30 } break
}
set failed
} {}
# cleanup
::tcltest::cleanupTests
return
|
Changes to tests/zipfs.test.
| ︙ | ︙ | |||
41 42 43 44 45 46 47 |
###
# "make test" does not map tcl_library from the dynamic library on Unix
#
# Hack the environment to pretend we did pull tcl_library from a zip
# archive
###
set tclzip [file join $CWD [::tcl::pkgconfig get zipfile,runtime]]
| | | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 |
###
# "make test" does not map tcl_library from the dynamic library on Unix
#
# Hack the environment to pretend we did pull tcl_library from a zip
# archive
###
set tclzip [file join $CWD [::tcl::pkgconfig get zipfile,runtime]]
testConstraint zipfslib [file isfile $tclzip]
if {[testConstraint zipfslib]} {
zipfs mount /lib/tcl $tclzip
set ::tcl_library ${ziproot}lib/tcl/tcl_library
}
}
test zipfs-0.2 {zipfs basics} -constraints zipfslib -body {
|
| ︙ | ︙ |
Changes to tools/README.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 | uniClass.tcl -- Script for generating regexp class tables from the Tcl "string is" classes Generating HTML files. The tcl-tk-man-html.tcl script from Robert Critchlow generates a nice set of HTML with good cross references. Use it like | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
uniClass.tcl -- Script for generating regexp class tables from the Tcl
"string is" classes
Generating HTML files.
The tcl-tk-man-html.tcl script from Robert Critchlow
generates a nice set of HTML with good cross references.
Use it like
tclsh tcl-tk-man-html.tcl --htmldir=/tmp/tcl8.2
This script is very picky about the organization of man pages,
effectively acting as a style enforcer.
Generating Windows Help Files:
1) Build tcl in the ../unix directory
2) On UNIX, (after autoconf and configure), do
make
|
| ︙ | ︙ |
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 | # 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.2/*/*.[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.) |
| ︙ | ︙ | |||
46 47 48 49 50 51 52 53 54 55 56 57 58 59 |
Tcl_SavedResult \
Tcl_ThreadDataKey \
Tcl_ThreadId \
Tcl_Time \
Tcl_TimerToken \
Tcl_Token \
Tcl_Trace \
Tcl_Var \
Tk_3DBorder \
Tk_ArgvInfo \
Tk_BindingTable \
Tk_Canvas \
Tk_CanvasTextInfo \
Tk_ConfigSpec \
| > > | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 |
Tcl_SavedResult \
Tcl_ThreadDataKey \
Tcl_ThreadId \
Tcl_Time \
Tcl_TimerToken \
Tcl_Token \
Tcl_Trace \
Tcl_Value \
Tcl_ValueType \
Tcl_Var \
Tk_3DBorder \
Tk_ArgvInfo \
Tk_BindingTable \
Tk_Canvas \
Tk_CanvasTextInfo \
Tk_ConfigSpec \
|
| ︙ | ︙ | |||
100 101 102 103 104 105 106 |
global argv0
global argv
set len [llength $argv]
if {($len != 2) && ($len != 3)} {
puts "usage: $argv0 pkgName pkgDir \[outFile\]"
puts " pkgName == Tcl,Tk"
| | | 102 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"
puts " pkgDir == /home/surles/cvs/tcl8.2"
exit 1
}
set pkg [lindex $argv 0]
set dir [lindex $argv 1]
if {[llength $argv] == 3} {
set file [open [lindex $argv 2] w]
|
| ︙ | ︙ |
Changes to tools/configure.
| ︙ | ︙ | |||
1677 1678 1679 1680 1681 1682 1683 | # Recover information that Tcl computed with its configure script. #-------------------------------------------------------------------- # See if there was a command-line option for where Tcl is; if # not, assume that its top-level directory is a sibling of ours. #-------------------------------------------------------------------- | | | 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 |
# Recover information that Tcl computed with its configure script.
#--------------------------------------------------------------------
# See if there was a command-line option for where Tcl is; if
# not, assume that its top-level directory is a sibling of ours.
#--------------------------------------------------------------------
DEF_VER=8.7
# Check whether --with-tcl was given.
if test "${with_tcl+set}" = set; then :
withval=$with_tcl; TCL_BIN_DIR=$withval
else
TCL_BIN_DIR=`cd ../../tcl$DEF_VER$TCL_PATCH_LEVEL/unix; pwd`
|
| ︙ | ︙ |
Changes to tools/configure.ac.
1 2 3 4 5 6 7 8 9 10 11 12 13 | dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run to configure the dnl Makefile in this directory. AC_INIT(man2tcl.c) AC_PREREQ(2.69) # Recover information that Tcl computed with its configure script. #-------------------------------------------------------------------- # See if there was a command-line option for where Tcl is; if # not, assume that its top-level directory is a sibling of ours. #-------------------------------------------------------------------- | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 |
dnl This file is an input file used by the GNU "autoconf" program to
dnl generate the file "configure", which is run to configure the
dnl Makefile in this directory.
AC_INIT(man2tcl.c)
AC_PREREQ(2.69)
# Recover information that Tcl computed with its configure script.
#--------------------------------------------------------------------
# See if there was a command-line option for where Tcl is; if
# not, assume that its top-level directory is a sibling of ours.
#--------------------------------------------------------------------
DEF_VER=8.7
AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl $DEF_VER binaries from DIR], TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd ../../tcl$DEF_VER$TCL_PATCH_LEVEL/unix; pwd`)
if test ! -d $TCL_BIN_DIR; then
AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR doesn't exist)
fi
if test ! -f $TCL_BIN_DIR/tclConfig.sh; then
AC_MSG_ERROR(There's no tclConfig.sh in $TCL_BIN_DIR; perhaps you didn't specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?)
|
| ︙ | ︙ |
Changes to tools/encoding/txt2enc.c.
| ︙ | ︙ | |||
172 173 174 175 176 177 178 |
str = rest;
}
if (enc < 32 || uni < 32) {
continue;
}
hi = enc >> 8;
| | | 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 |
str = rest;
}
if (enc < 32 || uni < 32) {
continue;
}
hi = enc >> 8;
lo = enc & 0xFF;
if (toUnicode[hi] == NULL) {
toUnicode[hi] = (Rune *) malloc(256 * sizeof(Rune));
memset(toUnicode[hi], 0, 256 * sizeof(Rune));
}
toUnicode[hi][lo] = uni;
}
|
| ︙ | ︙ | |||
204 205 206 207 208 209 210 |
toUnicode[0] = (Rune *) malloc(256 * sizeof(Rune));
memset(toUnicode[0], 0, 256 * sizeof(Rune));
}
for (i = 0; i < 0x20; i++) {
toUnicode[0][i] = i;
}
if (fixmissing) {
| | | 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 |
toUnicode[0] = (Rune *) malloc(256 * sizeof(Rune));
memset(toUnicode[0], 0, 256 * sizeof(Rune));
}
for (i = 0; i < 0x20; i++) {
toUnicode[0][i] = i;
}
if (fixmissing) {
for (i = 0x7F; i < 0xA0; i++) {
if (toUnicode[i] == NULL && toUnicode[0][i] == 0) {
toUnicode[0][i] = i;
}
}
}
}
|
| ︙ | ︙ | |||
230 231 232 233 234 235 236 |
printf("%c\n%04X %d %d\n", "SDM"[type], fallbackChar, symbol, used);
for (hi = 0; hi < 256; hi++) {
if (toUnicode[hi] != NULL) {
printf("%02X\n", hi);
for (lo = 0; lo < 256; lo++) {
printf("%04X", toUnicode[hi][lo]);
| | | 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 |
printf("%c\n%04X %d %d\n", "SDM"[type], fallbackChar, symbol, used);
for (hi = 0; hi < 256; hi++) {
if (toUnicode[hi] != NULL) {
printf("%02X\n", hi);
for (lo = 0; lo < 256; lo++) {
printf("%04X", toUnicode[hi][lo]);
if ((lo & 0x0F) == 0x0F) {
putchar('\n');
}
}
}
}
for (hi = 0; hi < 256; hi++) {
|
| ︙ | ︙ |
Deleted tools/fix_tommath_h.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to tools/genStubs.tcl.
| ︙ | ︙ | |||
475 476 477 478 479 480 481 482 483 484 485 |
variable libraryName
lassign $decl rtype fname args
append text "/* $index */\n"
if {[info exists stubs($name,deprecated,$index)]} {
append text "[string toupper $libraryName]_DEPRECATED(\"$stubs($name,deprecated,$index)\")\n"
set line "$rtype"
} else {
set line "$scspec $rtype"
}
set count [expr {2 - ([string length $line] / 8)}]
| > > > | > | 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 |
variable libraryName
lassign $decl rtype fname args
append text "/* $index */\n"
if {[info exists stubs($name,deprecated,$index)]} {
append text "[string toupper $libraryName]_DEPRECATED(\"$stubs($name,deprecated,$index)\")\n"
set line "$rtype"
} elseif {[string range $rtype end-5 end] eq "MP_WUR"} {
set line "$scspec [string trim [string range $rtype 0 end-6]]"
} else {
set line "$scspec $rtype"
}
set count [expr {2 - ([string length $line] / 8)}]
if {$count >= 0} {
append line [string range "\t\t\t" 0 $count]
}
set pad [expr {24 - [string length $line]}]
if {$pad <= 0} {
append line " "
set pad 0
}
if {$args eq ""} {
append line $fname
|
| ︙ | ︙ | |||
543 544 545 546 547 548 549 550 551 552 553 554 555 556 |
set pad 28
}
append line $next
set sep ", "
}
append line ")"
}
}
return "$text$line;\n"
}
# genStubs::makeMacro --
#
# Generate the inline macro for a function.
| > > > | 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 |
set pad 28
}
append line $next
set sep ", "
}
append line ")"
}
}
if {[string range $rtype end-5 end] eq "MP_WUR"} {
append line " MP_WUR"
}
return "$text$line;\n"
}
# genStubs::makeMacro --
#
# Generate the inline macro for a function.
|
| ︙ | ︙ | |||
607 608 609 610 611 612 613 614 615 616 617 618 619 620 |
append text $rtype " *" $lfname "; /* $index */\n"
return $text
}
if {[string range $rtype end-8 end] eq "__stdcall"} {
append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") "
} elseif {[string range $rtype 0 11] eq "TCL_NORETURN"} {
append text "TCL_NORETURN1 " [string trim [string range $rtype 12 end]] " (*" $lfname ") "
} else {
append text $rtype " (*" $lfname ") "
}
set arg1 [lindex $args 0]
switch -exact $arg1 {
void {
append text "(void)"
| > > | 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 |
append text $rtype " *" $lfname "; /* $index */\n"
return $text
}
if {[string range $rtype end-8 end] eq "__stdcall"} {
append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") "
} elseif {[string range $rtype 0 11] eq "TCL_NORETURN"} {
append text "TCL_NORETURN1 " [string trim [string range $rtype 12 end]] " (*" $lfname ") "
} elseif {[string range $rtype end-5 end] eq "MP_WUR"} {
append text [string trim [string range $rtype 0 end-6]] " (*" $lfname ") "
} else {
append text $rtype " (*" $lfname ") "
}
set arg1 [lindex $args 0]
switch -exact $arg1 {
void {
append text "(void)"
|
| ︙ | ︙ | |||
644 645 646 647 648 649 650 651 652 653 654 655 656 657 |
append text [lindex $arg 1] [lindex $arg 2]
set sep ", "
}
append text ")"
}
}
append text "; /* $index */\n"
return $text
}
# genStubs::makeInit --
#
# Generate the prototype for a function.
| > > > | 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 |
append text [lindex $arg 1] [lindex $arg 2]
set sep ", "
}
append text ")"
}
}
if {[string range $rtype end-5 end] eq "MP_WUR"} {
append text " MP_WUR"
}
append text "; /* $index */\n"
return $text
}
# genStubs::makeInit --
#
# Generate the prototype for a function.
|
| ︙ | ︙ |
Changes to tools/loadICU.tcl.
| ︙ | ︙ | |||
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 >= 0x0020 && $ccode < 0x007F && $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/makeTestCases.tcl.
| ︙ | ︙ | |||
588 589 590 591 592 593 594 |
puts $f2 " }"
puts $f2 "} ok"
foreach row $TZData(:America/Detroit) {
foreach { t offset isdst tzname } $row break
if { $t > -4000000000000 } {
set conds [list detroit]
| | | 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 |
puts $f2 " }"
puts $f2 "} ok"
foreach row $TZData(:America/Detroit) {
foreach { t offset isdst tzname } $row break
if { $t > -4000000000000 } {
set conds [list detroit]
if { $t > wide(0x7FFFFFFF) } {
set conds [list detroit y2038]
}
incr t -1
set x [clock format $t -format {%Y-%m-%d %H:%M:%S} \
-timezone :America/Detroit]
set r [clock format $t -format $fmt \
-timezone :America/Detroit]
|
| ︙ | ︙ |
Changes to tools/mkdepend.tcl.
| ︙ | ︙ | |||
94 95 96 97 98 99 100 |
if {![info exists target]} {
# this is ourself
set target $fname
puts stderr "processing [file tail $fname]"
} else {
# don't include ourselves as a dependency of ourself.
if {![string compare $fname $target]} {continue}
| | | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 |
if {![info exists target]} {
# this is ourself
set target $fname
puts stderr "processing [file tail $fname]"
} else {
# don't include ourselves as a dependency of ourself.
if {![string compare $fname $target]} {continue}
# store in an array so multiple occurrences are not counted.
set depends($target|$fname) ""
}
}
}
set result {}
foreach n [array names depends] {
|
| ︙ | ︙ |
Changes to tools/tcl.hpj.in.
1 2 3 4 5 6 7 | ; This file is maintained by HCW. Do not modify this file directly. [OPTIONS] HCW=0 LCID=0x409 0x0 0x0 ;English (United States) REPORT=Yes TITLE=Tcl/Tk Reference Manual | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | ; This file is maintained by HCW. Do not modify this file directly. [OPTIONS] HCW=0 LCID=0x409 0x0 0x0 ;English (United States) REPORT=Yes TITLE=Tcl/Tk Reference Manual CNT=tcl87.cnt COPYRIGHT=Copyright © 2000 Ajuba Solutions HLP=tcl87.hlp [FILES] tcl.rtf [WINDOWS] main="Tcl/Tk Reference Manual",,0 |
| ︙ | ︙ |
Added tools/tclOOScript.tcl.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 |
# tclOOScript.h --
#
# This file contains support scripts for TclOO. They are defined here so
# that the code can be definitely run even in safe interpreters; TclOO's
# core setup is safe.
#
# Copyright (c) 2012-2018 Donal K. Fellows
# Copyright (c) 2013 Andreas Kupries
# Copyright (c) 2017 Gerald Lester
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
::namespace eval ::oo {
::namespace path {}
#
# Commands that are made available to objects by default.
#
namespace eval Helpers {
::namespace path {}
# ------------------------------------------------------------------
#
# callback, mymethod --
#
# Create a script prefix that calls a method on the current
# object. Same operation, two names.
#
# ------------------------------------------------------------------
proc callback {method args} {
list [uplevel 1 {::namespace which my}] $method {*}$args
}
# Make the [callback] command appear as [mymethod] too.
namespace export callback
namespace eval tmp {namespace import ::oo::Helpers::callback}
namespace export -clear
rename tmp::callback mymethod
namespace delete tmp
# ------------------------------------------------------------------
#
# classvariable --
#
# Link to a variable in the class of the current object.
#
# ------------------------------------------------------------------
proc classvariable {name args} {
# Get a reference to the class's namespace
set ns [info object namespace [uplevel 1 {self class}]]
# Double up the list of variable names
foreach v [list $name {*}$args] {
if {[string match *(*) $v]} {
set reason "can't create a scalar variable that looks like an array element"
return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \
[format {bad variable name "%s": %s} $v $reason]
}
if {[string match *::* $v]} {
set reason "can't create a local variable with a namespace separator in it"
return -code error -errorcode {TCL UPVAR INVERTED} \
[format {bad variable name "%s": %s} $v $reason]
}
lappend vs $v $v
}
# Lastly, link the caller's local variables to the class's variables
tailcall namespace upvar $ns {*}$vs
}
# ------------------------------------------------------------------
#
# link --
#
# Make a command that invokes a method on the current object.
# The name of the command and the name of the method match by
# default.
#
# ------------------------------------------------------------------
proc link {args} {
set ns [uplevel 1 {::namespace current}]
foreach link $args {
if {[llength $link] == 2} {
lassign $link src dst
} elseif {[llength $link] == 1} {
lassign $link src
set dst $src
} else {
return -code error -errorcode {TCLOO CMDLINK FORMAT} \
"bad link description; must only have one or two elements"
}
if {![string match ::* $src]} {
set src [string cat $ns :: $src]
}
interp alias {} $src {} ${ns}::my $dst
trace add command ${ns}::my delete [list \
::oo::UnlinkLinkedCommand $src]
}
return
}
}
# ----------------------------------------------------------------------
#
# UnlinkLinkedCommand --
#
# Callback used to remove linked command when the underlying mechanism
# that supports it is deleted.
#
# ----------------------------------------------------------------------
proc UnlinkLinkedCommand {cmd args} {
if {[namespace which $cmd] ne {}} {
rename $cmd {}
}
}
# ----------------------------------------------------------------------
#
# DelegateName --
#
# Utility that gets the name of the class delegate for a class. It's
# trivial, but makes working with them much easier as delegate names are
# intentionally hard to create by accident.
#
# ----------------------------------------------------------------------
proc DelegateName {class} {
string cat [info object namespace $class] {:: oo ::delegate}
}
# ----------------------------------------------------------------------
#
# MixinClassDelegates --
#
# Support code called *after* [oo::define] inside the constructor of a
# class that patches in the appropriate class delegates.
#
# ----------------------------------------------------------------------
proc MixinClassDelegates {class} {
if {![info object isa class $class]} {
return
}
set delegate [DelegateName $class]
if {![info object isa class $delegate]} {
return
}
foreach c [info class superclass $class] {
set d [DelegateName $c]
if {![info object isa class $d]} {
continue
}
define $delegate ::oo::define::superclass -append $d
}
objdefine $class ::oo::objdefine::mixin -append $delegate
}
# ----------------------------------------------------------------------
#
# UpdateClassDelegatesAfterClone --
#
# Support code that is like [MixinClassDelegates] except for when a
# class is cloned.
#
# ----------------------------------------------------------------------
proc UpdateClassDelegatesAfterClone {originObject targetObject} {
# Rebuild the class inheritance delegation class
set originDelegate [DelegateName $originObject]
set targetDelegate [DelegateName $targetObject]
if {
[info object isa class $originDelegate]
&& ![info object isa class $targetDelegate]
} then {
copy $originDelegate $targetDelegate
objdefine $targetObject ::oo::objdefine::mixin -set \
{*}[lmap c [info object mixin $targetObject] {
if {$c eq $originDelegate} {set targetDelegate} {set c}
}]
}
}
# ----------------------------------------------------------------------
#
# oo::define::classmethod --
#
# Defines a class method. See define(n) for details.
#
# Note that the ::oo::define namespace is semi-public and a bit weird
# anyway, so we don't regard the namespace path as being under control:
# fully qualified names are used for everything.
#
# ----------------------------------------------------------------------
proc define::classmethod {name {args {}} {body {}}} {
# Create the method on the class if the caller gave arguments and body
::set argc [::llength [::info level 0]]
::if {$argc == 3} {
::return -code error -errorcode {TCL WRONGARGS} [::format \
{wrong # args: should be "%s name ?args body?"} \
[::lindex [::info level 0] 0]]
}
::set cls [::uplevel 1 self]
::if {$argc == 4} {
::oo::define [::oo::DelegateName $cls] method $name $args $body
}
# Make the connection by forwarding
::tailcall forward $name myclass $name
}
# ----------------------------------------------------------------------
#
# oo::define::initialise, oo::define::initialize --
#
# Do specific initialisation for a class. See define(n) for details.
#
# Note that the ::oo::define namespace is semi-public and a bit weird
# anyway, so we don't regard the namespace path as being under control:
# fully qualified names are used for everything.
#
# ----------------------------------------------------------------------
proc define::initialise {body} {
::set clsns [::info object namespace [::uplevel 1 self]]
::tailcall apply [::list {} $body $clsns]
}
# Make the [initialise] definition appear as [initialize] too
namespace eval define {
::namespace export initialise
::namespace eval tmp {::namespace import ::oo::define::initialise}
::namespace export -clear
::rename tmp::initialise initialize
::namespace delete tmp
}
# ----------------------------------------------------------------------
#
# Slot --
#
# The class of slot operations, which are basically lists at the low
# level of TclOO; this provides a more consistent interface to them.
#
# ----------------------------------------------------------------------
define Slot {
# ------------------------------------------------------------------
#
# Slot Get --
#
# Basic slot getter. Retrieves the contents of the slot.
# Particular slots must provide concrete non-erroring
# implementation.
#
# ------------------------------------------------------------------
method Get {} {
return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
}
# ------------------------------------------------------------------
#
# Slot Set --
#
# Basic slot setter. Sets the contents of the slot. Particular
# slots must provide concrete non-erroring implementation.
#
# ------------------------------------------------------------------
method Set list {
return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
}
# ------------------------------------------------------------------
#
# Slot Resolve --
#
# Helper that lets a slot convert a list of arguments of a
# particular type to their canonical forms. Defaults to doing
# nothing (suitable for simple strings).
#
# ------------------------------------------------------------------
method Resolve list {
return $list
}
# ------------------------------------------------------------------
#
# Slot -set, -append, -clear, --default-operation --
#
# Standard public slot operations. If a slot can't figure out
# what method to call directly, it uses --default-operation.
#
# ------------------------------------------------------------------
method -set args {
set my [namespace which my]
set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
tailcall my Set $args
}
method -append args {
set my [namespace which my]
set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
set current [uplevel 1 [list $my Get]]
tailcall my Set [list {*}$current {*}$args]
}
method -clear {} {tailcall my Set {}}
method -prepend args {
set my [namespace which my]
set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
set current [uplevel 1 [list $my Get]]
tailcall my Set [list {*}$args {*}$current]
}
method -remove args {
set my [namespace which my]
set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
set current [uplevel 1 [list $my Get]]
tailcall my Set [lmap val $current {
if {$val in $args} continue else {set val}
}]
}
# Default handling
forward --default-operation my -append
method unknown {args} {
set def --default-operation
if {[llength $args] == 0} {
tailcall my $def
} elseif {![string match -* [lindex $args 0]]} {
tailcall my $def {*}$args
}
next {*}$args
}
# Set up what is exported and what isn't
export -set -append -clear -prepend -remove
unexport unknown destroy
}
# Set the default operation differently for these slots
objdefine define::superclass forward --default-operation my -set
objdefine define::mixin forward --default-operation my -set
objdefine objdefine::mixin forward --default-operation my -set
# ----------------------------------------------------------------------
#
# oo::object <cloned> --
#
# Handler for cloning objects that clones basic bits (only!) of the
# object's namespace. Non-procedures, traces, sub-namespaces, etc. need
# more complex (and class-specific) handling.
#
# ----------------------------------------------------------------------
define object method <cloned> {originObject} {
# Copy over the procedures from the original namespace
foreach p [info procs [info object namespace $originObject]::*] {
set args [info args $p]
set idx -1
foreach a $args {
if {[info default $p $a d]} {
lset args [incr idx] [list $a $d]
} else {
lset args [incr idx] [list $a]
}
}
set b [info body $p]
set p [namespace tail $p]
proc $p $args $b
}
# Copy over the variables from the original namespace
foreach v [info vars [info object namespace $originObject]::*] {
upvar 0 $v vOrigin
namespace upvar [namespace current] [namespace tail $v] vNew
if {[info exists vOrigin]} {
if {[array exists vOrigin]} {
array set vNew [array get vOrigin]
} else {
set vNew $vOrigin
}
}
}
# General commands, sub-namespaces and advancd variable config (traces,
# etc) are *not* copied over. Classes that want that should do it
# themselves.
}
# ----------------------------------------------------------------------
#
# oo::class <cloned> --
#
# Handler for cloning classes, which fixes up the delegates.
#
# ----------------------------------------------------------------------
define class method <cloned> {originObject} {
next $originObject
# Rebuild the class inheritance delegation class
::oo::UpdateClassDelegatesAfterClone $originObject [self]
}
# ----------------------------------------------------------------------
#
# oo::singleton --
#
# A metaclass that is used to make classes that only permit one instance
# of them to exist. See singleton(n).
#
# ----------------------------------------------------------------------
class create singleton {
superclass class
variable object
unexport create createWithNamespace
method new args {
if {![info exists object] || ![info object isa object $object]} {
set object [next {*}$args]
::oo::objdefine $object {
method destroy {} {
::return -code error -errorcode {TCLOO SINGLETON} \
"may not destroy a singleton object"
}
method <cloned> {originObject} {
::return -code error -errorcode {TCLOO SINGLETON} \
"may not clone a singleton object"
}
}
}
return $object
}
}
# ----------------------------------------------------------------------
#
# oo::abstract --
#
# A metaclass that is used to make classes that can't be directly
# instantiated. See abstract(n).
#
# ----------------------------------------------------------------------
class create abstract {
superclass class
unexport create createWithNamespace new
}
}
# Local Variables:
# mode: tcl
# c-basic-offset: 4
# fill-column: 78
# End:
|
Changes to tools/tcltk-man2html-utils.tcl.
| ︙ | ︙ | |||
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]
| | | 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 |
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 ""] \
|
| ︙ | ︙ | |||
908 909 910 911 912 913 914 |
set text [string range $text[set text ""] [expr {$off+3}] end]
append result [cross-reference Tcl]
continue
}
url {
set off [lindex $offsets 0]
append result [string range $text 0 [expr {$off-1}]]
| | | 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 |
set text [string range $text[set text ""] [expr {$off+3}] end]
append result [cross-reference Tcl]
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 {
|
| ︙ | ︙ |
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 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
#!/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.7 (or the equivalent tclsh87.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.
#
# Note well, this program is a hack rather than a piece of software
# engineering. In that sense it's probably a good example of things
# that a scripting language, like Tcl, can do well. It is offered as
# an example of how someone might convert a specific set of man pages
# into hypertext, not as a general solution to the problem. If you
# try to use this, you'll be very much on your own.
#
# Copyright (c) 1995-1997 Roger E. Critchlow Jr
# Copyright (c) 2004-2010 Donal K. Fellows
set ::Version "50/8.7"
set ::CSSFILE "docs.css"
##
## Source the utility functions that provide most of the
## implementation of the transformation from nroff to html.
##
source [file join [file dirname [info script]] tcltk-man2html-utils.tcl]
|
| ︙ | ︙ |
Changes to tools/uniClass.tcl.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 |
# in order for the class ranges to match.
#
proc emitRange {first last} {
global ranges numranges chars numchars extchars extranges
if {$first < ($last-1)} {
| | | | | | | | | | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 |
# in order for the class ranges to match.
#
proc emitRange {first last} {
global ranges numranges chars numchars extchars extranges
if {$first < ($last-1)} {
if {!$extranges && ($first) > 0xFFFF} {
set extranges 1
set numranges 0
set ranges [string trimright $ranges " \n\r\t,"]
append ranges "\n#if CHRBITS > 16\n ,"
}
append ranges [format "{0x%X, 0x%X}, " \
$first $last]
if {[incr numranges] % 4 == 0} {
set ranges [string trimright $ranges]
append ranges "\n "
}
} else {
if {!$extchars && ($first) > 0xFFFF} {
set extchars 1
set numchars 0
set chars [string trimright $chars " \n\r\t,"]
append chars "\n#if CHRBITS > 16\n ,"
}
append chars [format "0x%X, " $first]
incr numchars
if {$numchars % 9 == 0} {
set chars [string trimright $chars]
append chars "\n "
}
if {$first != $last} {
append chars [format "0x%X, " $last]
incr numchars
if {$numchars % 9 == 0} {
append chars "\n "
}
}
}
}
proc genTable {type} {
global first last ranges numranges chars numchars extchars extranges
set first -2
set last -2
set ranges " "
set numranges 0
set chars " "
set numchars 0
set extchars 0
set extranges 0
for {set i 0} {$i <= 0x10FFFF} {incr i} {
if {$i == 0xD800} {
# Skip surrogates
set i 0xE000
}
if {[string is $type [format %c $i]]} {
if {$i == ($last + 1)} {
set last $i
} else {
if {$first >= 0} {
emitRange $first $last
}
|
| ︙ | ︙ |
Changes to tools/uniParse.tcl.
| ︙ | ︙ | |||
110 111 112 113 114 115 116 |
set line [format %X [expr {($next-1)|$mask}]]
append line ";;Cn;0;ON;;;;;N;;;;;\n"
}
set items [split $line \;]
scan [lindex $items 0] %x index
| | | | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 |
set line [format %X [expr {($next-1)|$mask}]]
append line ";;Cn;0;ON;;;;;N;;;;;\n"
}
set items [split $line \;]
scan [lindex $items 0] %x index
if {$index > 0x3FFFF} then {
# Ignore characters > plane 3
continue
}
set index [format %d $index]
set gIndex [getGroup [getValue $items $index]]
# Since the input table omits unassigned characters, these will
|
| ︙ | ︙ | |||
339 340 341 342 343 344 345 |
set line " "
}
}
puts $f $line
puts -nonewline $f "};
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
| | | | 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 |
set line " "
}
}
puts $f $line
puts -nonewline $f "};
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1FFFFF) >= [format 0x%X $next])
#else
# define UNICODE_OUT_OF_RANGE(ch) (((ch) & 0x1F0000) != 0)
#endif
/*
* The following constants are used to determine the category of a
* Unicode character.
*/
|
| ︙ | ︙ | |||
388 389 390 391 392 393 394 | /* * The following macros extract the fields of the character info. The * GetDelta() macro is complicated because we can't rely on the C compiler * to do sign extension on right shifts. */ | | | | | | 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 |
/*
* The following macros extract the fields of the character info. The
* GetDelta() macro is complicated because we can't rely on the C compiler
* to do sign extension on right shifts.
*/
#define GetCaseType(info) (((info) & 0xE0) >> 5)
#define GetCategory(ch) (GetUniCharInfo(ch) & 0x1F)
#define GetDelta(info) ((info) >> 8)
/*
* This macro extracts the information about a character from the
* Unicode character tables.
*/
#if TCL_UTF_MAX > 3 || TCL_MAJOR_VERSION > 8 || TCL_MINOR_VERSION > 6
# define GetUniCharInfo(ch) (groups\[groupMap\[pageMap\[((ch) & 0x1FFFFF) >> OFFSET_BITS\] | ((ch) & ((1 << OFFSET_BITS)-1))\]\])
#else
# define GetUniCharInfo(ch) (groups\[groupMap\[pageMap\[((ch) & 0xFFFF) >> OFFSET_BITS\] | ((ch) & ((1 << OFFSET_BITS)-1))\]\])
#endif
"
close $f
}
uni::main
return
|
Changes to unix/Makefile.in.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 31 32 33 34 35 36 37 | prefix = @prefix@ exec_prefix = @exec_prefix@ bindir = @bindir@ libdir = @libdir@ includedir = @includedir@ datarootdir = @datarootdir@ mandir = @mandir@ # The following definition can be set to non-null for special systems like AFS # with replication. It allows the pathnames used for installation to be # different than those used for actually reference files at run-time. # INSTALL_ROOT is prepended to $prefix and $exec_prefix when installing files. INSTALL_ROOT = $(DESTDIR) | > | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | prefix = @prefix@ exec_prefix = @exec_prefix@ bindir = @bindir@ libdir = @libdir@ includedir = @includedir@ datarootdir = @datarootdir@ runstatedir = @runstatedir@ mandir = @mandir@ # The following definition can be set to non-null for special systems like AFS # with replication. It allows the pathnames used for installation to be # different than those used for actually reference files at run-time. # INSTALL_ROOT is prepended to $prefix and $exec_prefix when installing files. INSTALL_ROOT = $(DESTDIR) |
| ︙ | ︙ | |||
48 49 50 51 52 53 54 55 56 57 58 59 60 61 | # Directory in which to install libtcl.so or libtcl.a: LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) DLL_INSTALL_DIR = @DLL_INSTALL_DIR@ # Path name to use when installing library scripts. SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Path to the private tcl header dir: PRIVATE_INCLUDE_DIR = @PRIVATE_INCLUDE_DIR@ # Directory in which to (optionally) install the private tcl headers: | > > > | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | # Directory in which to install libtcl.so or libtcl.a: LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) DLL_INSTALL_DIR = @DLL_INSTALL_DIR@ # Path name to use when installing library scripts. SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) # Path name to use when installing Tcl modules. MODULE_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)/../tcl8 # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Path to the private tcl header dir: PRIVATE_INCLUDE_DIR = @PRIVATE_INCLUDE_DIR@ # Directory in which to (optionally) install the private tcl headers: |
| ︙ | ︙ | |||
106 107 108 109 110 111 112 | CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@ # Flags to pass to the linker LDFLAGS_DEBUG = @LDFLAGS_DEBUG@ LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@ LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@ | < < < < < | | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 |
CFLAGS = @CFLAGS_DEFAULT@ @CFLAGS@
# Flags to pass to the linker
LDFLAGS_DEBUG = @LDFLAGS_DEBUG@
LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@
LDFLAGS = @LDFLAGS_DEFAULT@ @LDFLAGS@
# If you use the setenv, putenv, or unsetenv procedures to modify environment
# variables in your application and you'd like those modifications to appear
# in the "env" Tcl variable, switch the comments on the two lines below so
# that Tcl provides these procedures instead of your standard C library.
ENV_FLAGS =
#ENV_FLAGS = -DTclSetEnv=setenv -DTcl_PutEnv=putenv -DTclUnsetEnv=unsetenv
# To enable memory debugging, call configure with --enable-symbols=mem
# Warning: if you enable memory debugging, you must do it *everywhere*,
# including all the code that calls Tcl, and you must use ckalloc and ckfree
# everywhere instead of malloc and free.
TCL_STUB_LIB_FILE = @TCL_STUB_LIB_FILE@
#TCL_STUB_LIB_FILE = libtclstub.a
# Generic stub lib name used in rules that apply to tcl and tk
STUB_LIB_FILE = ${TCL_STUB_LIB_FILE}
|
| ︙ | ︙ | |||
175 176 177 178 179 180 181 182 183 184 185 186 187 188 | # the symbols are normally set by the configure script. You shouldn't normally # need to modify any of these definitions by hand. STLIB_LD = @STLIB_LD@ SHLIB_LD = @SHLIB_LD@ SHLIB_CFLAGS = @SHLIB_CFLAGS@ -DBUILD_tcl SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ TCL_SHLIB_LD_EXTRAS = @TCL_SHLIB_LD_EXTRAS@ SHLIB_SUFFIX = @SHLIB_SUFFIX@ DLTEST_TARGETS = dltest.marker # Additional search flags needed to find the various shared libraries at | > | 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 | # the symbols are normally set by the configure script. You shouldn't normally # need to modify any of these definitions by hand. STLIB_LD = @STLIB_LD@ SHLIB_LD = @SHLIB_LD@ SHLIB_CFLAGS = @SHLIB_CFLAGS@ -DBUILD_tcl SHLIB_LD_LIBS = @SHLIB_LD_LIBS@ SHLIB_LD_FLAGS = @SHLIB_LD_FLAGS@ TCL_SHLIB_LD_EXTRAS = @TCL_SHLIB_LD_EXTRAS@ SHLIB_SUFFIX = @SHLIB_SUFFIX@ DLTEST_TARGETS = dltest.marker # Additional search flags needed to find the various shared libraries at |
| ︙ | ︙ | |||
223 224 225 226 227 228 229 | AR = @AR@ RANLIB = @RANLIB@ DTRACE = @DTRACE@ SRC_DIR = @srcdir@ TOP_DIR = @TCL_SRC_DIR@ BUILD_DIR = @builddir@ GENERIC_DIR = $(TOP_DIR)/generic | < > > | 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 |
AR = @AR@
RANLIB = @RANLIB@
DTRACE = @DTRACE@
SRC_DIR = @srcdir@
TOP_DIR = @TCL_SRC_DIR@
BUILD_DIR = @builddir@
GENERIC_DIR = $(TOP_DIR)/generic
COMPAT_DIR = $(TOP_DIR)/compat
TOOL_DIR = $(TOP_DIR)/tools
UNIX_DIR = $(TOP_DIR)/unix
MAC_OSX_DIR = $(TOP_DIR)/macosx
PKGS_DIR = $(TOP_DIR)/pkgs
# Must be absolute because of the cd dltest $(DLTEST_DIR)/configure below.
DLTEST_DIR = @TCL_SRC_DIR@/unix/dltest
# Must be absolute to so the corresponding tcltest's tcl_library is absolute.
TCL_BUILDTIME_LIBRARY = @TCL_SRC_DIR@/library
ZLIB_DIR = ${COMPAT_DIR}/zlib
ZLIB_INCLUDE = @ZLIB_INCLUDE@
TOMMATH_DIR = $(TOP_DIR)/libtommath
TOMMATH_INCLUDE = @TOMMATH_INCLUDE@
CC = @CC@
OBJEXT = @OBJEXT@
#CC = purify -best-effort @CC@ -DPURIFY
# Flags to be passed to installManPage to control how the manpages should be
|
| ︙ | ︙ | |||
270 271 272 273 274 275 276 | --suppressions=$(TOOL_DIR)/valgrind_suppress #-------------------------------------------------------------------------- # The information below should be usable as is. The configure script won't # modify it and you shouldn't need to modify it either. #-------------------------------------------------------------------------- | < | > | | | | 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 |
--suppressions=$(TOOL_DIR)/valgrind_suppress
#--------------------------------------------------------------------------
# The information below should be usable as is. The configure script won't
# modify it and you shouldn't need to modify it either.
#--------------------------------------------------------------------------
STUB_CC_SWITCHES = -I"${BUILD_DIR}" -I${UNIX_DIR} -I${GENERIC_DIR} -I${TOMMATH_DIR} \
${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
${AC_FLAGS} ${ENV_FLAGS} ${EXTRA_CFLAGS} \
@EXTRA_CC_SWITCHES@
CC_SWITCHES = $(STUB_CC_SWITCHES) ${NO_DEPRECATED_FLAGS} -DMP_FIXED_CUTOFFS -DMP_NO_STDINT
APP_CC_SWITCHES = $(CC_SWITCHES) @EXTRA_APP_CC_SWITCHES@
LIBS = @TCL_LIBS@
DEPEND_SWITCHES = ${CFLAGS} -I${UNIX_DIR} -I${GENERIC_DIR} \
${AC_FLAGS} ${EXTRA_CFLAGS} @EXTRA_CC_SWITCHES@
TCLSH_OBJS = tclAppInit.o
TCLTEST_OBJS = tclTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
tclThreadTest.o tclUnixTest.o
XTTEST_OBJS = xtTestInit.o tclTest.o tclTestObj.o tclTestProcBodyObj.o \
|
| ︙ | ︙ | |||
315 316 317 318 319 320 321 | tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \ tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o tclZlib.o \ tclTomMathInterface.o tclZipfs.o OO_OBJS = tclOO.o tclOOBasic.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o \ tclOOMethod.o tclOOStubInit.o | | | | | | | > | | | | | | | | 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 |
tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \
tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o tclZlib.o \
tclTomMathInterface.o tclZipfs.o
OO_OBJS = tclOO.o tclOOBasic.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o \
tclOOMethod.o tclOOStubInit.o
TOMMATH_OBJS = bn_s_mp_reverse.o bn_s_mp_mul_digs_fast.o \
bn_s_mp_sqr_fast.o bn_mp_add.o bn_mp_and.o \
bn_mp_add_d.o bn_mp_clamp.o bn_mp_clear.o bn_mp_clear_multi.o \
bn_mp_cmp.o bn_mp_cmp_d.o bn_mp_cmp_mag.o \
bn_mp_cnt_lsb.o bn_mp_copy.o \
bn_mp_count_bits.o bn_mp_div.o bn_mp_div_d.o bn_mp_div_2.o \
bn_mp_div_2d.o bn_mp_div_3.o bn_mp_exch.o bn_mp_expt_u32.o \
bn_mp_get_mag_u64.o \
bn_mp_grow.o bn_mp_init.o \
bn_mp_init_copy.o bn_mp_init_multi.o bn_mp_init_set.o \
bn_mp_init_size.o bn_s_mp_karatsuba_mul.o \
bn_mp_init_i64.o bn_mp_init_u64.o \
bn_s_mp_karatsuba_sqr.o bn_s_mp_balance_mul.o \
bn_mp_lshd.o bn_mp_mod.o bn_mp_mod_2d.o bn_mp_mul.o bn_mp_mul_2.o \
bn_mp_mul_2d.o bn_mp_mul_d.o bn_mp_neg.o bn_mp_or.o \
bn_mp_radix_size.o bn_mp_radix_smap.o bn_mp_set_i64.o \
bn_mp_read_radix.o bn_mp_rshd.o \
bn_mp_set_u64.o bn_mp_shrink.o \
bn_mp_sqr.o bn_mp_sqrt.o bn_mp_sub.o bn_mp_sub_d.o \
bn_mp_signed_rsh.o \
bn_mp_to_ubin.o \
bn_s_mp_toom_mul.o bn_s_mp_toom_sqr.o bn_mp_to_radix.o \
bn_mp_ubin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \
bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o
STUB_LIB_OBJS = tclStubLib.o \
tclTomMathStubLib.o \
tclOOStubLib.o \
${COMPAT_OBJS}
|
| ︙ | ︙ | |||
363 364 365 366 367 368 369 |
ZLIB_OBJS = Zadler32.o Zcompress.o Zcrc32.o Zdeflate.o Zinfback.o \
Zinffast.o Zinflate.o Zinftrees.o Ztrees.o Zuncompr.o Zzutil.o
TCL_OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${NOTIFY_OBJS} ${COMPAT_OBJS} \
${OO_OBJS} @DL_OBJS@ @PLAT_OBJS@
| | | 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 |
ZLIB_OBJS = Zadler32.o Zcompress.o Zcrc32.o Zdeflate.o Zinfback.o \
Zinffast.o Zinflate.o Zinftrees.o Ztrees.o Zuncompr.o Zzutil.o
TCL_OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${NOTIFY_OBJS} ${COMPAT_OBJS} \
${OO_OBJS} @DL_OBJS@ @PLAT_OBJS@
OBJS = ${TCL_OBJS} @DTRACE_OBJ@ @ZLIB_OBJS@ @TOMMATH_OBJS@
TCL_DECLS = \
$(GENERIC_DIR)/tcl.decls \
$(GENERIC_DIR)/tclInt.decls \
$(GENERIC_DIR)/tclOO.decls \
$(GENERIC_DIR)/tclTomMath.decls
|
| ︙ | ︙ | |||
486 487 488 489 490 491 492 | STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c \ $(GENERIC_DIR)/tclTomMathStubLib.c \ $(GENERIC_DIR)/tclOOStubLib.c TOMMATH_SRCS = \ | | > | | > | | > | | > > > > > | | | > | > > | > > > > > > > > > > > > > > | | > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | > > > > > > > > | | | | | | | | | > > > > > > > > > > > > > > > > > > | > > | 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 | STUB_SRCS = \ $(GENERIC_DIR)/tclStubLib.c \ $(GENERIC_DIR)/tclTomMathStubLib.c \ $(GENERIC_DIR)/tclOOStubLib.c TOMMATH_SRCS = \ $(TOMMATH_DIR)/bn_cutoffs.c \ $(TOMMATH_DIR)/bn_deprecated.c \ $(TOMMATH_DIR)/bn_mp_2expt.c \ $(TOMMATH_DIR)/bn_mp_abs.c \ $(TOMMATH_DIR)/bn_mp_add.c \ $(TOMMATH_DIR)/bn_mp_add_d.c \ $(TOMMATH_DIR)/bn_mp_addmod.c \ $(TOMMATH_DIR)/bn_mp_and.c \ $(TOMMATH_DIR)/bn_mp_clamp.c \ $(TOMMATH_DIR)/bn_mp_clear.c \ $(TOMMATH_DIR)/bn_mp_clear_multi.c \ $(TOMMATH_DIR)/bn_mp_cmp.c \ $(TOMMATH_DIR)/bn_mp_cmp_d.c \ $(TOMMATH_DIR)/bn_mp_cmp_mag.c \ $(TOMMATH_DIR)/bn_mp_cnt_lsb.c \ $(TOMMATH_DIR)/bn_mp_complement.c \ $(TOMMATH_DIR)/bn_mp_copy.c \ $(TOMMATH_DIR)/bn_mp_count_bits.c \ $(TOMMATH_DIR)/bn_mp_decr.c \ $(TOMMATH_DIR)/bn_mp_div.c \ $(TOMMATH_DIR)/bn_mp_div_2.c \ $(TOMMATH_DIR)/bn_mp_div_2d.c \ $(TOMMATH_DIR)/bn_mp_div_3.c \ $(TOMMATH_DIR)/bn_mp_div_d.c \ $(TOMMATH_DIR)/bn_mp_dr_is_modulus.c \ $(TOMMATH_DIR)/bn_mp_dr_reduce.c \ $(TOMMATH_DIR)/bn_mp_dr_setup.c \ $(TOMMATH_DIR)/bn_mp_error_to_string.c \ $(TOMMATH_DIR)/bn_mp_exch.c \ $(TOMMATH_DIR)/bn_mp_expt_u32.c \ $(TOMMATH_DIR)/bn_mp_exptmod.c \ $(TOMMATH_DIR)/bn_mp_exteuclid.c \ $(TOMMATH_DIR)/bn_mp_fread.c \ $(TOMMATH_DIR)/bn_mp_from_sbin.c \ $(TOMMATH_DIR)/bn_mp_from_ubin.c \ $(TOMMATH_DIR)/bn_mp_fwrite.c \ $(TOMMATH_DIR)/bn_mp_gcd.c \ $(TOMMATH_DIR)/bn_mp_get_double.c \ $(TOMMATH_DIR)/bn_mp_get_i32.c \ $(TOMMATH_DIR)/bn_mp_get_i64.c \ $(TOMMATH_DIR)/bn_mp_get_l.c \ $(TOMMATH_DIR)/bn_mp_get_ll.c \ $(TOMMATH_DIR)/bn_mp_get_mag_u32.c \ $(TOMMATH_DIR)/bn_mp_get_mag_u64.c \ $(TOMMATH_DIR)/bn_mp_get_mag_ul.c \ $(TOMMATH_DIR)/bn_mp_get_mag_ull.c \ $(TOMMATH_DIR)/bn_mp_grow.c \ $(TOMMATH_DIR)/bn_mp_incr.c \ $(TOMMATH_DIR)/bn_mp_init.c \ $(TOMMATH_DIR)/bn_mp_init_copy.c \ $(TOMMATH_DIR)/bn_mp_init_i32.c \ $(TOMMATH_DIR)/bn_mp_init_i64.c \ $(TOMMATH_DIR)/bn_mp_init_l.c \ $(TOMMATH_DIR)/bn_mp_init_ll.c \ $(TOMMATH_DIR)/bn_mp_init_multi.c \ $(TOMMATH_DIR)/bn_mp_init_set.c \ $(TOMMATH_DIR)/bn_mp_init_size.c \ $(TOMMATH_DIR)/bn_mp_init_u32.c \ $(TOMMATH_DIR)/bn_mp_init_u64.c \ $(TOMMATH_DIR)/bn_mp_init_ul.c \ $(TOMMATH_DIR)/bn_mp_init_ull.c \ $(TOMMATH_DIR)/bn_mp_invmod.c \ $(TOMMATH_DIR)/bn_mp_is_square.c \ $(TOMMATH_DIR)/bn_mp_iseven.c \ $(TOMMATH_DIR)/bn_mp_isodd.c \ $(TOMMATH_DIR)/bn_mp_kronecker.c \ $(TOMMATH_DIR)/bn_mp_lcm.c \ $(TOMMATH_DIR)/bn_mp_log_u32.c \ $(TOMMATH_DIR)/bn_mp_lshd.c \ $(TOMMATH_DIR)/bn_mp_mod.c \ $(TOMMATH_DIR)/bn_mp_mod_2d.c \ $(TOMMATH_DIR)/bn_mp_mod_d.c \ $(TOMMATH_DIR)/bn_mp_montgomery_calc_normalization.c \ $(TOMMATH_DIR)/bn_mp_montgomery_reduce.c \ $(TOMMATH_DIR)/bn_mp_montgomery_setup.c \ $(TOMMATH_DIR)/bn_mp_mul.c \ $(TOMMATH_DIR)/bn_mp_mul_2.c \ $(TOMMATH_DIR)/bn_mp_mul_2d.c \ $(TOMMATH_DIR)/bn_mp_mul_d.c \ $(TOMMATH_DIR)/bn_mp_mulmod.c \ $(TOMMATH_DIR)/bn_mp_neg.c \ $(TOMMATH_DIR)/bn_mp_or.c \ $(TOMMATH_DIR)/bn_mp_pack.c \ $(TOMMATH_DIR)/bn_mp_pack_count.c \ $(TOMMATH_DIR)/bn_mp_prime_fermat.c \ $(TOMMATH_DIR)/bn_mp_prime_frobenius_underwood.c \ $(TOMMATH_DIR)/bn_mp_prime_is_prime.c \ $(TOMMATH_DIR)/bn_mp_prime_miller_rabin.c \ $(TOMMATH_DIR)/bn_mp_prime_next_prime.c \ $(TOMMATH_DIR)/bn_mp_prime_rabin_miller_trials.c \ $(TOMMATH_DIR)/bn_mp_prime_rand.c \ $(TOMMATH_DIR)/bn_mp_prime_strong_lucas_selfridge.c \ $(TOMMATH_DIR)/bn_mp_radix_size.c \ $(TOMMATH_DIR)/bn_mp_radix_smap.c \ $(TOMMATH_DIR)/bn_mp_rand.c \ $(TOMMATH_DIR)/bn_mp_read_radix.c \ $(TOMMATH_DIR)/bn_mp_reduce.c \ $(TOMMATH_DIR)/bn_mp_reduce_2k.c \ $(TOMMATH_DIR)/bn_mp_reduce_2k_l.c \ $(TOMMATH_DIR)/bn_mp_reduce_2k_setup.c \ $(TOMMATH_DIR)/bn_mp_reduce_2k_setup_l.c \ $(TOMMATH_DIR)/bn_mp_reduce_is_2k.c \ $(TOMMATH_DIR)/bn_mp_reduce_is_2k_l.c \ $(TOMMATH_DIR)/bn_mp_reduce_setup.c \ $(TOMMATH_DIR)/bn_mp_root_u32.c \ $(TOMMATH_DIR)/bn_mp_rshd.c \ $(TOMMATH_DIR)/bn_mp_sbin_size.c \ $(TOMMATH_DIR)/bn_mp_set.c \ $(TOMMATH_DIR)/bn_mp_set_double.c \ $(TOMMATH_DIR)/bn_mp_set_i32.c \ $(TOMMATH_DIR)/bn_mp_set_i64.c \ $(TOMMATH_DIR)/bn_mp_set_l.c \ $(TOMMATH_DIR)/bn_mp_set_ll.c \ $(TOMMATH_DIR)/bn_mp_set_u32.c \ $(TOMMATH_DIR)/bn_mp_set_u64.c \ $(TOMMATH_DIR)/bn_mp_set_ul.c \ $(TOMMATH_DIR)/bn_mp_set_ull.c \ $(TOMMATH_DIR)/bn_mp_shrink.c \ $(TOMMATH_DIR)/bn_mp_signed_rsh.c \ $(TOMMATH_DIR)/bn_mp_sqr.c \ $(TOMMATH_DIR)/bn_mp_sqrmod.c \ $(TOMMATH_DIR)/bn_mp_sqrt.c \ $(TOMMATH_DIR)/bn_mp_sqrtmod_prime.c \ $(TOMMATH_DIR)/bn_mp_sub.c \ $(TOMMATH_DIR)/bn_mp_sub_d.c \ $(TOMMATH_DIR)/bn_mp_submod.c \ $(TOMMATH_DIR)/bn_mp_to_radix.c \ $(TOMMATH_DIR)/bn_mp_to_sbin.c \ $(TOMMATH_DIR)/bn_mp_to_ubin.c \ $(TOMMATH_DIR)/bn_mp_ubin_size.c \ $(TOMMATH_DIR)/bn_mp_unpack.c \ $(TOMMATH_DIR)/bn_mp_xor.c \ $(TOMMATH_DIR)/bn_mp_zero.c \ $(TOMMATH_DIR)/bn_prime_tab.c \ $(TOMMATH_DIR)/bn_s_mp_add.c \ $(TOMMATH_DIR)/bn_s_mp_balance_mul.c \ $(TOMMATH_DIR)/bn_s_mp_exptmod.c \ $(TOMMATH_DIR)/bn_s_mp_exptmod_fast.c \ $(TOMMATH_DIR)/bn_s_mp_get_bit.c \ $(TOMMATH_DIR)/bn_s_mp_invmod_fast.c \ $(TOMMATH_DIR)/bn_s_mp_invmod_slow.c \ $(TOMMATH_DIR)/bn_s_mp_karatsuba_mul.c \ $(TOMMATH_DIR)/bn_s_mp_karatsuba_sqr.c \ $(TOMMATH_DIR)/bn_s_mp_montgomery_reduce_fast.c \ $(TOMMATH_DIR)/bn_s_mp_mul_digs.c \ $(TOMMATH_DIR)/bn_s_mp_mul_digs_fast.c \ $(TOMMATH_DIR)/bn_s_mp_mul_high_digs.c \ $(TOMMATH_DIR)/bn_s_mp_mul_high_digs_fast.c \ $(TOMMATH_DIR)/bn_s_mp_prime_is_divisible.c \ $(TOMMATH_DIR)/bn_s_mp_rand_jenkins.c \ $(TOMMATH_DIR)/bn_s_mp_rand_platform.c \ $(TOMMATH_DIR)/bn_s_mp_reverse.c \ $(TOMMATH_DIR)/bn_s_mp_sqr.c \ $(TOMMATH_DIR)/bn_s_mp_sqr_fast.c \ $(TOMMATH_DIR)/bn_s_mp_sub.c \ $(TOMMATH_DIR)/bn_s_mp_toom_mul.c \ $(TOMMATH_DIR)/bn_s_mp_toom_sqr.c UNIX_HDRS = \ $(UNIX_DIR)/tclUnixPort.h # $(UNIX_DIR)/tclConfig.h UNIX_SRCS = \ $(UNIX_DIR)/tclAppInit.c \ |
| ︙ | ︙ | |||
619 620 621 622 623 624 625 | $(ZLIB_DIR)/uncompr.c \ $(ZLIB_DIR)/zutil.c # Note: don't include DL_SRCS or MAC_OSX_SRCS in SRCS: most of those files # won't compile on the current machine, and they will cause problems for # things like "make depend". | | | | 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 | $(ZLIB_DIR)/uncompr.c \ $(ZLIB_DIR)/zutil.c # Note: don't include DL_SRCS or MAC_OSX_SRCS in SRCS: most of those files # won't compile on the current machine, and they will cause problems for # things like "make depend". SRCS = $(GENERIC_SRCS) $(UNIX_SRCS) $(NOTIFY_SRCS) \ $(OO_SRCS) $(STUB_SRCS) @PLAT_SRCS@ @ZLIB_SRCS@ @TOMMATH_SRCS@ ### # Tip 430 - ZipFS Modifications ### TCL_ZIP_FILE = @TCL_ZIP_FILE@ TCL_VFS_ROOT = libtcl.vfs |
| ︙ | ︙ | |||
679 680 681 682 683 684 685 |
tclzipfile: ${TCL_ZIP_FILE}
${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS}
@rm -rf ${TCL_VFS_ROOT}
@mkdir -p ${TCL_VFS_PATH}
@echo "creating ${TCL_VFS_PATH} (prepare compression)"
@if \
| | < < > > | 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 |
tclzipfile: ${TCL_ZIP_FILE}
${TCL_ZIP_FILE}: ${ZIP_INSTALL_OBJS}
@rm -rf ${TCL_VFS_ROOT}
@mkdir -p ${TCL_VFS_PATH}
@echo "creating ${TCL_VFS_PATH} (prepare compression)"
@if \
ln -s $(TOP_DIR)/library/* ${TCL_VFS_PATH}/; \
then : ; else \
cp -a $(TOP_DIR)/library/* ${TCL_VFS_PATH}; \
fi
mv ${TCL_VFS_PATH}/manifest.txt ${TCL_VFS_PATH}/pkgIndex.tcl
rm -rf ${TCL_VFS_PATH}/dde ${TCL_VFS_PATH}/reg
@find ${TCL_VFS_ROOT} -type d -empty -delete
@echo "creating ${TCL_ZIP_FILE} from ${TCL_VFS_PATH}"
@(zip=`(realpath '${NATIVE_ZIP}' || readlink -m '${NATIVE_ZIP}' || \
echo '${NATIVE_ZIP}' | sed "s?^\./?$$(pwd)/?") 2>/dev/null`; \
echo 'cd ${TCL_VFS_ROOT} &&' $$zip '${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH}'; \
cd ${TCL_VFS_ROOT} && \
$$zip ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH} >/dev/null)
|
| ︙ | ︙ | |||
894 895 896 897 898 899 900 | "$(CONFIG_INSTALL_DIR)/tclooConfig.sh" @if test "$(STUB_LIB_FILE)" != "" ; then \ echo "Installing $(STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \ @INSTALL_STUB_LIB@ ; \ fi @EXTRA_INSTALL_BINARIES@ @echo "Installing pkg-config file to $(LIB_INSTALL_DIR)/pkgconfig/" | | | | | < < | > | | | > > > > > > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 |
"$(CONFIG_INSTALL_DIR)/tclooConfig.sh"
@if test "$(STUB_LIB_FILE)" != "" ; then \
echo "Installing $(STUB_LIB_FILE) to $(LIB_INSTALL_DIR)/"; \
@INSTALL_STUB_LIB@ ; \
fi
@EXTRA_INSTALL_BINARIES@
@echo "Installing pkg-config file to $(LIB_INSTALL_DIR)/pkgconfig/"
@$(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/pkgconfig"
@$(INSTALL_DATA) tcl.pc "$(LIB_INSTALL_DIR)/pkgconfig/tcl.pc"
install-libraries-zipfs-shared: libraries
@for i in "$(SCRIPT_INSTALL_DIR)"; do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
fi; \
done
@echo "Installing library files to $(SCRIPT_INSTALL_DIR)/"
@for i in $(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \
done
install-libraries-zipfs-static: install-libraries-zipfs-shared
$(INSTALL_DATA) ${TCL_ZIP_FILE} "$(LIB_INSTALL_DIR)"
install-libraries: libraries
@for i in "$(SCRIPT_INSTALL_DIR)" "$(MODULE_INSTALL_DIR)"; \
do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
fi; \
done
@for i in opt0.4 cookiejar0.2 encoding; do \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/$$i"; \
else true; \
fi; \
done;
@for i in 8.4 8.4/platform 8.5 8.6 8.7; \
do \
if [ ! -d "$(MODULE_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(MODULE_INSTALL_DIR)/$$i"; \
$(INSTALL_DATA_DIR) "$(MODULE_INSTALL_DIR)/$$i"; \
fi; \
done
@echo "Installing library files to $(SCRIPT_INSTALL_DIR)/"
@for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex \
$(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@ ; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \
done
@echo "Installing package cookiejar 0.2 files to $(SCRIPT_INSTALL_DIR)/cookiejar0.2/"
@for i in $(TOP_DIR)/library/cookiejar/*.tcl; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \
done
@for i in $(TOP_DIR)/library/cookiejar/*.gz; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \
done
@echo "Installing package http 2.9.2 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl \
"$(MODULE_INSTALL_DIR)/8.6/http-2.9.2.tm"
@echo "Installing package opt 0.4.7"
@for i in $(TOP_DIR)/library/opt/*.tcl; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
done
@echo "Installing package msgcat 1.7.1 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl \
"$(MODULE_INSTALL_DIR)/8.7/msgcat-1.7.1.tm"
@echo "Installing package tcltest 2.5.3 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl \
"$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.3.tm"
@echo "Installing package platform 1.0.14 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl \
"$(MODULE_INSTALL_DIR)/8.4/platform-1.0.14.tm"
@echo "Installing package platform::shell 1.1.4 as a Tcl Module"
@$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl \
"$(MODULE_INSTALL_DIR)/8.4/platform/shell-1.1.4.tm"
@echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/"
@for i in $(TOP_DIR)/library/encoding/*.enc; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/encoding"; \
done
@if [ -n "$(TCL_MODULE_PATH)" -a -f $(TOP_DIR)/library/tm.tcl ] ; then \
echo "Customizing tcl module path"; \
echo "if {![interp issafe]} { ::tcl::tm::roots {$(TCL_MODULE_PATH)} }" >> \
"$(SCRIPT_INSTALL_DIR)/tm.tcl"; \
fi
install-tzdata:
@for i in tzdata; do \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/$$i"; \
fi; \
done
@echo "Installing time zone files to $(SCRIPT_INSTALL_DIR)/tzdata/"
@for i in $(TOP_DIR)/library/tzdata/*; do \
if [ -d $$i ] ; then \
ii=`basename $$i`; \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii" ] ; then \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii"; \
fi; \
for j in $$i/*; do \
if [ -d $$j ] ; then \
jj=`basename $$j`; \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii/$$jj" ] ; then \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii/$$jj"; \
fi; \
for k in $$j/*; do \
$(INSTALL_DATA) $$k "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii/$$jj"; \
done; \
else \
$(INSTALL_DATA) $$j "$(SCRIPT_INSTALL_DIR)/tzdata/$$ii"; \
fi; \
done; \
else \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/tzdata"; \
fi; \
done
install-msgs:
@for i in msgs; do \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
$(INSTALL_DATA_DIR) "$(SCRIPT_INSTALL_DIR)/$$i"; \
fi; \
done
@echo "Installing message catalog files to $(SCRIPT_INSTALL_DIR)/msgs/"
@for i in $(TOP_DIR)/library/msgs/*.msg; do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)/msgs"; \
done
install-doc: doc
@for i in "$(MAN_INSTALL_DIR)" "$(MAN1_INSTALL_DIR)" "$(MAN3_INSTALL_DIR)" "$(MANN_INSTALL_DIR)"; do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
fi; \
done
@echo "Installing and cross-linking top-level (.1) docs to $(MAN1_INSTALL_DIR)/"
@for i in $(TOP_DIR)/doc/*.1; do \
$(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN1_INSTALL_DIR)"; \
done
@echo "Installing and cross-linking C API (.3) docs to $(MAN3_INSTALL_DIR)/"
@for i in $(TOP_DIR)/doc/*.3; do \
$(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MAN3_INSTALL_DIR)"; \
done
@echo "Installing and cross-linking command (.n) docs to $(MANN_INSTALL_DIR)/";
@for i in $(TOP_DIR)/doc/*.n; do \
$(SHELL) $(UNIX_DIR)/installManPage $(MAN_FLAGS) $$i "$(MANN_INSTALL_DIR)"; \
done
# Public headers that define Tcl's API
TCL_PUBLIC_HEADERS = $(GENERIC_DIR)/tcl.h $(GENERIC_DIR)/tclDecls.h \
$(GENERIC_DIR)/tclOO.h $(GENERIC_DIR)/tclOODecls.h \
$(GENERIC_DIR)/tclPlatDecls.h $(GENERIC_DIR)/tclTomMath.h \
$(GENERIC_DIR)/tclTomMathDecls.h
# Private headers that define Tcl's internal API
TCL_PRIVATE_HEADERS = $(GENERIC_DIR)/tclInt.h $(GENERIC_DIR)/tclIntDecls.h \
$(GENERIC_DIR)/tclIntPlatDecls.h $(GENERIC_DIR)/tclPort.h \
$(GENERIC_DIR)/tclOOInt.h $(GENERIC_DIR)/tclOOIntDecls.h \
$(UNIX_DIR)/tclUnixPort.h
# Any other headers you find in the Tcl sources are purely part of Tcl's
# implementation, and aren't to be installed.
install-headers:
@for i in "$(INCLUDE_INSTALL_DIR)"; do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
fi; \
done
@echo "Installing header files to $(INCLUDE_INSTALL_DIR)/";
@for i in $(TCL_PUBLIC_HEADERS); do \
$(INSTALL_DATA) $$i "$(INCLUDE_INSTALL_DIR)"; \
done
# Optional target to install private headers
install-private-headers:
@for i in "$(PRIVATE_INCLUDE_INSTALL_DIR)"; do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(INSTALL_DATA_DIR) "$$i"; \
fi; \
done
@echo "Installing private header files to $(PRIVATE_INCLUDE_INSTALL_DIR)/";
@for i in $(TCL_PRIVATE_HEADERS); do \
$(INSTALL_DATA) $$i "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \
done
@if test -f tclConfig.h; then\
$(INSTALL_DATA) tclConfig.h "$(PRIVATE_INCLUDE_INSTALL_DIR)"; \
fi
#--------------------------------------------------------------------------
# Rules for how to compile C files
#--------------------------------------------------------------------------
|
| ︙ | ︙ | |||
1115 1116 1117 1118 1119 1120 1121 | REGHDRS = $(GENERIC_DIR)/regex.h $(GENERIC_DIR)/regguts.h \ $(GENERIC_DIR)/regcustom.h TCLREHDRS = $(GENERIC_DIR)/tclRegexp.h COMPILEHDR = $(GENERIC_DIR)/tclCompile.h FSHDR = $(GENERIC_DIR)/tclFileSystem.h IOHDR = $(GENERIC_DIR)/tclIO.h | | | 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 |
REGHDRS = $(GENERIC_DIR)/regex.h $(GENERIC_DIR)/regguts.h \
$(GENERIC_DIR)/regcustom.h
TCLREHDRS = $(GENERIC_DIR)/tclRegexp.h
COMPILEHDR = $(GENERIC_DIR)/tclCompile.h
FSHDR = $(GENERIC_DIR)/tclFileSystem.h
IOHDR = $(GENERIC_DIR)/tclIO.h
MATHHDRS = $(GENERIC_DIR)/tclTomMath.h $(GENERIC_DIR)/tclTomMathDecls.h
PARSEHDR = $(GENERIC_DIR)/tclParse.h
NREHDR = $(GENERIC_DIR)/tclInt.h
TRIMHDR = $(GENERIC_DIR)/tclStringTrim.h
TCL_LOCATIONS = -DTCL_LIBRARY="\"${TCL_LIBRARY}\"" \
-DTCL_PACKAGE_PATH="\"${TCL_PACKAGE_PATH}\""
|
| ︙ | ︙ | |||
1419 1420 1421 1422 1423 1424 1425 | tclZipfs.o: $(GENERIC_DIR)/tclZipfs.c $(CC) -c $(CC_SWITCHES) \ -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \ -DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \ -DCFG_RUNTIME_LIBDIR="\"$(libdir)\"" \ -DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY)\"" \ | | | 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 | tclZipfs.o: $(GENERIC_DIR)/tclZipfs.c $(CC) -c $(CC_SWITCHES) \ -DCFG_RUNTIME_DLLFILE="\"$(TCL_LIB_FILE)\"" \ -DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \ -DCFG_RUNTIME_LIBDIR="\"$(libdir)\"" \ -DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY)\"" \ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip \ $(GENERIC_DIR)/tclZipfs.c tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTest.c tclTestObj.o: $(GENERIC_DIR)/tclTestObj.c $(MATHHDRS) $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTestObj.c |
| ︙ | ︙ | |||
1452 1453 1454 1455 1456 1457 1458 | tclThreadTest.o: $(GENERIC_DIR)/tclThreadTest.c $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclThreadTest.c tclTomMathInterface.o: $(GENERIC_DIR)/tclTomMathInterface.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTomMathInterface.c | | | | | | | | 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 | tclThreadTest.o: $(GENERIC_DIR)/tclThreadTest.c $(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclThreadTest.c tclTomMathInterface.o: $(GENERIC_DIR)/tclTomMathInterface.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTomMathInterface.c bn_s_mp_reverse.o: $(TOMMATH_DIR)/bn_s_mp_reverse.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_reverse.c bn_s_mp_mul_digs_fast.o: $(TOMMATH_DIR)/bn_s_mp_mul_digs_fast.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_mul_digs_fast.c bn_s_mp_sqr_fast.o: $(TOMMATH_DIR)/bn_s_mp_sqr_fast.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_sqr_fast.c bn_mp_add.o: $(TOMMATH_DIR)/bn_mp_add.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_add.c bn_mp_add_d.o: $(TOMMATH_DIR)/bn_mp_add_d.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_add_d.c |
| ︙ | ︙ | |||
1515 1516 1517 1518 1519 1520 1521 | bn_mp_div_3.o: $(TOMMATH_DIR)/bn_mp_div_3.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_div_3.c bn_mp_exch.o: $(TOMMATH_DIR)/bn_mp_exch.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_exch.c | | | < < < < < < | | < < < < < < > > > < < < > > > | | | | > > > | 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 | bn_mp_div_3.o: $(TOMMATH_DIR)/bn_mp_div_3.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_div_3.c bn_mp_exch.o: $(TOMMATH_DIR)/bn_mp_exch.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_exch.c bn_mp_expt_u32.o: $(TOMMATH_DIR)/bn_mp_expt_u32.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_expt_u32.c bn_mp_get_mag_u64.o: $(TOMMATH_DIR)/bn_mp_get_mag_u64.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_get_mag_u64.c bn_mp_grow.o: $(TOMMATH_DIR)/bn_mp_grow.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_grow.c bn_mp_init.o: $(TOMMATH_DIR)/bn_mp_init.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init.c bn_mp_init_copy.o: $(TOMMATH_DIR)/bn_mp_init_copy.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_copy.c bn_mp_init_i64.o:$(TOMMATH_DIR)/bn_mp_init_i64.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_i64.c bn_mp_init_multi.o: $(TOMMATH_DIR)/bn_mp_init_multi.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_multi.c bn_mp_init_set.o: $(TOMMATH_DIR)/bn_mp_init_set.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_set.c bn_mp_init_size.o:$(TOMMATH_DIR)/bn_mp_init_size.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_size.c bn_mp_init_u64.o:$(TOMMATH_DIR)/bn_mp_init_u64.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_init_u64.c bn_s_mp_karatsuba_mul.o: $(TOMMATH_DIR)/bn_s_mp_karatsuba_mul.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_karatsuba_mul.c bn_s_mp_karatsuba_sqr.o: $(TOMMATH_DIR)/bn_s_mp_karatsuba_sqr.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_karatsuba_sqr.c bn_s_mp_balance_mul.o: $(TOMMATH_DIR)/bn_s_mp_balance_mul.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_balance_mul.c bn_mp_lshd.o: $(TOMMATH_DIR)/bn_mp_lshd.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_lshd.c bn_mp_mod.o: $(TOMMATH_DIR)/bn_mp_mod.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_mod.c |
| ︙ | ︙ | |||
1599 1600 1601 1602 1603 1604 1605 | bn_mp_read_radix.o: $(TOMMATH_DIR)/bn_mp_read_radix.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_read_radix.c bn_mp_rshd.o: $(TOMMATH_DIR)/bn_mp_rshd.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_rshd.c | | | | | < < < < < < | | < < < | | | | | | | | | 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 | bn_mp_read_radix.o: $(TOMMATH_DIR)/bn_mp_read_radix.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_read_radix.c bn_mp_rshd.o: $(TOMMATH_DIR)/bn_mp_rshd.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_rshd.c bn_mp_set_i64.o: $(TOMMATH_DIR)/bn_mp_set_i64.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_set_i64.c bn_mp_set_u64.o: $(TOMMATH_DIR)/bn_mp_set_u64.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_set_u64.c bn_mp_shrink.o: $(TOMMATH_DIR)/bn_mp_shrink.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_shrink.c bn_mp_sqr.o: $(TOMMATH_DIR)/bn_mp_sqr.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sqr.c bn_mp_sqrt.o: $(TOMMATH_DIR)/bn_mp_sqrt.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sqrt.c bn_mp_sub.o: $(TOMMATH_DIR)/bn_mp_sub.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sub.c bn_mp_sub_d.o: $(TOMMATH_DIR)/bn_mp_sub_d.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_sub_d.c bn_mp_signed_rsh.o: $(TOMMATH_DIR)/bn_mp_signed_rsh.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_signed_rsh.c bn_mp_to_ubin.o: $(TOMMATH_DIR)/bn_mp_to_ubin.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_to_ubin.c bn_s_mp_toom_mul.o: $(TOMMATH_DIR)/bn_s_mp_toom_mul.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_toom_mul.c bn_s_mp_toom_sqr.o: $(TOMMATH_DIR)/bn_s_mp_toom_sqr.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_s_mp_toom_sqr.c bn_mp_to_radix.o: $(TOMMATH_DIR)/bn_mp_to_radix.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_to_radix.c bn_mp_ubin_size.o: $(TOMMATH_DIR)/bn_mp_ubin_size.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_ubin_size.c bn_mp_xor.o: $(TOMMATH_DIR)/bn_mp_xor.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_xor.c bn_mp_zero.o: $(TOMMATH_DIR)/bn_mp_zero.c $(MATHHDRS) $(CC) -c $(CC_SWITCHES) $(TOMMATH_DIR)/bn_mp_zero.c |
| ︙ | ︙ | |||
1889 1890 1891 1892 1893 1894 1895 | # If PKG_DIR is changed to a different relative depth to the build dir, need # to adapt the ../.. relative paths below and at the top of configure.ac (we # cannot use absolute paths due to issues in nested configure when path to # build dir contains spaces). PKG_DIR = ./pkgs configure-packages: | | | | | | | | | 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 |
# If PKG_DIR is changed to a different relative depth to the build dir, need
# to adapt the ../.. relative paths below and at the top of configure.ac (we
# cannot use absolute paths due to issues in nested configure when path to
# build dir contains spaces).
PKG_DIR = ./pkgs
configure-packages:
@for i in $(PKGS_DIR)/*; do \
if [ -d $$i ] ; then \
if [ -x $$i/configure ] ; then \
pkg=`basename $$i`; \
echo "Configuring package '$$pkg'"; \
mkdir -p $(PKG_DIR)/$$pkg; \
if [ ! -f $(PKG_DIR)/$$pkg/Makefile ] ; then \
( cd $(PKG_DIR)/$$pkg; \
$$i/configure --with-tcl=../.. \
--with-tclinclude=$(GENERIC_DIR) \
$(PKG_CFG_ARGS) --libdir=$(PACKAGE_DIR) \
--enable-shared; ) || exit $$?; \
fi; \
fi; \
fi; \
done
packages: configure-packages ${STUB_LIB_FILE}
@for i in $(PKGS_DIR)/*; do \
if [ -d $$i ] ; then \
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \
echo "Building package '$$pkg'"; \
( cd $(PKG_DIR)/$$pkg; $(MAKE); ) || exit $$?; \
fi; \
fi; \
done
install-packages: packages
@for i in $(PKGS_DIR)/*; do \
if [ -d $$i ] ; then \
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \
echo "Installing package '$$pkg'"; \
( cd $(PKG_DIR)/$$pkg; $(MAKE) install \
"DESTDIR=$(INSTALL_ROOT)"; ) || exit $$?; \
fi; \
fi; \
done
test-packages: ${TCLTEST_EXE} packages
@for i in $(PKGS_DIR)/*; do \
if [ -d $$i ] ; then \
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \
echo "Testing package '$$pkg'"; \
( cd $(PKG_DIR)/$$pkg; $(MAKE) \
"@LD_LIBRARY_PATH_VAR@=../..:$${@LD_LIBRARY_PATH_VAR@}" \
"TCL_LIBRARY=${TCL_BUILDTIME_LIBRARY}" \
"TCLLIBPATH=../../pkgs" test \
"TCLSH_PROG=../../${TCLTEST_EXE}"; ) \
fi; \
fi; \
done
clean-packages:
@for i in $(PKGS_DIR)/*; do \
if [ -d $$i ] ; then \
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \
( cd $(PKG_DIR)/$$pkg; $(MAKE) clean; ) \
fi; \
fi; \
done
distclean-packages:
@for i in $(PKGS_DIR)/*; do \
if [ -d $$i ] ; then \
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \
( cd $(PKG_DIR)/$$pkg; $(MAKE) distclean; ) \
fi; \
rm -rf $(PKG_DIR)/$$pkg; \
fi; \
done; \
rm -rf $(PKG_DIR)
dist-packages: configure-packages
@rm -rf $(DISTROOT)/pkgs; \
mkdir -p $(DISTROOT)/pkgs; \
for i in $(PKGS_DIR)/*; do \
if [ -d $$i ] ; then \
pkg=`basename $$i`; \
if [ -f $(PKG_DIR)/$$pkg/Makefile ] ; then \
( cd $(PKG_DIR)/$$pkg; $(MAKE) dist \
"DIST_ROOT=$(DISTROOT)/pkgs"; ) || exit $$?; \
fi; \
fi; \
|
| ︙ | ︙ | |||
2006 2007 2008 2009 2010 2011 2012 | # -e '/TclDatenewstate:/d' -e '/#pragma/d' \ # -e '/#include <inttypes.h>/d' \ # -e '/#define YYNEW/s/malloc/TclDateAlloc/g' \ # -e '/#define YYENLARGE/,/realloc/s/realloc/TclDateRealloc/g' \ # <y.tab.c >$(GENERIC_DIR)/tclDate.c # rm y.tab.c | < < < < < < < < | | | | | | | | 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 |
# -e '/TclDatenewstate:/d' -e '/#pragma/d' \
# -e '/#include <inttypes.h>/d' \
# -e '/#define YYNEW/s/malloc/TclDateAlloc/g' \
# -e '/#define YYENLARGE/,/realloc/s/realloc/TclDateRealloc/g' \
# <y.tab.c >$(GENERIC_DIR)/tclDate.c
# rm y.tab.c
#
# Target to regenerate header files and stub files from the *.decls tables.
#
$(GENERIC_DIR)/tclStubInit.c: $(GENERIC_DIR)/tcl.decls \
$(GENERIC_DIR)/tclInt.decls $(GENERIC_DIR)/tclTomMath.decls
@echo "Warning: tclStubInit.c may be out of date."
@echo "Developers may want to run \"make genstubs\" to regenerate."
@echo "This warning can be safely ignored, do not report as a bug!"
$(GENERIC_DIR)/tclOOStubInit.c: $(GENERIC_DIR)/tclOO.decls
@echo "Warning: tclOOStubInit.c may be out of date."
@echo "Developers may want to run \"make genstubs\" to regenerate."
@echo "This warning can be safely ignored, do not report as a bug!"
$(GENERIC_DIR)/tclOOScript.h: $(TOOL_DIR)/tclOOScript.tcl
@echo "Warning: tclOOScript.h may be out of date."
@echo "Developers may want to run \"make genscript\" to regenerate."
@echo "This warning can be safely ignored, do not report as a bug!"
genstubs:
$(NATIVE_TCLSH) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \
$(GENERIC_DIR)/tcl.decls $(GENERIC_DIR)/tclInt.decls \
$(GENERIC_DIR)/tclTomMath.decls
$(NATIVE_TCLSH) $(TOOL_DIR)/genStubs.tcl $(GENERIC_DIR) \
$(GENERIC_DIR)/tclOO.decls
genscript:
$(NATIVE_TCLSH) $(TOOL_DIR)/makeHeader.tcl \
$(TOOL_DIR)/tclOOScript.tcl $(GENERIC_DIR)/tclOOScript.h
#
# Target to check that all exported functions have an entry in the stubs
# tables.
#
checkstubs: $(TCL_LIB_FILE)
-@for i in `nm -p $(TCL_LIB_FILE) \
| awk '$$2 ~ /^[TDBCS]$$/ { sub("^_", "", $$3); print $$3 }' \
| sort -n` ; do \
match=0; \
for j in $(TCL_DECLS); do \
if [ `grep -c "$$i *(" $$j` -gt 0 ] ; then \
match=1; \
fi; \
done; \
if [ $$match -eq 0 ] ; then \
echo $$i; \
fi; \
done
#
# Target to check that all public APIs which are not command implementations
# have an entry in section three of the distributed manpages.
#
checkdoc: $(TCL_LIB_FILE)
-@for i in `nm -p $(TCL_LIB_FILE) | awk '$$3 ~ /Tcl_/ { print $$3 }' \
| grep -Fv . | grep -v 'Cmd$$' | sort -n`; do \
match=0; \
i=`echo $$i | sed 's/^_//'`; \
for j in $(TOP_DIR)/doc/*.3; do \
if [ `grep '\-' $$j | grep -c $$i` -gt 0 ]; then \
match=1; \
fi; \
done; \
if [ $$match -eq 0 ]; then \
echo $$i; \
fi; \
done
#
# Target to check for proper usage of UCHAR macro.
#
|
| ︙ | ︙ | |||
2133 2134 2135 2136 2137 2138 2139 |
# 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)
| < < | | | | > | | > | | | | | | | | | > | | | > | | | | | | | | | | | | | | | < | | | | | | | | | < | | | | | | | | | | < < < < < | | | | | | | | 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 |
# distribution. DISTDIR must be an absolute path name.
#
DISTROOT = /tmp/dist
DISTNAME = tcl${VERSION}${PATCH_LEVEL}
ZIPNAME = tcl${MAJOR_VERSION}${MINOR_VERSION}${PATCH_LEVEL}-src.zip
DISTDIR = $(DISTROOT)/$(DISTNAME)
BUILTIN_PACKAGE_LIST = cookiejar http opt msgcat reg dde tcltest platform
$(UNIX_DIR)/configure: $(UNIX_DIR)/configure.ac $(UNIX_DIR)/tcl.m4 \
$(UNIX_DIR)/aclocal.m4
cd $(UNIX_DIR); autoconf
$(MAC_OSX_DIR)/configure: $(MAC_OSX_DIR)/configure.ac $(UNIX_DIR)/configure
cd $(MAC_OSX_DIR); autoconf
$(UNIX_DIR)/tclConfig.h.in: $(MAC_OSX_DIR)/configure
cd $(MAC_OSX_DIR); autoheader; touch $@
dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in \
$(MAC_OSX_DIR)/configure genstubs dist-packages ${NATIVE_TCLSH}
rm -rf $(DISTDIR)
mkdir -p $(DISTDIR)/unix
cp -p $(UNIX_DIR)/*.[ch] $(DISTDIR)/unix
cp $(UNIX_DIR)/Makefile.in $(DISTDIR)/unix
chmod 664 $(DISTDIR)/unix/Makefile.in
cp $(UNIX_DIR)/configure $(UNIX_DIR)/configure.ac \
$(UNIX_DIR)/tcl.m4 $(UNIX_DIR)/aclocal.m4 \
$(UNIX_DIR)/tclConfig.sh.in $(UNIX_DIR)/tclooConfig.sh \
$(UNIX_DIR)/install-sh \
$(UNIX_DIR)/README $(UNIX_DIR)/ldAix $(UNIX_DIR)/tcl.spec \
$(UNIX_DIR)/installManPage $(UNIX_DIR)/tclConfig.h.in \
$(UNIX_DIR)/tcl.pc.in $(DISTDIR)/unix
chmod 775 $(DISTDIR)/unix/configure $(DISTDIR)/unix/configure.ac
chmod 775 $(DISTDIR)/unix/ldAix
@mkdir $(DISTDIR)/generic
cp -p $(GENERIC_DIR)/*.[cdh] $(DISTDIR)/generic
cp -p $(GENERIC_DIR)/*.decls $(DISTDIR)/generic
cp -p $(GENERIC_DIR)/README $(DISTDIR)/generic
cp -p $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic
cp -p $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README.md \
$(TOP_DIR)/ChangeLog.[12]??? $(TOP_DIR)/license.terms \
$(DISTDIR)
@mkdir $(DISTDIR)/library
cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \
$(TOP_DIR)/library/manifest.txt \
$(TOP_DIR)/library/tclIndex $(DISTDIR)/library
@for i in $(BUILTIN_PACKAGE_LIST); do \
mkdir $(DISTDIR)/library/$$i;\
cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \
done
cp -p $(TOP_DIR)/library/cookiejar/*.txt.gz $(DISTDIR)/library/cookiejar
@mkdir $(DISTDIR)/library/encoding
cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding
@mkdir $(DISTDIR)/library/msgs
cp -p $(TOP_DIR)/library/msgs/*.msg $(DISTDIR)/library/msgs
@echo cp -r $(TOP_DIR)/library/tzdata $(DISTDIR)/library/tzdata
@( cd $(TOP_DIR); find library/tzdata -type f -print ) \
| ( cd $(TOP_DIR) ; xargs tar cf - ) \
| ( cd $(DISTDIR) ; tar xfp - )
@mkdir $(DISTDIR)/doc
cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/doc/*.[13n] \
$(TOP_DIR)/doc/man.macros $(DISTDIR)/doc
@mkdir $(DISTDIR)/compat
cp -p $(TOP_DIR)/license.terms $(COMPAT_DIR)/*.[ch] \
$(COMPAT_DIR)/README $(DISTDIR)/compat
@mkdir $(DISTDIR)/compat/zlib
@echo cp -r $(COMPAT_DIR)/zlib $(DISTDIR)/compat/zlib
@( cd $(COMPAT_DIR)/zlib; find . -type f -print ) \
| ( cd $(COMPAT_DIR)/zlib ; xargs tar cf - ) \
| ( cd $(DISTDIR)/compat/zlib ; tar xfp - )
@mkdir $(DISTDIR)/tests
cp -p $(TOP_DIR)/license.terms $(DISTDIR)/tests
cp -p $(TOP_DIR)/tests/*.test $(TOP_DIR)/tests/README \
$(TOP_DIR)/tests/httpd $(TOP_DIR)/tests/*.tcl \
$(DISTDIR)/tests
@mkdir $(DISTDIR)/win
cp $(TOP_DIR)/win/Makefile.in $(DISTDIR)/win
cp $(TOP_DIR)/win/configure.ac $(TOP_DIR)/win/configure \
$(TOP_DIR)/win/tclConfig.sh.in $(TOP_DIR)/win/tclooConfig.sh \
$(TOP_DIR)/win/tcl.m4 $(TOP_DIR)/win/aclocal.m4 \
$(TOP_DIR)/win/tclsh.exe.manifest.in \
$(DISTDIR)/win
cp -p $(TOP_DIR)/win/*.[ch] $(TOP_DIR)/win/*.ico $(TOP_DIR)/win/*.rc \
$(DISTDIR)/win
cp -p $(TOP_DIR)/win/*.bat $(DISTDIR)/win
cp -p $(TOP_DIR)/win/*.vc $(DISTDIR)/win
cp -p $(TOP_DIR)/win/tcl.hpj.in $(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 \
$(MAC_OSX_DIR)/configure $(DISTDIR)/macosx
cp -p $(TOP_DIR)/license.terms $(DISTDIR)/macosx
@mkdir $(DISTDIR)/macosx/Tcl.xcode
cp -p $(MAC_OSX_DIR)/Tcl.xcode/project.pbxproj \
$(MAC_OSX_DIR)/Tcl.xcode/default.pbxuser \
$(DISTDIR)/macosx/Tcl.xcode
@mkdir $(DISTDIR)/macosx/Tcl.xcodeproj
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)/Makefile.in $(TOOL_DIR)/README \
$(TOOL_DIR)/configure $(TOOL_DIR)/configure.ac \
$(TOOL_DIR)/*.tcl $(TOOL_DIR)/man2tcl.c \
$(TOOL_DIR)/*.bmp $(TOOL_DIR)/tcl.hpj.in \
$(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"; \
done
alldist: dist
rm -f $(DISTROOT)/$(DISTNAME)-src.tar.gz $(DISTROOT)/$(ZIPNAME)
( cd $(DISTROOT); \
tar cf $(DISTNAME)-src.tar $(DISTNAME); \
gzip -9 $(DISTNAME)-src.tar; \
zip -qr8 $(ZIPNAME) $(DISTNAME) )
#--------------------------------------------------------------------------
# This target creates the HTML folder for Tcl & Tk and places it in
# DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool
# workspace. It depends on the Tcl & Tk being in directories called tcl8.* &
# tk8.* up two directories from the TOOL_DIR.
#
# Note that for platforms where this is important, it is more common to use a
# build of this HTML documentation that has already been placed online. As
# such, this rule is not guaranteed to work well on all systems; it only needs
# to function on those of the Tcl/Tk maintainers.
#
|
| ︙ | ︙ |
Changes to unix/README.
| ︙ | ︙ | |||
159 160 161 162 163 164 165 | should then see a printout of the test files processed. If any errors occur, you'll see a much more substantial printout for each error. See the README file in the "tests" directory for more information on the test suite. Note: don't run the tests as superuser: this will cause several of them to fail. If a test is failing consistently, please send us a bug report with as much detail as you can manage to our tracker: | | | 159 160 161 162 163 164 165 166 167 | should then see a printout of the test files processed. If any errors occur, you'll see a much more substantial printout for each error. See the README file in the "tests" directory for more information on the test suite. Note: don't run the tests as superuser: this will cause several of them to fail. If a test is failing consistently, please send us a bug report with as much detail as you can manage to our tracker: https://core.tcl-lang.org/tcl/reportlist |
Changes to unix/configure.
1 2 | #! /bin/sh # Guess values for system-dependent variables and create Makefiles. | | | 1 2 3 4 5 6 7 8 9 10 | #! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.69 for tcl 8.7. # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. |
| ︙ | ︙ | |||
573 574 575 576 577 578 579 | subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME='tcl' PACKAGE_TARNAME='tcl' | | | | 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 | subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME='tcl' PACKAGE_TARNAME='tcl' PACKAGE_VERSION='8.7' PACKAGE_STRING='tcl 8.7' PACKAGE_BUGREPORT='' PACKAGE_URL='' # Factoring default headers for most tests. ac_includes_default="\ #include <stdio.h> #ifdef HAVE_SYS_TYPES_H |
| ︙ | ︙ | |||
701 702 703 704 705 706 707 708 709 710 711 712 713 714 | PLAT_OBJS DL_OBJS DL_LIBS TCL_LIBS LIBOBJS AR RANLIB ZLIB_INCLUDE ZLIB_SRCS ZLIB_OBJS TCLSH_PROG SHARED_BUILD EGREP GREP | > > > | 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 | PLAT_OBJS DL_OBJS DL_LIBS TCL_LIBS LIBOBJS AR RANLIB TOMMATH_INCLUDE TOMMATH_SRCS TOMMATH_OBJS ZLIB_INCLUDE ZLIB_SRCS ZLIB_OBJS TCLSH_PROG SHARED_BUILD EGREP GREP |
| ︙ | ︙ | |||
764 765 766 767 768 769 770 771 772 773 774 775 776 777 | ac_user_opts=' enable_option_checking enable_man_symlinks enable_man_compression enable_man_suffix with_encoding enable_shared enable_64bit enable_64bit_vis enable_rpath enable_corefoundation enable_load enable_symbols enable_langinfo | > | 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 | ac_user_opts=' enable_option_checking enable_man_symlinks enable_man_compression enable_man_suffix with_encoding enable_shared with_system_libtommath enable_64bit enable_64bit_vis enable_rpath enable_corefoundation enable_load enable_symbols enable_langinfo |
| ︙ | ︙ | |||
1326 1327 1328 1329 1330 1331 1332 | # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF | | | 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 | # # Report the --help message. # if test "$ac_init_help" = "long"; then # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF \`configure' configures tcl 8.7 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... To assign environment variables (e.g., CC, CFLAGS...), specify them as VAR=VALUE. See below for descriptions of some of the useful variables. Defaults for the options are specified in brackets. |
| ︙ | ︙ | |||
1387 1388 1389 1390 1391 1392 1393 | cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in | | | 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 |
cat <<\_ACEOF
_ACEOF
fi
if test -n "$ac_init_help"; then
case $ac_init_help in
short | recursive ) echo "Configuration of tcl 8.7:";;
esac
cat <<\_ACEOF
Optional Features:
--disable-option-checking ignore unrecognized --enable/--with options
--disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no)
--enable-FEATURE[=ARG] include FEATURE [ARG=yes]
|
| ︙ | ︙ | |||
1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 |
(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:
iso8859-1)
--with-tzdata install timezone data (default: autodetect)
Some influential environment variables:
CC C compiler command
CFLAGS C compiler flags
LDFLAGS linker flags, e.g. -L<lib dir> if you have libraries in a
nonstandard directory <lib dir>
| > > > | 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 |
(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:
iso8859-1)
--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
CFLAGS C compiler flags
LDFLAGS linker flags, e.g. -L<lib dir> if you have libraries in a
nonstandard directory <lib dir>
|
| ︙ | ︙ | |||
1501 1502 1503 1504 1505 1506 1507 |
cd "$ac_pwd" || { ac_status=$?; break; }
done
fi
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
| | | 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 |
cd "$ac_pwd" || { ac_status=$?; break; }
done
fi
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
tcl configure 8.7
generated by GNU Autoconf 2.69
Copyright (C) 2012 Free Software Foundation, Inc.
This configure script is free software; the Free Software Foundation
gives unlimited permission to copy, distribute and modify it.
_ACEOF
exit
|
| ︙ | ︙ | |||
2023 2024 2025 2026 2027 2028 2029 |
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
} # ac_fn_c_check_member
cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
| | | 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 |
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
} # ac_fn_c_check_member
cat >config.log <<_ACEOF
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
It was created by tcl $as_me 8.7, which was
generated by GNU Autoconf 2.69. Invocation command line was
$ $0 $@
_ACEOF
exec 5>>config.log
{
|
| ︙ | ︙ | |||
2375 2376 2377 2378 2379 2380 2381 | ac_compiler_gnu=$ac_cv_c_compiler_gnu | | | | | | 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 |
ac_compiler_gnu=$ac_cv_c_compiler_gnu
TCL_VERSION=8.7
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=7
TCL_PATCH_LEVEL="a4"
VERSION=${TCL_VERSION}
EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"}
EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"}
#------------------------------------------------------------------------
# Setup configure arguments for bundled packages
|
| ︙ | ︙ | |||
3329 3330 3331 3332 3333 3334 3335 |
;;
esac
#--------------------------------------------------------------------
# Supply substitutes for missing POSIX header files. Special notes:
| | | | 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 |
;;
esac
#--------------------------------------------------------------------
# Supply substitutes for missing POSIX header files. Special notes:
# - stdlib.h doesn't define strtol or strtoul in some versions
# of SunOS
# - some versions of string.h don't declare procedures such
# as strstr
# Do this early, otherwise an autoconf bug throws errors on configure
#--------------------------------------------------------------------
ac_ext=c
ac_cpp='$CPP $CPPFLAGS'
|
| ︙ | ︙ | |||
3816 3817 3818 3819 3820 3821 3822 | /* end confdefs.h. */ #include <stdlib.h> _ACEOF if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | $EGREP "strtoul" >/dev/null 2>&1; then : | < < < < < < < < < < < < < | 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 |
/* end confdefs.h. */
#include <stdlib.h>
_ACEOF
if (eval "$ac_cpp conftest.$ac_ext") 2>&5 |
$EGREP "strtoul" >/dev/null 2>&1; then :
else
tcl_ok=0
fi
rm -f conftest*
if test $tcl_ok = 0; then
|
| ︙ | ︙ | |||
4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 |
ZLIB_INCLUDE=-I\${ZLIB_DIR}
fi
$as_echo "#define HAVE_ZLIB 1" >>confdefs.h
#--------------------------------------------------------------------
# The statements below define a collection of compile flags. This
# macro depends on the value of SHARED_BUILD, and should be called
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 4685 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 4701 4702 4703 4704 4705 4706 4707 4708 4709 4710 4711 4712 4713 4714 4715 4716 4717 4718 4719 4720 4721 4722 4723 4724 4725 4726 4727 4728 4729 4730 4731 4732 4733 4734 4735 4736 4737 4738 4739 4740 4741 4742 4743 4744 4745 4746 4747 4748 4749 4750 4751 |
ZLIB_INCLUDE=-I\${ZLIB_DIR}
fi
$as_echo "#define HAVE_ZLIB 1" >>confdefs.h
#------------------------------------------------------------------------
# Add stuff for libtommath
libtommath_ok=yes
# Check whether --with-system-libtommath was given.
if test "${with_system_libtommath+set}" = set; then :
withval=$with_system_libtommath; libtommath_ok=${withval}
fi
if test x"${libtommath_ok}" = x -o x"${libtommath_ok}" != xno; then
ac_fn_c_check_header_mongrel "$LINENO" "tommath.h" "ac_cv_header_tommath_h" "$ac_includes_default"
if test "x$ac_cv_header_tommath_h" = xyes; then :
ac_fn_c_check_type "$LINENO" "mp_int" "ac_cv_type_mp_int" "#include <tommath.h>
"
if test "x$ac_cv_type_mp_int" = xyes; then :
else
libtommath_ok=no
fi
else
libtommath_ok=no
fi
if test $libtommath_ok = yes; then :
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for mp_log_u32 in -ltommath" >&5
$as_echo_n "checking for mp_log_u32 in -ltommath... " >&6; }
if ${ac_cv_lib_tommath_mp_log_u32+:} false; then :
$as_echo_n "(cached) " >&6
else
ac_check_lib_save_LIBS=$LIBS
LIBS="-ltommath $LIBS"
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
/* Override any GCC internal prototype to avoid an error.
Use char because int might match the return type of a GCC
builtin and then its argument prototype would still apply. */
#ifdef __cplusplus
extern "C"
#endif
char mp_log_u32 ();
int
main ()
{
return mp_log_u32 ();
;
return 0;
}
_ACEOF
if ac_fn_c_try_link "$LINENO"; then :
ac_cv_lib_tommath_mp_log_u32=yes
else
ac_cv_lib_tommath_mp_log_u32=no
fi
rm -f core conftest.err conftest.$ac_objext \
conftest$ac_exeext conftest.$ac_ext
LIBS=$ac_check_lib_save_LIBS
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_tommath_mp_log_u32" >&5
$as_echo "$ac_cv_lib_tommath_mp_log_u32" >&6; }
if test "x$ac_cv_lib_tommath_mp_log_u32" = xyes; then :
MATH_LIBS="$MATH_LIBS -ltommath"
else
libtommath_ok=no
fi
fi
fi
if test $libtommath_ok = yes; then :
$as_echo "#define TCL_WITH_EXTERNAL_TOMMATH 1" >>confdefs.h
else
TOMMATH_OBJS=\${TOMMATH_OBJS}
TOMMATH_SRCS=\${TOMMATH_SRCS}
TOMMATH_INCLUDE=-I\${TOMMATH_DIR}
fi
#--------------------------------------------------------------------
# The statements below define a collection of compile flags. This
# macro depends on the value of SHARED_BUILD, and should be called
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------
|
| ︙ | ︙ | |||
4866 4867 4868 4869 4870 4871 4872 4873 4874 4875 4876 4877 4878 4879 |
{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: can't find uname command" >&5
$as_echo "$as_me: WARNING: can't find uname command" >&2;}
tcl_cv_sys_version=unknown
else
if test "`uname -s`" = "AIX" ; then
tcl_cv_sys_version=AIX-`uname -v`.`uname -r`
fi
fi
fi
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_sys_version" >&5
$as_echo "$tcl_cv_sys_version" >&6; }
system=$tcl_cv_sys_version
| > > > | 4952 4953 4954 4955 4956 4957 4958 4959 4960 4961 4962 4963 4964 4965 4966 4967 4968 |
{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: can't find uname command" >&5
$as_echo "$as_me: WARNING: can't find uname command" >&2;}
tcl_cv_sys_version=unknown
else
if test "`uname -s`" = "AIX" ; then
tcl_cv_sys_version=AIX-`uname -v`.`uname -r`
fi
if test "`uname -s`" = "NetBSD" -a -f /etc/debian_version ; then
tcl_cv_sys_version=NetBSD-Debian
fi
fi
fi
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_sys_version" >&5
$as_echo "$tcl_cv_sys_version" >&6; }
system=$tcl_cv_sys_version
|
| ︙ | ︙ | |||
4943 4944 4945 4946 4947 4948 4949 |
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
| > > > > > > > > | | 5032 5033 5034 5035 5036 5037 5038 5039 5040 5041 5042 5043 5044 5045 5046 5047 5048 5049 5050 5051 5052 5053 5054 |
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 -Wwrite-strings -Wpointer-arith"
case "${CC}" in
*++|*++-*)
;;
*)
CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -Wdeclaration-after-statement"
;;
esac
else
CFLAGS_OPTIMIZE=-O
CFLAGS_WARNING=""
fi
|
| ︙ | ︙ | |||
5210 5211 5212 5213 5214 5215 5216 | DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; CYGWIN_*) | | | | 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 |
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -export-dynamic"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
CYGWIN_*)
SHLIB_CFLAGS="-fno-common"
SHLIB_LD='${CC} -shared'
SHLIB_SUFFIX=".dll"
DL_OBJS="tclLoadDl.o"
PLAT_OBJS='${CYGWIN_OBJS}'
PLAT_SRCS='${CYGWIN_SRCS}'
DL_LIBS="-ldl"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
TCL_NEEDS_EXP_FILE=1
TCL_EXPORT_FILE_SUFFIX='${VERSION}.dll.a'
SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$@.a"
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for Cygwin version of gcc" >&5
$as_echo_n "checking for Cygwin version of gcc... " >&6; }
if ${ac_cv_cygwin+:} false; then :
$as_echo_n "(cached) " >&6
else
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
|
| ︙ | ︙ | |||
5423 5424 5425 5426 5427 5428 5429 |
case `${CC} -dumpmachine` in
hppa64*)
# 64-bit gcc in use. Fix flags for GNU ld.
do64bit_ok=yes
SHLIB_LD='${CC} -shared'
if test $doRpath = yes; then :
| | | 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 |
case `${CC} -dumpmachine` in
hppa64*)
# 64-bit gcc in use. Fix flags for GNU ld.
do64bit_ok=yes
SHLIB_LD='${CC} -shared'
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
;;
*)
{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: 64bit mode not supported with GCC on $system" >&5
$as_echo "$as_me: WARNING: 64bit mode not supported with GCC on $system" >&2;}
;;
|
| ︙ | ︙ | |||
5513 5514 5515 5516 5517 5518 5519 | *" mkstemp.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext" ;; esac if test $doRpath = yes; then : | | | | 5610 5611 5612 5613 5614 5615 5616 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 5632 5633 5634 5635 5636 5637 5638 5639 5640 5641 5642 |
*" mkstemp.$ac_objext "* ) ;;
*) LIBOBJS="$LIBOBJS mkstemp.$ac_objext"
;;
esac
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
fi
;;
IRIX-6.*)
SHLIB_CFLAGS=""
SHLIB_LD="ld -n32 -shared -rdata_shared"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
case " $LIBOBJS " in
*" mkstemp.$ac_objext "* ) ;;
*) LIBOBJS="$LIBOBJS mkstemp.$ac_objext"
;;
esac
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
fi
if test "$GCC" = yes; then :
CFLAGS="$CFLAGS -mabi=n32"
LDFLAGS="$LDFLAGS -mabi=n32"
|
| ︙ | ︙ | |||
5568 5569 5570 5571 5572 5573 5574 | *" mkstemp.$ac_objext "* ) ;; *) LIBOBJS="$LIBOBJS mkstemp.$ac_objext" ;; esac if test $doRpath = yes; then : | | | 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 |
*" mkstemp.$ac_objext "* ) ;;
*) LIBOBJS="$LIBOBJS mkstemp.$ac_objext"
;;
esac
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
fi
# Check to enable 64-bit flags for compiler/linker
if test "$do64bit" = yes; then :
|
| ︙ | ︙ | |||
5593 5594 5595 5596 5597 5598 5599 | LDFLAGS_ARCH="-64" fi fi ;; Linux*|GNU*|NetBSD-Debian) | | | | 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 |
LDFLAGS_ARCH="-64"
fi
fi
;;
Linux*|GNU*|NetBSD-Debian)
SHLIB_CFLAGS="-fPIC -fno-common"
SHLIB_SUFFIX=".so"
CFLAGS_OPTIMIZE="-O2"
# egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings
# when you inline the string and math operations. Turn this off to
# get rid of the warnings.
#CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES"
SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -Wl,--export-dynamic"
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
if test "`uname -m`" = "alpha"; then :
CFLAGS="$CFLAGS -mieee"
fi
if test $do64bit = yes; then :
|
| ︙ | ︙ | |||
5656 5657 5658 5659 5660 5661 5662 | do64bit_ok=yes fi fi # The combo of gcc + glibc has a bug related to inlining of | | | | | | 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 |
do64bit_ok=yes
fi
fi
# The combo of gcc + glibc has a bug related to inlining of
# functions like strtol()/strtoul(). The -fno-builtin flag should address
# this problem but it does not work. The -fno-inline flag is kind
# of overkill but it works. Disable inlining only when one of the
# files in compat/*.c is being linked in.
if test x"${USE_COMPAT}" != x; then :
CFLAGS="$CFLAGS -fno-inline"
fi
;;
Lynx*)
SHLIB_CFLAGS="-fPIC"
SHLIB_SUFFIX=".so"
CFLAGS_OPTIMIZE=-02
SHLIB_LD='${CC} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-mshared -ldl"
LD_FLAGS="-Wl,--export-dynamic"
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
;;
OpenBSD-*)
arch=`arch -s`
case "$arch" in
alpha|sparc64)
SHLIB_CFLAGS="-fPIC"
;;
*)
SHLIB_CFLAGS="-fpic"
;;
esac
SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}'
LDFLAGS="-Wl,-export-dynamic"
CFLAGS_OPTIMIZE="-O2"
# On OpenBSD: Compile with -pthread
# Don't link with -lpthread
|
| ︙ | ︙ | |||
5719 5720 5721 5722 5723 5724 5725 |
SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -export-dynamic"
if test $doRpath = yes; then :
| | < < | | | 5816 5817 5818 5819 5820 5821 5822 5823 5824 5825 5826 5827 5828 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 5847 5848 |
SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -export-dynamic"
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
# The -pthread needs to go in the CFLAGS, not LIBS
LIBS=`echo $LIBS | sed s/-pthread//`
CFLAGS="$CFLAGS -pthread"
LDFLAGS="$LDFLAGS -pthread"
;;
DragonFly-*|FreeBSD-*)
# This configuration from FreeBSD Ports.
SHLIB_LD="${CC} -shared"
SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,-soname,\$@"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
fi
# The -pthread needs to go in the LDFLAGS, not LIBS
LIBS=`echo $LIBS | sed s/-pthread//`
CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
LDFLAGS="$LDFLAGS $PTHREAD_LIBS"
case $system in
FreeBSD-3.*)
|
| ︙ | ︙ | |||
5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 | fi if test "$tcl_cv_cc_visibility_hidden" != yes; then : $as_echo "#define MODULE_SCOPE __private_extern__" >>confdefs.h fi CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH" $as_echo "#define MAC_OSX_TCL 1" >>confdefs.h | > | 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 | fi if test "$tcl_cv_cc_visibility_hidden" != yes; then : $as_echo "#define MODULE_SCOPE __private_extern__" >>confdefs.h tcl_cv_cc_visibility_hidden=yes fi CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH" $as_echo "#define MAC_OSX_TCL 1" >>confdefs.h |
| ︙ | ︙ | |||
6090 6091 6092 6093 6094 6095 6096 | fi SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" if test $doRpath = yes; then : | | | 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 |
fi
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
if test $doRpath = yes; then :
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'
fi
if test "$GCC" = yes; then :
CFLAGS="$CFLAGS -mieee"
else
CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee"
|
| ︙ | ︙ | |||
6117 6118 6119 6120 6121 6122 6123 | LDFLAGS="$LDFLAGS -pthread" fi ;; QNX-6*) # QNX RTP # This may work for all QNX, but it was only reported for v6. | < | | | | | 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 6239 6240 6241 6242 6243 6244 6245 6246 6247 6248 | LDFLAGS="$LDFLAGS -pthread" fi ;; QNX-6*) # QNX RTP # This may work for all QNX, but it was only reported for v6. SHLIB_LD="ld -Bshareable -x" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" # dlopen is in -lc on QNX DL_LIBS="" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; SCO_SV-3.2*) # Note, dlopen is available only on SCO 3.2.5 and greater. However, # this test works, since "uname -s" was non-standard in 3.2.4 and # below. if test "$GCC" = yes; then : SHLIB_CFLAGS="-fPIC -melf" LDFLAGS="$LDFLAGS -melf -Wl,-Bexport" else SHLIB_CFLAGS="-Kpic -belf" LDFLAGS="$LDFLAGS -belf -Wl,-Bexport" fi SHLIB_LD="ld -G" SHLIB_LD_LIBS="" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" |
| ︙ | ︙ | |||
6461 6462 6463 6464 6465 6466 6467 6468 |
if test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes; then :
case $system in
AIX-*) ;;
BSD/OS*) ;;
CYGWIN_*) ;;
IRIX*) ;;
| > > > | | | 6556 6557 6558 6559 6560 6561 6562 6563 6564 6565 6566 6567 6568 6569 6570 6571 6572 6573 6574 6575 |
if test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes; then :
case $system in
AIX-*) ;;
BSD/OS*) ;;
CYGWIN_*) ;;
HP_UX*) ;;
Darwin-*) ;;
IRIX*) ;;
Linux*|GNU*) ;;
NetBSD-*|OpenBSD-*) ;;
OSF1-V*) ;;
SCO_SV-3.2*) ;;
*) SHLIB_CFLAGS="-fPIC" ;;
esac
fi
if test "$tcl_cv_cc_visibility_hidden" != yes; then :
|
| ︙ | ︙ | |||
6490 6491 6492 6493 6494 6495 6496 |
UNSHARED_LIB_SUFFIX='${VERSION}.a'
fi
DLL_INSTALL_DIR="\$(LIB_INSTALL_DIR)"
if test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""; then :
LIB_SUFFIX=${SHARED_LIB_SUFFIX}
| | | 6588 6589 6590 6591 6592 6593 6594 6595 6596 6597 6598 6599 6600 6601 6602 |
UNSHARED_LIB_SUFFIX='${VERSION}.a'
fi
DLL_INSTALL_DIR="\$(LIB_INSTALL_DIR)"
if test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""; then :
LIB_SUFFIX=${SHARED_LIB_SUFFIX}
MAKE_LIB='${SHLIB_LD} -o $@ ${OBJS} ${LDFLAGS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}'
if test "${SHLIB_SUFFIX}" = ".dll"; then :
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)";if test -f $(LIB_FILE).a; then $(INSTALL_DATA) $(LIB_FILE).a "$(LIB_INSTALL_DIR)"; fi;'
DLL_INSTALL_DIR="\$(BIN_INSTALL_DIR)"
else
|
| ︙ | ︙ | |||
6578 6579 6580 6581 6582 6583 6584 6585 6586 6587 6588 6589 6590 6591 |
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cast_to_union" >&5
$as_echo "$tcl_cv_cast_to_union" >&6; }
if test "$tcl_cv_cast_to_union" = "yes"; then
$as_echo "#define HAVE_CAST_TO_UNION 1" >>confdefs.h
fi
# FIXME: This subst was left in only because the TCL_DL_LIBS
# entry in tclConfig.sh uses it. It is not clear why someone
# would use TCL_DL_LIBS instead of TCL_LIBS.
| > > > > > > > > > | 6676 6677 6678 6679 6680 6681 6682 6683 6684 6685 6686 6687 6688 6689 6690 6691 6692 6693 6694 6695 6696 6697 6698 |
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_cast_to_union" >&5
$as_echo "$tcl_cv_cast_to_union" >&6; }
if test "$tcl_cv_cast_to_union" = "yes"; then
$as_echo "#define HAVE_CAST_TO_UNION 1" >>confdefs.h
fi
ac_fn_c_check_header_mongrel "$LINENO" "stdbool.h" "ac_cv_header_stdbool_h" "$ac_includes_default"
if test "x$ac_cv_header_stdbool_h" = xyes; then :
$as_echo "#define HAVE_STDBOOL_H 1" >>confdefs.h
fi
# FIXME: This subst was left in only because the TCL_DL_LIBS
# entry in tclConfig.sh uses it. It is not clear why someone
# would use TCL_DL_LIBS instead of TCL_LIBS.
|
| ︙ | ︙ | |||
6631 6632 6633 6634 6635 6636 6637 |
if test "${enable_symbols+set}" = set; then :
enableval=$enable_symbols; tcl_ok=$enableval
else
tcl_ok=no
fi
# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
| < | 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 6749 6750 6751 |
if test "${enable_symbols+set}" = set; then :
enableval=$enable_symbols; tcl_ok=$enableval
else
tcl_ok=no
fi
# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
if test "$tcl_ok" = "no"; then
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
$as_echo "#define NDEBUG 1" >>confdefs.h
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5
|
| ︙ | ︙ | |||
7935 7936 7937 7938 7939 7940 7941 | $as_echo "#define HAVE_MTSAFE_GETHOSTBYNAME 1" >>confdefs.h $as_echo "#define HAVE_MTSAFE_GETHOSTBYADDR 1" >>confdefs.h else | > > > > > > > > > > > > > > > > > > > > > > > | | 8041 8042 8043 8044 8045 8046 8047 8048 8049 8050 8051 8052 8053 8054 8055 8056 8057 8058 8059 8060 8061 8062 8063 8064 8065 8066 8067 8068 8069 8070 8071 8072 8073 8074 8075 8076 8077 8078 |
$as_echo "#define HAVE_MTSAFE_GETHOSTBYNAME 1" >>confdefs.h
$as_echo "#define HAVE_MTSAFE_GETHOSTBYADDR 1" >>confdefs.h
else
# Avoids picking hidden internal symbol from libc
ac_fn_c_check_decl "$LINENO" "gethostbyname_r" "ac_cv_have_decl_gethostbyname_r" "#include <netdb.h>
"
if test "x$ac_cv_have_decl_gethostbyname_r" = xyes; then :
ac_have_decl=1
else
ac_have_decl=0
fi
cat >>confdefs.h <<_ACEOF
#define HAVE_DECL_GETHOSTBYNAME_R $ac_have_decl
_ACEOF
if test $ac_have_decl = 1; then :
tcl_cv_api_gethostbyname_r=yes
else
tcl_cv_api_gethostbyname_r=no
fi
if test "$tcl_cv_api_gethostbyname_r" = yes; then
ac_fn_c_check_func "$LINENO" "gethostbyname_r" "ac_cv_func_gethostbyname_r"
if test "x$ac_cv_func_gethostbyname_r" = xyes; then :
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for gethostbyname_r with 6 args" >&5
$as_echo_n "checking for gethostbyname_r with 6 args... " >&6; }
if ${tcl_cv_api_gethostbyname_r_6+:} false; then :
$as_echo_n "(cached) " >&6
else
|
| ︙ | ︙ | |||
8072 8073 8074 8075 8076 8077 8078 |
$as_echo "#define HAVE_GETHOSTBYNAME_R 1" >>confdefs.h
fi
fi
| > > > > > > > > > > > > > > > > > > > > > > > > > | | 8201 8202 8203 8204 8205 8206 8207 8208 8209 8210 8211 8212 8213 8214 8215 8216 8217 8218 8219 8220 8221 8222 8223 8224 8225 8226 8227 8228 8229 8230 8231 8232 8233 8234 8235 8236 8237 8238 8239 8240 |
$as_echo "#define HAVE_GETHOSTBYNAME_R 1" >>confdefs.h
fi
fi
fi
# Avoids picking hidden internal symbol from libc
ac_fn_c_check_decl "$LINENO" "gethostbyaddr_r" "ac_cv_have_decl_gethostbyaddr_r" "#include <netdb.h>
"
if test "x$ac_cv_have_decl_gethostbyaddr_r" = xyes; then :
ac_have_decl=1
else
ac_have_decl=0
fi
cat >>confdefs.h <<_ACEOF
#define HAVE_DECL_GETHOSTBYADDR_R $ac_have_decl
_ACEOF
if test $ac_have_decl = 1; then :
tcl_cv_api_gethostbyaddr_r=yes
else
tcl_cv_api_gethostbyaddr_r=no
fi
if test "$tcl_cv_api_gethostbyaddr_r" = yes; then
ac_fn_c_check_func "$LINENO" "gethostbyaddr_r" "ac_cv_func_gethostbyaddr_r"
if test "x$ac_cv_func_gethostbyaddr_r" = xyes; then :
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for gethostbyaddr_r with 7 args" >&5
$as_echo_n "checking for gethostbyaddr_r with 7 args... " >&6; }
if ${tcl_cv_api_gethostbyaddr_r_7+:} false; then :
$as_echo_n "(cached) " >&6
else
|
| ︙ | ︙ | |||
8173 8174 8175 8176 8177 8178 8179 8180 8181 8182 8183 8184 8185 8186 |
if test "$tcl_ok" = yes; then
$as_echo "#define HAVE_GETHOSTBYADDR_R 1" >>confdefs.h
fi
fi
fi
#---------------------------------------------------------------------------
# Check for serial port interface.
#
# termios.h is present on all POSIX systems.
| > > | 8327 8328 8329 8330 8331 8332 8333 8334 8335 8336 8337 8338 8339 8340 8341 8342 |
if test "$tcl_ok" = yes; then
$as_echo "#define HAVE_GETHOSTBYADDR_R 1" >>confdefs.h
fi
fi
fi
fi
#---------------------------------------------------------------------------
# Check for serial port interface.
#
# termios.h is present on all POSIX systems.
|
| ︙ | ︙ | |||
9785 9786 9787 9788 9789 9790 9791 9792 9793 9794 9795 9796 9797 9798 |
{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: can't find uname command" >&5
$as_echo "$as_me: WARNING: can't find uname command" >&2;}
tcl_cv_sys_version=unknown
else
if test "`uname -s`" = "AIX" ; then
tcl_cv_sys_version=AIX-`uname -v`.`uname -r`
fi
fi
fi
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_sys_version" >&5
$as_echo "$tcl_cv_sys_version" >&6; }
system=$tcl_cv_sys_version
| > > > | 9941 9942 9943 9944 9945 9946 9947 9948 9949 9950 9951 9952 9953 9954 9955 9956 9957 |
{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: can't find uname command" >&5
$as_echo "$as_me: WARNING: can't find uname command" >&2;}
tcl_cv_sys_version=unknown
else
if test "`uname -s`" = "AIX" ; then
tcl_cv_sys_version=AIX-`uname -v`.`uname -r`
fi
if test "`uname -s`" = "NetBSD" -a -f /etc/debian_version ; then
tcl_cv_sys_version=NetBSD-Debian
fi
fi
fi
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_sys_version" >&5
$as_echo "$tcl_cv_sys_version" >&6; }
system=$tcl_cv_sys_version
|
| ︙ | ︙ | |||
9832 9833 9834 9835 9836 9837 9838 |
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_ok" >&5
$as_echo "$tcl_ok" >&6; }
#------------------------------------------------------------------------
# Check whether the timezone data is supplied by the OS or has
# to be installed by Tcl. The default is autodetection, but can
| | | 9991 9992 9993 9994 9995 9996 9997 9998 9999 10000 10001 10002 10003 10004 10005 |
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_ok" >&5
$as_echo "$tcl_ok" >&6; }
#------------------------------------------------------------------------
# Check whether the timezone data is supplied by the OS or has
# to be installed by Tcl. The default is autodetection, but can
# be overridden on the configure command line either way.
#------------------------------------------------------------------------
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for timezone data" >&5
$as_echo_n "checking for timezone data... " >&6; }
# Check whether --with-tzdata was given.
if test "${with_tzdata+set}" = set; then :
|
| ︙ | ︙ | |||
10209 10210 10211 10212 10213 10214 10215 |
# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed
# since on some platforms TCL_LIB_FILE contains shell escapes.
# (See also: TCL_TRIM_DOTS).
eval "TCL_LIB_FILE=${TCL_LIB_FILE}"
| | | 10368 10369 10370 10371 10372 10373 10374 10375 10376 10377 10378 10379 10380 10381 10382 |
# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed
# since on some platforms TCL_LIB_FILE contains shell escapes.
# (See also: TCL_TRIM_DOTS).
eval "TCL_LIB_FILE=${TCL_LIB_FILE}"
test -z "$TCL_LIBRARY" && TCL_LIBRARY='$(prefix)/lib/tcl$(VERSION)'
PRIVATE_INCLUDE_DIR='$(includedir)'
HTML_DIR='$(DISTDIR)/html'
# Note: in the following variable, it's important to use the absolute
# path name of the Tcl directory rather than "..": this is because
# AIX remembers this path and will attempt to use it at run-time to look
# up the Tcl library.
|
| ︙ | ︙ | |||
10260 10261 10262 10263 10264 10265 10266 |
fi
FRAMEWORK_BUILD=0
fi
fi
TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version ${TCL_VERSION}`echo ${TCL_PATCH_LEVEL} | awk '{match($0, "\\\.[0-9]+"); print substr($0,RSTART,RLENGTH)}'`"
TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -install_name "${DYLIB_INSTALL_DIR}"/${TCL_LIB_FILE}'
| | | 10419 10420 10421 10422 10423 10424 10425 10426 10427 10428 10429 10430 10431 10432 10433 |
fi
FRAMEWORK_BUILD=0
fi
fi
TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version ${TCL_VERSION}`echo ${TCL_PATCH_LEVEL} | awk '{match($0, "\\\.[0-9]+"); print substr($0,RSTART,RLENGTH)}'`"
TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -install_name "${DYLIB_INSTALL_DIR}"/${TCL_LIB_FILE}'
echo "$LDFLAGS " | grep -q -- '-prebind ' && TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -seg1addr 0xA000000'
TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -sectcreate __TEXT __info_plist Tcl-Info.plist'
EXTRA_TCLSH_LIBS='-sectcreate __TEXT __info_plist Tclsh-Info.plist'
EXTRA_APP_CC_SWITCHES='-mdynamic-no-pic'
ac_config_files="$ac_config_files Tcl-Info.plist:../macosx/Tcl-Info.plist.in Tclsh-Info.plist:../macosx/Tclsh-Info.plist.in"
TCL_YEAR="`date +%Y`"
fi
|
| ︙ | ︙ | |||
10298 10299 10300 10301 10302 10303 10304 |
TCL_LIB_SPEC="-F${libdir} -framework Tcl"
libdir="${libdir}/Tcl.framework/Versions/\${VERSION}"
TCL_LIBRARY="${libdir}/Resources/Scripts"
includedir="${libdir}/Headers"
PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders"
HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl"
EXTRA_INSTALL="install-private-headers html-tcl"
| | | 10457 10458 10459 10460 10461 10462 10463 10464 10465 10466 10467 10468 10469 10470 10471 |
TCL_LIB_SPEC="-F${libdir} -framework Tcl"
libdir="${libdir}/Tcl.framework/Versions/\${VERSION}"
TCL_LIBRARY="${libdir}/Resources/Scripts"
includedir="${libdir}/Headers"
PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders"
HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl"
EXTRA_INSTALL="install-private-headers html-tcl"
EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)/TclTOC.html"'
EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"'
EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"'
EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."'
# Don't use AC_DEFINE for the following as the framework version define
# needs to go into the Makefile even when using autoheader, so that we
# can pick up a potential make override of VERSION. Also, don't put this
# into CFLAGS as it should not go into tclConfig.sh
|
| ︙ | ︙ | |||
10334 10335 10336 10337 10338 10339 10340 |
# gives a list of directories that may contain packages. The list
# consists of one directory for machine-dependent binaries and
# another for platform-independent scripts.
#--------------------------------------------------------------------
if test "$FRAMEWORK_BUILD" = "1" ; then
test -z "$TCL_PACKAGE_PATH" && \
| | | | | | | 10493 10494 10495 10496 10497 10498 10499 10500 10501 10502 10503 10504 10505 10506 10507 10508 10509 10510 10511 10512 10513 10514 10515 10516 10517 10518 10519 10520 10521 10522 10523 10524 10525 10526 |
# gives a list of directories that may contain packages. The list
# consists of one directory for machine-dependent binaries and
# another for platform-independent scripts.
#--------------------------------------------------------------------
if test "$FRAMEWORK_BUILD" = "1" ; then
test -z "$TCL_PACKAGE_PATH" && \
TCL_PACKAGE_PATH="~/Library/Tcl /Library/Tcl ~/Library/Frameworks /Library/Frameworks"
test -z "$TCL_MODULE_PATH" && \
TCL_MODULE_PATH="~/Library/Tcl /Library/Tcl"
elif test "$prefix/lib" != "$libdir"; then
test -z "$TCL_PACKAGE_PATH" && TCL_PACKAGE_PATH="{${libdir}} {${prefix}/lib} ${TCL_PACKAGE_PATH}"
else
test -z "$TCL_PACKAGE_PATH" && TCL_PACKAGE_PATH="{${prefix}/lib} ${TCL_PACKAGE_PATH}"
fi
#--------------------------------------------------------------------
# The statements below define various symbols relating to Tcl
# stub support.
#--------------------------------------------------------------------
# Replace ${VERSION} with contents of ${TCL_VERSION}
# double-eval to account for TCL_TRIM_DOTS.
#
eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}"
eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_DIR=\"${libdir}\""
if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}"
else
TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`"
fi
|
| ︙ | ︙ | |||
10966 10967 10968 10969 10970 10971 10972 | test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" | | | 11125 11126 11127 11128 11129 11130 11131 11132 11133 11134 11135 11136 11137 11138 11139 | test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # Save the log message, to keep $0 and so on meaningful, and to # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" This file was extended by tcl $as_me 8.7, which was generated by GNU Autoconf 2.69. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS CONFIG_LINKS = $CONFIG_LINKS CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ |
| ︙ | ︙ | |||
11023 11024 11025 11026 11027 11028 11029 | Report bugs to the package provider." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ | | | 11182 11183 11184 11185 11186 11187 11188 11189 11190 11191 11192 11193 11194 11195 11196 | Report bugs to the package provider." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ tcl config.status 8.7 configured by $0, generated by GNU Autoconf 2.69, with options \\"\$ac_cs_config\\" Copyright (C) 2012 Free Software Foundation, Inc. This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." |
| ︙ | ︙ |
Changes to unix/configure.ac.
1 2 3 4 5 | #! /bin/bash -norc dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. | | | | | | | 1 2 3 4 5 6 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 |
#! /bin/bash -norc
dnl This file is an input file used by the GNU "autoconf" program to
dnl generate the file "configure", which is run during Tcl installation
dnl to configure the system for the local environment.
AC_INIT([tcl],[8.7])
AC_PREREQ(2.69)
dnl This is only used when included from macosx/configure.ac
m4_ifdef([SC_USE_CONFIG_HEADERS], [
AC_CONFIG_HEADERS([tclConfig.h:../unix/tclConfig.h.in])
AC_CONFIG_COMMANDS_PRE([DEFS="-DHAVE_TCL_CONFIG_H -imacros tclConfig.h"])
AH_TOP([
#ifndef _TCLCONFIG
#define _TCLCONFIG])
AH_BOTTOM([
/* Undef unused package specific autoheader defines so that we can
* include both tclConfig.h and tkConfig.h at the same time: */
/* override */ #undef PACKAGE_NAME
/* override */ #undef PACKAGE_STRING
/* override */ #undef PACKAGE_TARNAME
#endif /* _TCLCONFIG */])
])
TCL_VERSION=8.7
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=7
TCL_PATCH_LEVEL="a4"
VERSION=${TCL_VERSION}
EXTRA_INSTALL_BINARIES=${EXTRA_INSTALL_BINARIES:-"@:"}
EXTRA_BUILD_HTML=${EXTRA_BUILD_HTML:-"@:"}
#------------------------------------------------------------------------
# Setup configure arguments for bundled packages
|
| ︙ | ︙ | |||
85 86 87 88 89 90 91 | AC_PROG_CC AC_C_INLINE #-------------------------------------------------------------------- # Supply substitutes for missing POSIX header files. Special notes: | | | | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 | AC_PROG_CC AC_C_INLINE #-------------------------------------------------------------------- # Supply substitutes for missing POSIX header files. Special notes: # - stdlib.h doesn't define strtol or strtoul in some versions # of SunOS # - some versions of string.h don't declare procedures such # as strstr # Do this early, otherwise an autoconf bug throws errors on configure #-------------------------------------------------------------------- SC_MISSING_POSIX_HEADERS |
| ︙ | ︙ | |||
162 163 164 165 166 167 168 169 170 171 172 173 174 175 |
])])
AS_IF([test $zlib_ok = no], [
AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}])
AC_SUBST(ZLIB_SRCS,[\${ZLIB_SRCS}])
AC_SUBST(ZLIB_INCLUDE,[-I\${ZLIB_DIR}])
])
AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?])
#--------------------------------------------------------------------
# The statements below define a collection of compile flags. This
# macro depends on the value of SHARED_BUILD, and should be called
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------
| > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
])])
AS_IF([test $zlib_ok = no], [
AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}])
AC_SUBST(ZLIB_SRCS,[\${ZLIB_SRCS}])
AC_SUBST(ZLIB_INCLUDE,[-I\${ZLIB_DIR}])
])
AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?])
#------------------------------------------------------------------------
# Add stuff for libtommath
libtommath_ok=yes
AC_ARG_WITH(system-libtommath,
AC_HELP_STRING([--with-system-libtommath],
[use external libtommath (default: true if available, false otherwise)]),
libtommath_ok=${withval})
if test x"${libtommath_ok}" = x -o x"${libtommath_ok}" != xno; then
AC_CHECK_HEADER([tommath.h],[
AC_CHECK_TYPE([mp_int],[],[libtommath_ok=no],[#include <tommath.h>])],[
libtommath_ok=no])
AS_IF([test $libtommath_ok = yes], [
AC_CHECK_LIB([tommath],[mp_log_u32],[MATH_LIBS="$MATH_LIBS -ltommath"],[
libtommath_ok=no])])
fi
AS_IF([test $libtommath_ok = yes], [
AC_DEFINE(TCL_WITH_EXTERNAL_TOMMATH, 1, [Tcl with external libtommath])
], [
AC_SUBST(TOMMATH_OBJS,[\${TOMMATH_OBJS}])
AC_SUBST(TOMMATH_SRCS,[\${TOMMATH_SRCS}])
AC_SUBST(TOMMATH_INCLUDE,[-I\${TOMMATH_DIR}])
])
#--------------------------------------------------------------------
# The statements below define a collection of compile flags. This
# macro depends on the value of SHARED_BUILD, and should be called
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------
|
| ︙ | ︙ | |||
673 674 675 676 677 678 679 |
AC_DEFINE(TCL_UNLOAD_DLLS, 1, [Do we allow unloading of shared libraries?])
fi
AC_MSG_RESULT([$tcl_ok])
#------------------------------------------------------------------------
# Check whether the timezone data is supplied by the OS or has
# to be installed by Tcl. The default is autodetection, but can
| | | 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 |
AC_DEFINE(TCL_UNLOAD_DLLS, 1, [Do we allow unloading of shared libraries?])
fi
AC_MSG_RESULT([$tcl_ok])
#------------------------------------------------------------------------
# Check whether the timezone data is supplied by the OS or has
# to be installed by Tcl. The default is autodetection, but can
# be overridden on the configure command line either way.
#------------------------------------------------------------------------
AC_MSG_CHECKING([for timezone data])
AC_ARG_WITH(tzdata,
AC_HELP_STRING([--with-tzdata],
[install timezone data (default: autodetect)]),
[tcl_ok=$withval], [tcl_ok=auto])
|
| ︙ | ︙ | |||
837 838 839 840 841 842 843 |
# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed
# since on some platforms TCL_LIB_FILE contains shell escapes.
# (See also: TCL_TRIM_DOTS).
eval "TCL_LIB_FILE=${TCL_LIB_FILE}"
| | | | 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 |
# tclConfig.sh needs a version of the _LIB_SUFFIX that has been eval'ed
# since on some platforms TCL_LIB_FILE contains shell escapes.
# (See also: TCL_TRIM_DOTS).
eval "TCL_LIB_FILE=${TCL_LIB_FILE}"
test -z "$TCL_LIBRARY" && TCL_LIBRARY='$(prefix)/lib/tcl$(VERSION)'
PRIVATE_INCLUDE_DIR='$(includedir)'
HTML_DIR='$(DISTDIR)/html'
# Note: in the following variable, it's important to use the absolute
# path name of the Tcl directory rather than "..": this is because
# AIX remembers this path and will attempt to use it at run-time to look
# up the Tcl library.
if test "`uname -s`" = "Darwin" ; then
SC_ENABLE_FRAMEWORK
TCL_SHLIB_LD_EXTRAS="-compatibility_version ${TCL_VERSION} -current_version ${TCL_VERSION}`echo ${TCL_PATCH_LEVEL} | awk ['{match($0, "\\\.[0-9]+"); print substr($0,RSTART,RLENGTH)}']`"
TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -install_name "${DYLIB_INSTALL_DIR}"/${TCL_LIB_FILE}'
echo "$LDFLAGS " | grep -q -- '-prebind ' && TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -seg1addr 0xA000000'
TCL_SHLIB_LD_EXTRAS="${TCL_SHLIB_LD_EXTRAS}"' -sectcreate __TEXT __info_plist Tcl-Info.plist'
EXTRA_TCLSH_LIBS='-sectcreate __TEXT __info_plist Tclsh-Info.plist'
EXTRA_APP_CC_SWITCHES='-mdynamic-no-pic'
AC_CONFIG_FILES([Tcl-Info.plist:../macosx/Tcl-Info.plist.in Tclsh-Info.plist:../macosx/Tclsh-Info.plist.in])
TCL_YEAR="`date +%Y`"
fi
|
| ︙ | ︙ | |||
890 891 892 893 894 895 896 |
TCL_LIB_SPEC="-F${libdir} -framework Tcl"
libdir="${libdir}/Tcl.framework/Versions/\${VERSION}"
TCL_LIBRARY="${libdir}/Resources/Scripts"
includedir="${libdir}/Headers"
PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders"
HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl"
EXTRA_INSTALL="install-private-headers html-tcl"
| | | 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 |
TCL_LIB_SPEC="-F${libdir} -framework Tcl"
libdir="${libdir}/Tcl.framework/Versions/\${VERSION}"
TCL_LIBRARY="${libdir}/Resources/Scripts"
includedir="${libdir}/Headers"
PRIVATE_INCLUDE_DIR="${libdir}/PrivateHeaders"
HTML_DIR="${libdir}/Resources/Documentation/Reference/Tcl"
EXTRA_INSTALL="install-private-headers html-tcl"
EXTRA_BUILD_HTML='@ln -fs contents.htm "$(HTML_INSTALL_DIR)/TclTOC.html"'
EXTRA_INSTALL_BINARIES='@echo "Installing Info.plist to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA_DIR) "$(LIB_INSTALL_DIR)/Resources" && $(INSTALL_DATA) Tcl-Info.plist "$(LIB_INSTALL_DIR)/Resources/Info.plist"'
EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Installing license.terms to $(LIB_INSTALL_DIR)/Resources/" && $(INSTALL_DATA) "$(TOP_DIR)/license.terms" "$(LIB_INSTALL_DIR)/Resources"'
EXTRA_INSTALL_BINARIES="$EXTRA_INSTALL_BINARIES"' && echo "Finalizing Tcl.framework" && rm -f "$(LIB_INSTALL_DIR)/../Current" && ln -s "$(VERSION)" "$(LIB_INSTALL_DIR)/../Current" && for f in "$(LIB_FILE)" tclConfig.sh Resources Headers PrivateHeaders; do rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/Current/$$f" "$(LIB_INSTALL_DIR)/../.."; done && f="$(STUB_LIB_FILE)" && rm -f "$(LIB_INSTALL_DIR)/../../$$f" && ln -s "Versions/$(VERSION)/$$f" "$(LIB_INSTALL_DIR)/../.."'
# Don't use AC_DEFINE for the following as the framework version define
# needs to go into the Makefile even when using autoheader, so that we
# can pick up a potential make override of VERSION. Also, don't put this
# into CFLAGS as it should not go into tclConfig.sh
|
| ︙ | ︙ | |||
926 927 928 929 930 931 932 |
# gives a list of directories that may contain packages. The list
# consists of one directory for machine-dependent binaries and
# another for platform-independent scripts.
#--------------------------------------------------------------------
if test "$FRAMEWORK_BUILD" = "1" ; then
test -z "$TCL_PACKAGE_PATH" && \
| | | | | | | 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 |
# gives a list of directories that may contain packages. The list
# consists of one directory for machine-dependent binaries and
# another for platform-independent scripts.
#--------------------------------------------------------------------
if test "$FRAMEWORK_BUILD" = "1" ; then
test -z "$TCL_PACKAGE_PATH" && \
TCL_PACKAGE_PATH="~/Library/Tcl /Library/Tcl ~/Library/Frameworks /Library/Frameworks"
test -z "$TCL_MODULE_PATH" && \
TCL_MODULE_PATH="~/Library/Tcl /Library/Tcl"
elif test "$prefix/lib" != "$libdir"; then
test -z "$TCL_PACKAGE_PATH" && TCL_PACKAGE_PATH="{${libdir}} {${prefix}/lib} ${TCL_PACKAGE_PATH}"
else
test -z "$TCL_PACKAGE_PATH" && TCL_PACKAGE_PATH="{${prefix}/lib} ${TCL_PACKAGE_PATH}"
fi
#--------------------------------------------------------------------
# The statements below define various symbols relating to Tcl
# stub support.
#--------------------------------------------------------------------
# Replace ${VERSION} with contents of ${TCL_VERSION}
# double-eval to account for TCL_TRIM_DOTS.
#
eval "TCL_STUB_LIB_FILE=libtclstub${TCL_UNSHARED_LIB_SUFFIX}"
eval "TCL_STUB_LIB_FILE=\"${TCL_STUB_LIB_FILE}\""
eval "TCL_STUB_LIB_DIR=\"${libdir}\""
if test "${TCL_LIB_VERSIONS_OK}" = "ok"; then
TCL_STUB_LIB_FLAG="-ltclstub${TCL_VERSION}"
else
TCL_STUB_LIB_FLAG="-ltclstub`echo ${TCL_VERSION} | tr -d .`"
fi
|
| ︙ | ︙ |
Changes to unix/installManPage.
| ︙ | ︙ | |||
39 40 41 42 43 44 45 |
ManPage=$1
Dir=$2
if test -f $ManPage ; then : ; else
echo "source manual page file must exist"
exit 1
fi
| | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 |
ManPage=$1
Dir=$2
if test -f $ManPage ; then : ; else
echo "source manual page file must exist"
exit 1
fi
if test -d "$Dir" ; then : ; else
echo "target directory must exist"
exit 1
fi
test -z "$SymOrLoc" && SymOrLoc="$Dir/"
########################################################################
### Extract Target Names from Manual Page
|
| ︙ | ︙ | |||
103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 |
*.1) Section=1 ;;
*.3) Section=3 ;;
*.n) Section=n ;;
*) echo "unknown section for $ManPage"
exit 2 ;;
esac
SrcDir=`dirname $ManPage`
########################################################################
### Process Page to Create Target Pages
###
First=""
for Target in $Names; do
Target=$Target.$Section$Suffix
| > > > > > > > > | | | | | | 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 |
*.1) Section=1 ;;
*.3) Section=3 ;;
*.n) Section=n ;;
*) echo "unknown section for $ManPage"
exit 2 ;;
esac
Name=`basename $ManPage .$Section`
SrcDir=`dirname $ManPage`
########################################################################
### Process Page to Create Target Pages
###
Specials="DString Thread Notifier RegExp library packagens pkgMkIndex safesock"
for n in $Specials; do
if [ "$Name" = "$n" ] ; then
Names="$n $Names"
fi
done
First=""
for Target in $Names; do
Target=$Target.$Section$Suffix
rm -f "$Dir/$Target" "$Dir/$Target.*"
if test -z "$First" ; then
First=$Target
sed -e "/man\.macros/r $SrcDir/man.macros" -e "/man\.macros/d" \
$ManPage > "$Dir/$First"
chmod 644 "$Dir/$First"
$Gzip "$Dir/$First"
else
ln "$SymOrLoc$First$Gz" "$Dir/$Target$Gz"
fi
done
########################################################################
exit 0
|
Changes to unix/tcl.m4.
| ︙ | ︙ | |||
73 74 75 76 77 78 79 |
fi
# on Darwin, check in Framework installation locations
if test "`uname -s`" = "Darwin" -a x"${ac_cv_c_tclconfig}" = x ; then
for i in `ls -d ~/Library/Frameworks 2>/dev/null` \
`ls -d /Library/Frameworks 2>/dev/null` \
`ls -d /Network/Library/Frameworks 2>/dev/null` \
| < > | | | 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 |
fi
# on Darwin, check in Framework installation locations
if test "`uname -s`" = "Darwin" -a x"${ac_cv_c_tclconfig}" = x ; then
for i in `ls -d ~/Library/Frameworks 2>/dev/null` \
`ls -d /Library/Frameworks 2>/dev/null` \
`ls -d /Network/Library/Frameworks 2>/dev/null` \
; do
if test -f "$i/Tcl.framework/tclConfig.sh" ; then
ac_cv_c_tclconfig="`(cd $i/Tcl.framework; pwd)`"
break
fi
done
fi
# check in a few common install locations
if test x"${ac_cv_c_tclconfig}" = x ; then
for i in `ls -d ${libdir} 2>/dev/null` \
`ls -d ${exec_prefix}/lib 2>/dev/null` \
`ls -d ${prefix}/lib 2>/dev/null` \
`ls -d /usr/local/lib 2>/dev/null` \
`ls -d /usr/contrib/lib 2>/dev/null` \
`ls -d /usr/pkg/lib 2>/dev/null` \
`ls -d /usr/lib/tcl8.7 2>/dev/null` \
`ls -d /usr/lib 2>/dev/null` \
`ls -d /usr/lib64 2>/dev/null` \
`ls -d /usr/local/lib/tcl8.7 2>/dev/null` \
`ls -d /usr/local/lib/tcl/tcl8.7 2>/dev/null` \
; do
if test -f "$i/tclConfig.sh" ; then
ac_cv_c_tclconfig="`(cd $i; pwd)`"
break
fi
done
fi
|
| ︙ | ︙ | |||
206 207 208 209 210 211 212 |
fi
# on Darwin, check in Framework installation locations
if test "`uname -s`" = "Darwin" -a x"${ac_cv_c_tkconfig}" = x ; then
for i in `ls -d ~/Library/Frameworks 2>/dev/null` \
`ls -d /Library/Frameworks 2>/dev/null` \
`ls -d /Network/Library/Frameworks 2>/dev/null` \
| < > | | | 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 |
fi
# on Darwin, check in Framework installation locations
if test "`uname -s`" = "Darwin" -a x"${ac_cv_c_tkconfig}" = x ; then
for i in `ls -d ~/Library/Frameworks 2>/dev/null` \
`ls -d /Library/Frameworks 2>/dev/null` \
`ls -d /Network/Library/Frameworks 2>/dev/null` \
; do
if test -f "$i/Tk.framework/tkConfig.sh" ; then
ac_cv_c_tkconfig="`(cd $i/Tk.framework; pwd)`"
break
fi
done
fi
# check in a few common install locations
if test x"${ac_cv_c_tkconfig}" = x ; then
for i in `ls -d ${libdir} 2>/dev/null` \
`ls -d ${exec_prefix}/lib 2>/dev/null` \
`ls -d ${prefix}/lib 2>/dev/null` \
`ls -d /usr/local/lib 2>/dev/null` \
`ls -d /usr/contrib/lib 2>/dev/null` \
`ls -d /usr/pkg/lib 2>/dev/null` \
`ls -d /usr/lib/tk8.7 2>/dev/null` \
`ls -d /usr/lib 2>/dev/null` \
`ls -d /usr/lib64 2>/dev/null` \
`ls -d /usr/local/lib/tk8.7 2>/dev/null` \
`ls -d /usr/local/lib/tcl/tk8.7 2>/dev/null` \
; do
if test -f "$i/tkConfig.sh" ; then
ac_cv_c_tkconfig="`(cd $i; pwd)`"
break
fi
done
fi
|
| ︙ | ︙ | |||
289 290 291 292 293 294 295 |
if test -f "${TCL_BIN_DIR}/tclConfig.sh" ; then
AC_MSG_RESULT([loading])
. "${TCL_BIN_DIR}/tclConfig.sh"
else
AC_MSG_RESULT([could not find ${TCL_BIN_DIR}/tclConfig.sh])
fi
| < < < < | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 |
if test -f "${TCL_BIN_DIR}/tclConfig.sh" ; then
AC_MSG_RESULT([loading])
. "${TCL_BIN_DIR}/tclConfig.sh"
else
AC_MSG_RESULT([could not find ${TCL_BIN_DIR}/tclConfig.sh])
fi
# If the TCL_BIN_DIR is the build directory (not the install directory),
# then set the common variable name to the value of the build variables.
# For example, the variable TCL_LIB_SPEC will be set to the value
# of TCL_BUILD_LIB_SPEC. An extension should make use of TCL_LIB_SPEC
# instead of TCL_BUILD_LIB_SPEC since it will work with both an
# installed and uninstalled version of Tcl.
if test -f "${TCL_BIN_DIR}/Makefile" ; then
|
| ︙ | ︙ | |||
326 327 328 329 330 331 332 |
TCL_STUB_LIB_SPEC="-L`echo "${TCL_BIN_DIR}" | sed -e 's/ /\\\\ /g'` ${TCL_STUB_LIB_FLAG}"
TCL_STUB_LIB_PATH="${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}"
fi
;;
esac
fi
| < < < < < < | 322 323 324 325 326 327 328 329 330 331 332 333 334 335 |
TCL_STUB_LIB_SPEC="-L`echo "${TCL_BIN_DIR}" | sed -e 's/ /\\\\ /g'` ${TCL_STUB_LIB_FLAG}"
TCL_STUB_LIB_PATH="${TCL_BIN_DIR}/${TCL_STUB_LIB_FILE}"
fi
;;
esac
fi
AC_SUBST(TCL_VERSION)
AC_SUBST(TCL_PATCH_LEVEL)
AC_SUBST(TCL_BIN_DIR)
AC_SUBST(TCL_SRC_DIR)
AC_SUBST(TCL_LIB_FILE)
AC_SUBST(TCL_LIB_FLAG)
|
| ︙ | ︙ | |||
372 373 374 375 376 377 378 |
if test -f "${TK_BIN_DIR}/tkConfig.sh" ; then
AC_MSG_RESULT([loading])
. "${TK_BIN_DIR}/tkConfig.sh"
else
AC_MSG_RESULT([could not find ${TK_BIN_DIR}/tkConfig.sh])
fi
| < < < < | 362 363 364 365 366 367 368 369 370 371 372 373 374 375 |
if test -f "${TK_BIN_DIR}/tkConfig.sh" ; then
AC_MSG_RESULT([loading])
. "${TK_BIN_DIR}/tkConfig.sh"
else
AC_MSG_RESULT([could not find ${TK_BIN_DIR}/tkConfig.sh])
fi
# If the TK_BIN_DIR is the build directory (not the install directory),
# then set the common variable name to the value of the build variables.
# For example, the variable TK_LIB_SPEC will be set to the value
# of TK_BUILD_LIB_SPEC. An extension should make use of TK_LIB_SPEC
# instead of TK_BUILD_LIB_SPEC since it will work with both an
# installed and uninstalled version of Tcl.
if test -f "${TK_BIN_DIR}/Makefile" ; then
|
| ︙ | ︙ | |||
409 410 411 412 413 414 415 |
TK_STUB_LIB_SPEC="-L` echo "${TK_BIN_DIR}" | sed -e 's/ /\\\\ /g'` ${TK_STUB_LIB_FLAG}"
TK_STUB_LIB_PATH="${TK_BIN_DIR}/${TK_STUB_LIB_FILE}"
fi
;;
esac
fi
| < < < < < < | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 |
TK_STUB_LIB_SPEC="-L` echo "${TK_BIN_DIR}" | sed -e 's/ /\\\\ /g'` ${TK_STUB_LIB_FLAG}"
TK_STUB_LIB_PATH="${TK_BIN_DIR}/${TK_STUB_LIB_FILE}"
fi
;;
esac
fi
AC_SUBST(TK_VERSION)
AC_SUBST(TK_BIN_DIR)
AC_SUBST(TK_SRC_DIR)
AC_SUBST(TK_LIB_FILE)
AC_SUBST(TK_LIB_FLAG)
AC_SUBST(TK_LIB_SPEC)
|
| ︙ | ︙ | |||
620 621 622 623 624 625 626 | # --enable-symbols # # Defines the following vars: # CFLAGS_DEFAULT Sets to $(CFLAGS_DEBUG) if true # Sets to $(CFLAGS_OPTIMIZE) if false # LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true # Sets to $(LDFLAGS_OPTIMIZE) if false | < < < | 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 |
# --enable-symbols
#
# Defines the following vars:
# CFLAGS_DEFAULT Sets to $(CFLAGS_DEBUG) if true
# Sets to $(CFLAGS_OPTIMIZE) if false
# LDFLAGS_DEFAULT Sets to $(LDFLAGS_DEBUG) if true
# Sets to $(LDFLAGS_OPTIMIZE) if false
#------------------------------------------------------------------------
AC_DEFUN([SC_ENABLE_SYMBOLS], [
AC_MSG_CHECKING([for build with symbols])
AC_ARG_ENABLE(symbols,
AC_HELP_STRING([--enable-symbols],
[build with debugging symbols (default: off)]),
[tcl_ok=$enableval], [tcl_ok=no])
# FIXME: Currently, LDFLAGS_DEFAULT is not used, it should work like CFLAGS_DEFAULT.
if test "$tcl_ok" = "no"; then
CFLAGS_DEFAULT='$(CFLAGS_OPTIMIZE)'
LDFLAGS_DEFAULT='$(LDFLAGS_OPTIMIZE)'
AC_DEFINE(NDEBUG, 1, [Is no debugging enabled?])
AC_MSG_RESULT([no])
AC_DEFINE(TCL_CFG_OPTIMIZED, 1, [Is this an optimized build?])
else
|
| ︙ | ︙ | |||
810 811 812 813 814 815 816 817 818 819 820 821 822 823 |
if test "$?" -ne 0 ; then
AC_MSG_WARN([can't find uname command])
tcl_cv_sys_version=unknown
else
if test "`uname -s`" = "AIX" ; then
tcl_cv_sys_version=AIX-`uname -v`.`uname -r`
fi
fi
fi
])
system=$tcl_cv_sys_version
])
#--------------------------------------------------------------------
| > > > | 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 |
if test "$?" -ne 0 ; then
AC_MSG_WARN([can't find uname command])
tcl_cv_sys_version=unknown
else
if test "`uname -s`" = "AIX" ; then
tcl_cv_sys_version=AIX-`uname -v`.`uname -r`
fi
if test "`uname -s`" = "NetBSD" -a -f /etc/debian_version ; then
tcl_cv_sys_version=NetBSD-Debian
fi
fi
fi
])
system=$tcl_cv_sys_version
])
#--------------------------------------------------------------------
|
| ︙ | ︙ | |||
982 983 984 985 986 987 988 |
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 977 978 979 980 981 982 983 984 |
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 -Wwrite-strings -Wpointer-arith"
case "${CC}" in
*++|*++-*)
;;
*)
CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -Wdeclaration-after-statement"
;;
esac
], [
CFLAGS_OPTIMIZE=-O
CFLAGS_WARNING=""
])
AC_CHECK_TOOL(AR, ar)
STLIB_LD='${AR} cr'
LD_LIBRARY_PATH_VAR="LD_LIBRARY_PATH"
|
| ︙ | ︙ | |||
1092 1093 1094 1095 1096 1097 1098 | DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -export-dynamic" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; CYGWIN_*) | | | | 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 |
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -export-dynamic"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
CYGWIN_*)
SHLIB_CFLAGS="-fno-common"
SHLIB_LD='${CC} -shared'
SHLIB_SUFFIX=".dll"
DL_OBJS="tclLoadDl.o"
PLAT_OBJS='${CYGWIN_OBJS}'
PLAT_SRCS='${CYGWIN_SRCS}'
DL_LIBS="-ldl"
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
TCL_NEEDS_EXP_FILE=1
TCL_EXPORT_FILE_SUFFIX='${VERSION}.dll.a'
SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,--out-implib,\$[@].a"
AC_CACHE_CHECK(for Cygwin version of gcc,
ac_cv_cygwin,
AC_TRY_COMPILE([
#ifdef __CYGWIN__
#error cygwin
#endif
|
| ︙ | ︙ | |||
1188 1189 1190 1191 1192 1193 1194 |
AS_IF([test "$GCC" = yes], [
case `${CC} -dumpmachine` in
hppa64*)
# 64-bit gcc in use. Fix flags for GNU ld.
do64bit_ok=yes
SHLIB_LD='${CC} -shared'
AS_IF([test $doRpath = yes], [
| | | 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 |
AS_IF([test "$GCC" = yes], [
case `${CC} -dumpmachine` in
hppa64*)
# 64-bit gcc in use. Fix flags for GNU ld.
do64bit_ok=yes
SHLIB_LD='${CC} -shared'
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'])
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
;;
*)
AC_MSG_WARN([64bit mode not supported with GCC on $system])
;;
esac
], [
|
| ︙ | ︙ | |||
1223 1224 1225 1226 1227 1228 1229 | SHLIB_CFLAGS="" SHLIB_LD="ld -shared -rdata_shared" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" AC_LIBOBJ(mkstemp) AS_IF([test $doRpath = yes], [ | | | | 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 |
SHLIB_CFLAGS=""
SHLIB_LD="ld -shared -rdata_shared"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
AC_LIBOBJ(mkstemp)
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'])
;;
IRIX-6.*)
SHLIB_CFLAGS=""
SHLIB_LD="ld -n32 -shared -rdata_shared"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
AC_LIBOBJ(mkstemp)
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'])
AS_IF([test "$GCC" = yes], [
CFLAGS="$CFLAGS -mabi=n32"
LDFLAGS="$LDFLAGS -mabi=n32"
], [
case $system in
IRIX-6.3)
|
| ︙ | ︙ | |||
1260 1261 1262 1263 1264 1265 1266 | SHLIB_CFLAGS="" SHLIB_LD="ld -n32 -shared -rdata_shared" SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" AC_LIBOBJ(mkstemp) AS_IF([test $doRpath = yes], [ | | | | | | | | | 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 |
SHLIB_CFLAGS=""
SHLIB_LD="ld -n32 -shared -rdata_shared"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
AC_LIBOBJ(mkstemp)
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'])
# Check to enable 64-bit flags for compiler/linker
AS_IF([test "$do64bit" = yes], [
AS_IF([test "$GCC" = yes], [
AC_MSG_WARN([64bit mode not supported by gcc])
], [
do64bit_ok=yes
SHLIB_LD="ld -64 -shared -rdata_shared"
CFLAGS="$CFLAGS -64"
LDFLAGS_ARCH="-64"
])
])
;;
Linux*|GNU*|NetBSD-Debian)
SHLIB_CFLAGS="-fPIC -fno-common"
SHLIB_SUFFIX=".so"
CFLAGS_OPTIMIZE="-O2"
# egcs-2.91.66 on Redhat Linux 6.0 generates lots of warnings
# when you inline the string and math operations. Turn this off to
# get rid of the warnings.
#CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D__NO_STRING_INLINES -D__NO_MATH_INLINES"
SHLIB_LD='${CC} ${CFLAGS} ${LDFLAGS} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-ldl"
LDFLAGS="$LDFLAGS -Wl,--export-dynamic"
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'])
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
AS_IF([test "`uname -m`" = "alpha"], [CFLAGS="$CFLAGS -mieee"])
AS_IF([test $do64bit = yes], [
AC_CACHE_CHECK([if compiler accepts -m64 flag], tcl_cv_cc_m64, [
hold_cflags=$CFLAGS
CFLAGS="$CFLAGS -m64"
AC_TRY_LINK(,, tcl_cv_cc_m64=yes, tcl_cv_cc_m64=no)
CFLAGS=$hold_cflags])
AS_IF([test $tcl_cv_cc_m64 = yes], [
CFLAGS="$CFLAGS -m64"
do64bit_ok=yes
])
])
# The combo of gcc + glibc has a bug related to inlining of
# functions like strtol()/strtoul(). The -fno-builtin flag should address
# this problem but it does not work. The -fno-inline flag is kind
# of overkill but it works. Disable inlining only when one of the
# files in compat/*.c is being linked in.
AS_IF([test x"${USE_COMPAT}" != x],[CFLAGS="$CFLAGS -fno-inline"])
;;
Lynx*)
SHLIB_CFLAGS="-fPIC"
SHLIB_SUFFIX=".so"
CFLAGS_OPTIMIZE=-02
SHLIB_LD='${CC} -shared'
DL_OBJS="tclLoadDl.o"
DL_LIBS="-mshared -ldl"
LD_FLAGS="-Wl,--export-dynamic"
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'])
;;
OpenBSD-*)
arch=`arch -s`
case "$arch" in
alpha|sparc64)
SHLIB_CFLAGS="-fPIC"
;;
*)
SHLIB_CFLAGS="-fpic"
;;
esac
SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'])
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}'
LDFLAGS="-Wl,-export-dynamic"
CFLAGS_OPTIMIZE="-O2"
# On OpenBSD: Compile with -pthread
# Don't link with -lpthread
LIBS=`echo $LIBS | sed s/-lpthread//`
|
| ︙ | ︙ | |||
1363 1364 1365 1366 1367 1368 1369 |
SHLIB_CFLAGS="-fPIC"
SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -export-dynamic"
AS_IF([test $doRpath = yes], [
| | < < | | | 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 |
SHLIB_CFLAGS="-fPIC"
SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared'
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
LDFLAGS="$LDFLAGS -export-dynamic"
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'])
LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS}
# The -pthread needs to go in the CFLAGS, not LIBS
LIBS=`echo $LIBS | sed s/-pthread//`
CFLAGS="$CFLAGS -pthread"
LDFLAGS="$LDFLAGS -pthread"
;;
DragonFly-*|FreeBSD-*)
# This configuration from FreeBSD Ports.
SHLIB_LD="${CC} -shared"
SHLIB_LD_LIBS="${SHLIB_LD_LIBS} -Wl,-soname,\$[@]"
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'])
# The -pthread needs to go in the LDFLAGS, not LIBS
LIBS=`echo $LIBS | sed s/-pthread//`
CFLAGS="$CFLAGS $PTHREAD_CFLAGS"
LDFLAGS="$LDFLAGS $PTHREAD_LIBS"
case $system in
FreeBSD-3.*)
# Version numbers are dot-stripped by system policy.
|
| ︙ | ︙ | |||
1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 |
LDFLAGS=$hold_ldflags])
AS_IF([test $tcl_cv_ld_search_paths_first = yes], [
LDFLAGS="$LDFLAGS -Wl,-search_paths_first"
])
AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [
AC_DEFINE(MODULE_SCOPE, [__private_extern__],
[Compiler support for module scope symbols])
])
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH"
AC_DEFINE(MAC_OSX_TCL, 1, [Is this a Mac I see before me?])
PLAT_OBJS='${MAC_OSX_OBJS}'
PLAT_SRCS='${MAC_OSX_SRCS}'
| > | 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 |
LDFLAGS=$hold_ldflags])
AS_IF([test $tcl_cv_ld_search_paths_first = yes], [
LDFLAGS="$LDFLAGS -Wl,-search_paths_first"
])
AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [
AC_DEFINE(MODULE_SCOPE, [__private_extern__],
[Compiler support for module scope symbols])
tcl_cv_cc_visibility_hidden=yes
])
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
LD_LIBRARY_PATH_VAR="DYLD_LIBRARY_PATH"
AC_DEFINE(MAC_OSX_TCL, 1, [Is this a Mac I see before me?])
PLAT_OBJS='${MAC_OSX_OBJS}'
PLAT_SRCS='${MAC_OSX_SRCS}'
|
| ︙ | ︙ | |||
1548 1549 1550 1551 1552 1553 1554 | ], [ SHLIB_LD='ld -non_shared -expect_unresolved "*"' ]) SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" AS_IF([test $doRpath = yes], [ | | < | | | | | 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 |
], [
SHLIB_LD='ld -non_shared -expect_unresolved "*"'
])
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
AS_IF([test $doRpath = yes], [
CC_SEARCH_FLAGS='"-Wl,-rpath,${LIB_RUNTIME_DIR}"'
LD_SEARCH_FLAGS='-rpath ${LIB_RUNTIME_DIR}'])
AS_IF([test "$GCC" = yes], [CFLAGS="$CFLAGS -mieee"], [
CFLAGS="$CFLAGS -DHAVE_TZSET -std1 -ieee"])
# see pthread_intro(3) for pthread support on osf1, k.furukawa
CFLAGS="$CFLAGS -DHAVE_PTHREAD_ATTR_SETSTACKSIZE"
CFLAGS="$CFLAGS -DTCL_THREAD_STACK_MIN=PTHREAD_STACK_MIN*64"
LIBS=`echo $LIBS | sed s/-lpthreads//`
AS_IF([test "$GCC" = yes], [
LIBS="$LIBS -lpthread -lmach -lexc"
], [
CFLAGS="$CFLAGS -pthread"
LDFLAGS="$LDFLAGS -pthread"
])
;;
QNX-6*)
# QNX RTP
# This may work for all QNX, but it was only reported for v6.
SHLIB_LD="ld -Bshareable -x"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
# dlopen is in -lc on QNX
DL_LIBS=""
CC_SEARCH_FLAGS=""
LD_SEARCH_FLAGS=""
;;
SCO_SV-3.2*)
# Note, dlopen is available only on SCO 3.2.5 and greater. However,
# this test works, since "uname -s" was non-standard in 3.2.4 and
# below.
AS_IF([test "$GCC" = yes], [
SHLIB_CFLAGS="-fPIC -melf"
LDFLAGS="$LDFLAGS -melf -Wl,-Bexport"
], [
SHLIB_CFLAGS="-Kpic -belf"
LDFLAGS="$LDFLAGS -belf -Wl,-Bexport"
])
SHLIB_LD="ld -G"
SHLIB_LD_LIBS=""
SHLIB_SUFFIX=".so"
DL_OBJS="tclLoadDl.o"
DL_LIBS=""
CC_SEARCH_FLAGS=""
|
| ︙ | ︙ | |||
1794 1795 1796 1797 1798 1799 1800 1801 |
# standard manufacturer compiler.
AS_IF([test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes], [
case $system in
AIX-*) ;;
BSD/OS*) ;;
CYGWIN_*) ;;
IRIX*) ;;
| > > > | | | | 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 |
# standard manufacturer compiler.
AS_IF([test "$DL_OBJS" != "tclLoadNone.o" -a "$GCC" = yes], [
case $system in
AIX-*) ;;
BSD/OS*) ;;
CYGWIN_*) ;;
HP_UX*) ;;
Darwin-*) ;;
IRIX*) ;;
Linux*|GNU*) ;;
NetBSD-*|OpenBSD-*) ;;
OSF1-V*) ;;
SCO_SV-3.2*) ;;
*) SHLIB_CFLAGS="-fPIC" ;;
esac])
AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [
AC_DEFINE(MODULE_SCOPE, [extern],
[No Compiler support for module scope symbols])
])
AS_IF([test "$SHARED_LIB_SUFFIX" = ""], [
SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}'])
AS_IF([test "$UNSHARED_LIB_SUFFIX" = ""], [
UNSHARED_LIB_SUFFIX='${VERSION}.a'])
DLL_INSTALL_DIR="\$(LIB_INSTALL_DIR)"
AS_IF([test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""], [
LIB_SUFFIX=${SHARED_LIB_SUFFIX}
MAKE_LIB='${SHLIB_LD} -o [$]@ ${OBJS} ${LDFLAGS} ${SHLIB_LD_LIBS} ${TCL_SHLIB_LD_EXTRAS} ${TK_SHLIB_LD_EXTRAS} ${LD_SEARCH_FLAGS}'
AS_IF([test "${SHLIB_SUFFIX}" = ".dll"], [
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(BIN_INSTALL_DIR)/$(LIB_FILE)";if test -f $(LIB_FILE).a; then $(INSTALL_DATA) $(LIB_FILE).a "$(LIB_INSTALL_DIR)"; fi;'
DLL_INSTALL_DIR="\$(BIN_INSTALL_DIR)"
], [
INSTALL_LIB='$(INSTALL_LIBRARY) $(LIB_FILE) "$(LIB_INSTALL_DIR)/$(LIB_FILE)"'
])
], [
|
| ︙ | ︙ | |||
1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 |
tcl_cv_cast_to_union=no)
)
if test "$tcl_cv_cast_to_union" = "yes"; then
AC_DEFINE(HAVE_CAST_TO_UNION, 1,
[Defined when compiler supports casting to union type.])
fi
# FIXME: This subst was left in only because the TCL_DL_LIBS
# entry in tclConfig.sh uses it. It is not clear why someone
# would use TCL_DL_LIBS instead of TCL_LIBS.
AC_SUBST(DL_LIBS)
AC_SUBST(DL_OBJS)
AC_SUBST(PLAT_OBJS)
| > > | 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 |
tcl_cv_cast_to_union=no)
)
if test "$tcl_cv_cast_to_union" = "yes"; then
AC_DEFINE(HAVE_CAST_TO_UNION, 1,
[Defined when compiler supports casting to union type.])
fi
AC_CHECK_HEADER(stdbool.h, [AC_DEFINE(HAVE_STDBOOL_H, 1, [Do we have <stdbool.h>?])],)
# FIXME: This subst was left in only because the TCL_DL_LIBS
# entry in tclConfig.sh uses it. It is not clear why someone
# would use TCL_DL_LIBS instead of TCL_LIBS.
AC_SUBST(DL_LIBS)
AC_SUBST(DL_OBJS)
AC_SUBST(PLAT_OBJS)
|
| ︙ | ︙ | |||
1909 1910 1911 1912 1913 1914 1915 | ]) #-------------------------------------------------------------------- # SC_MISSING_POSIX_HEADERS # # Supply substitutes for missing POSIX header files. Special # notes: | | | < | 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 |
])
#--------------------------------------------------------------------
# SC_MISSING_POSIX_HEADERS
#
# Supply substitutes for missing POSIX header files. Special
# notes:
# - stdlib.h doesn't define strtol or strtoul in some
# versions of SunOS
# - some versions of string.h don't declare procedures such
# as strstr
#
# Arguments:
# none
#
# Results:
#
# Defines some of the following vars:
# NO_DIRENT_H
# NO_STDLIB_H
# NO_STRING_H
# NO_SYS_WAIT_H
# NO_DLFCN_H
# HAVE_SYS_PARAM_H
# HAVE_STRING_H ?
#
#--------------------------------------------------------------------
AC_DEFUN([SC_MISSING_POSIX_HEADERS], [
AC_CACHE_CHECK([dirent.h], tcl_cv_dirent_h, [
AC_TRY_LINK([#include <sys/types.h>
|
| ︙ | ︙ | |||
1961 1962 1963 1964 1965 1966 1967 |
if test $tcl_cv_dirent_h = no; then
AC_DEFINE(NO_DIRENT_H, 1, [Do we have <dirent.h>?])
fi
AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0)
AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0)
AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0)
| < | 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 |
if test $tcl_cv_dirent_h = no; then
AC_DEFINE(NO_DIRENT_H, 1, [Do we have <dirent.h>?])
fi
AC_CHECK_HEADER(stdlib.h, tcl_ok=1, tcl_ok=0)
AC_EGREP_HEADER(strtol, stdlib.h, , tcl_ok=0)
AC_EGREP_HEADER(strtoul, stdlib.h, , tcl_ok=0)
if test $tcl_ok = 0; then
AC_DEFINE(NO_STDLIB_H, 1, [Do we have <stdlib.h>?])
fi
AC_CHECK_HEADER(string.h, tcl_ok=1, tcl_ok=0)
AC_EGREP_HEADER(strstr, string.h, , tcl_ok=0)
AC_EGREP_HEADER(strerror, string.h, , tcl_ok=0)
|
| ︙ | ︙ | |||
2515 2516 2517 2518 2519 2520 2521 | # Might define the following vars: # HAVE_GETHOSTBYADDR_R # HAVE_GETHOSTBYADDR_R_7 # HAVE_GETHOSTBYADDR_R_8 # #-------------------------------------------------------------------- | | > > > > > > > > > > > > > | 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 |
# Might define the following vars:
# HAVE_GETHOSTBYADDR_R
# HAVE_GETHOSTBYADDR_R_7
# HAVE_GETHOSTBYADDR_R_8
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_GETHOSTBYADDR_R], [
# Avoids picking hidden internal symbol from libc
SC_TCL_GETHOSTBYADDR_R_DECL
if test "$tcl_cv_api_gethostbyaddr_r" = yes; then
SC_TCL_GETHOSTBYADDR_R_TYPE
fi
])
AC_DEFUN([SC_TCL_GETHOSTBYADDR_R_DECL], [AC_CHECK_DECLS(gethostbyaddr_r, [
tcl_cv_api_gethostbyaddr_r=yes],[tcl_cv_api_gethostbyaddr_r=no],[#include <netdb.h>])
])
AC_DEFUN([SC_TCL_GETHOSTBYADDR_R_TYPE], [AC_CHECK_FUNC(gethostbyaddr_r, [
AC_CACHE_CHECK([for gethostbyaddr_r with 7 args], tcl_cv_api_gethostbyaddr_r_7, [
AC_TRY_COMPILE([
#include <netdb.h>
], [
char *addr;
int length;
int type;
|
| ︙ | ︙ | |||
2576 2577 2578 2579 2580 2581 2582 | # # Arguments: # None # # Results: # # Might define the following vars: | | | | | | > > > > > > > > > > > > > | 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 |
#
# Arguments:
# None
#
# Results:
#
# Might define the following vars:
# HAVE_GETHOSTBYNAME_R
# HAVE_GETHOSTBYNAME_R_3
# HAVE_GETHOSTBYNAME_R_5
# HAVE_GETHOSTBYNAME_R_6
#
#--------------------------------------------------------------------
AC_DEFUN([SC_TCL_GETHOSTBYNAME_R], [
# Avoids picking hidden internal symbol from libc
SC_TCL_GETHOSTBYNAME_R_DECL
if test "$tcl_cv_api_gethostbyname_r" = yes; then
SC_TCL_GETHOSTBYNAME_R_TYPE
fi
])
AC_DEFUN([SC_TCL_GETHOSTBYNAME_R_DECL], [AC_CHECK_DECLS(gethostbyname_r, [
tcl_cv_api_gethostbyname_r=yes],[tcl_cv_api_gethostbyname_r=no],[#include <netdb.h>])
])
AC_DEFUN([SC_TCL_GETHOSTBYNAME_R_TYPE], [AC_CHECK_FUNC(gethostbyname_r, [
AC_CACHE_CHECK([for gethostbyname_r with 6 args], tcl_cv_api_gethostbyname_r_6, [
AC_TRY_COMPILE([
#include <netdb.h>
], [
char *name;
struct hostent *he, *res;
char buffer[2048];
|
| ︙ | ︙ |
Changes to unix/tcl.pc.in.
1 2 3 4 5 6 7 8 9 10 11 12 13 | # tcl pkg-config source file prefix=@prefix@ exec_prefix=@exec_prefix@ libdir=@libdir@ includedir=@includedir@ libfile=@TCL_LIB_FILE@ zipfile=@TCL_ZIP_FILE@ Name: Tool Command Language Description: Tcl is a powerful, easy-to-learn dynamic programming language, suitable for a wide range of uses. URL: http://www.tcl.tk/ Version: @TCL_VERSION@@TCL_PATCH_LEVEL@ | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 |
# tcl pkg-config source file
prefix=@prefix@
exec_prefix=@exec_prefix@
libdir=@libdir@
includedir=@includedir@
libfile=@TCL_LIB_FILE@
zipfile=@TCL_ZIP_FILE@
Name: Tool Command Language
Description: Tcl is a powerful, easy-to-learn dynamic programming language, suitable for a wide range of uses.
URL: http://www.tcl.tk/
Version: @TCL_VERSION@@TCL_PATCH_LEVEL@
Requires.private: zlib >= 1.2.3, libtommath >= 1.2.0
Libs: -L${libdir} @TCL_LIB_FLAG@ @TCL_STUB_LIB_FLAG@
Libs.private: @TCL_LIBS@
Cflags: -I${includedir}
|
Changes to unix/tcl.spec.
1 2 3 4 5 6 |
# This file is the basis for a binary Tcl RPM for Linux.
%{!?directory:%define directory /usr/local}
Name: tcl
Summary: Tcl scripting language development environment
| | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
# This file is the basis for a binary Tcl RPM for Linux.
%{!?directory:%define directory /usr/local}
Name: tcl
Summary: Tcl scripting language development environment
Version: 8.7a3
Release: 2
License: BSD
Group: Development/Languages
Source: http://prdownloads.sourceforge.net/tcl/tcl%{version}-src.tar.gz
URL: http://www.tcl.tk/
Buildroot: /var/tmp/%{name}%{version}
|
| ︙ | ︙ |
Changes to unix/tclConfig.h.in.
| ︙ | ︙ | |||
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 | #undef HAVE_AVAILABILITYMACROS_H /* Define to 1 if the system has the type `blkcnt_t'. */ #undef HAVE_BLKCNT_T /* Defined when compiler supports casting to union type. */ #undef HAVE_CAST_TO_UNION /* Define to 1 if you have the `chflags' function. */ #undef HAVE_CHFLAGS /* Define to 1 if you have the `copyfile' function. */ #undef HAVE_COPYFILE /* Define to 1 if you have the <copyfile.h> header file. */ #undef HAVE_COPYFILE_H /* Do we have access to Darwin CoreFoundation.framework? */ #undef HAVE_COREFOUNDATION /* Is the cpuid instruction usable? */ #undef HAVE_CPUID /* Is 'DIR64' in <sys/types.h>? */ #undef HAVE_DIR64 /* Define to 1 if you have the `freeaddrinfo' function. */ #undef HAVE_FREEADDRINFO /* Do we have fts functions? */ #undef HAVE_FTS | > > > > > > > > > > > > > > > > > > | 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 | #undef HAVE_AVAILABILITYMACROS_H /* Define to 1 if the system has the type `blkcnt_t'. */ #undef HAVE_BLKCNT_T /* Defined when compiler supports casting to union type. */ #undef HAVE_CAST_TO_UNION /* Define to 1 if you have the `cfmakeraw' function. */ #undef HAVE_CFMAKERAW /* Define to 1 if you have the `chflags' function. */ #undef HAVE_CHFLAGS /* Define to 1 if you have the `copyfile' function. */ #undef HAVE_COPYFILE /* Define to 1 if you have the <copyfile.h> header file. */ #undef HAVE_COPYFILE_H /* Do we have access to Darwin CoreFoundation.framework? */ #undef HAVE_COREFOUNDATION /* Is the cpuid instruction usable? */ #undef HAVE_CPUID /* Define to 1 if you have the declaration of `gethostbyaddr_r', and to 0 if you don't. */ #undef HAVE_DECL_GETHOSTBYADDR_R /* Define to 1 if you have the declaration of `gethostbyname_r', and to 0 if you don't. */ #undef HAVE_DECL_GETHOSTBYNAME_R /* Define to 1 if you have the declaration of `PTHREAD_MUTEX_RECURSIVE', and to 0 if you don't. */ #undef HAVE_DECL_PTHREAD_MUTEX_RECURSIVE /* Is 'DIR64' in <sys/types.h>? */ #undef HAVE_DIR64 /* Is eventfd(2) supported? */ #undef HAVE_EVENTFD /* Define to 1 if you have the `freeaddrinfo' function. */ #undef HAVE_FREEADDRINFO /* Do we have fts functions? */ #undef HAVE_FTS |
| ︙ | ︙ | |||
173 174 175 176 177 178 179 180 181 182 183 184 185 186 | #undef HAVE_PTHREAD_ATTR_SETSTACKSIZE /* Does putenv() copy strings or incorporate them by reference? */ #undef HAVE_PUTENV_THAT_COPIES /* Are characters signed? */ #undef HAVE_SIGNED_CHAR /* Define to 1 if you have the <stdint.h> header file. */ #undef HAVE_STDINT_H /* Define to 1 if you have the <stdlib.h> header file. */ #undef HAVE_STDLIB_H | > > > | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 | #undef HAVE_PTHREAD_ATTR_SETSTACKSIZE /* Does putenv() copy strings or incorporate them by reference? */ #undef HAVE_PUTENV_THAT_COPIES /* Are characters signed? */ #undef HAVE_SIGNED_CHAR /* Do we have <stdbool.h>? */ #undef HAVE_STDBOOL_H /* Define to 1 if you have the <stdint.h> header file. */ #undef HAVE_STDINT_H /* Define to 1 if you have the <stdlib.h> header file. */ #undef HAVE_STDLIB_H |
| ︙ | ︙ | |||
212 213 214 215 216 217 218 219 220 221 222 223 224 225 | #undef HAVE_STRUCT_STAT64 /* Define to 1 if `st_blksize' is member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_BLKSIZE /* Define to 1 if `st_blocks' is member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_BLOCKS /* Define to 1 if you have the <sys/filio.h> header file. */ #undef HAVE_SYS_FILIO_H /* Define to 1 if you have the <sys/ioctl.h> header file. */ #undef HAVE_SYS_IOCTL_H | > > > > > > > > > | 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 | #undef HAVE_STRUCT_STAT64 /* Define to 1 if `st_blksize' is member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_BLKSIZE /* Define to 1 if `st_blocks' is member of `struct stat'. */ #undef HAVE_STRUCT_STAT_ST_BLOCKS /* Define to 1 if you have the <sys/epoll.h> header file. */ #undef HAVE_SYS_EPOLL_H /* Define to 1 if you have the <sys/eventfd.h> header file. */ #undef HAVE_SYS_EVENTFD_H /* Define to 1 if you have the <sys/event.h> header file. */ #undef HAVE_SYS_EVENT_H /* Define to 1 if you have the <sys/filio.h> header file. */ #undef HAVE_SYS_FILIO_H /* Define to 1 if you have the <sys/ioctl.h> header file. */ #undef HAVE_SYS_IOCTL_H |
| ︙ | ︙ | |||
273 274 275 276 277 278 279 | /* Is this a Mac I see before me? */ #undef MAC_OSX_TCL /* No Compiler support for module scope symbols */ #undef MODULE_SCOPE | < < < > > > > > > | 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 | /* Is this a Mac I see before me? */ #undef MAC_OSX_TCL /* No Compiler support for module scope symbols */ #undef MODULE_SCOPE /* Is no debugging enabled? */ #undef NDEBUG /* Use compat implementation of getaddrinfo() and friends */ #undef NEED_FAKE_RFC2553 /* Is epoll(7) supported? */ #undef NOTIFIER_EPOLL /* Is kqueue(2) supported? */ #undef NOTIFIER_KQUEUE /* Is Darwin CoreFoundation unavailable for 64-bit? */ #undef NO_COREFOUNDATION_64 /* Do we have <dirent.h>? */ #undef NO_DIRENT_H |
| ︙ | ︙ | |||
390 391 392 393 394 395 396 | /* Do we allow unloading of shared libraries? */ #undef TCL_UNLOAD_DLLS /* Does this platform have wide high-resolution clicks? */ #undef TCL_WIDE_CLICKS | | < < < > > > | 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 | /* Do we allow unloading of shared libraries? */ #undef TCL_UNLOAD_DLLS /* Does this platform have wide high-resolution clicks? */ #undef TCL_WIDE_CLICKS /* Do 'long' and 'long long' have the same size (64-bit)? */ #undef TCL_WIDE_INT_IS_LONG /* What type should be used to define wide integers? */ #undef TCL_WIDE_INT_TYPE /* Define to 1 if you can safely include both <sys/time.h> and <time.h>. */ #undef TIME_WITH_SYS_TIME /* Is getcwd Posix-compliant? */ #undef USEGETWD /* May we include <dirent2.h>? */ #undef USE_DIRENT2_H /* Are we building with DTrace support? */ #undef USE_DTRACE /* Should we use FIONBIO? */ #undef USE_FIONBIO /* Should we use vfork() instead of fork()? */ #undef USE_VFORK /* Define to 1 if your processor stores words with the most significant byte first (like Motorola and SPARC, unlike Intel and VAX). */ #undef WORDS_BIGENDIAN /* Are we building with zipfs enabled? */ #undef ZIPFS_BUILD /* Are Darwin SUSv3 extensions available? */ #undef _DARWIN_C_SOURCE /* Add the _ISOC99_SOURCE flag when building */ #undef _ISOC99_SOURCE |
| ︙ | ︙ |
Changes to unix/tclEpollNotfy.c.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 | * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is * in tclMacOSXNotify.c */ #if defined(NOTIFIER_EPOLL) && TCL_THREADS | > | > | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #ifndef HAVE_COREFOUNDATION /* Darwin/Mac OS X CoreFoundation notifier is * in tclMacOSXNotify.c */ #if defined(NOTIFIER_EPOLL) && TCL_THREADS #ifndef _GNU_SOURCE # define _GNU_SOURCE /* For pipe2(2) */ #endif #include <fcntl.h> #include <signal.h> #include <sys/epoll.h> #ifdef HAVE_EVENTFD #include <sys/eventfd.h> #endif /* HAVE_EVENTFD */ #include <sys/queue.h> |
| ︙ | ︙ | |||
177 178 179 180 181 182 183 | * Finalize is called. * *---------------------------------------------------------------------- */ void Tcl_FinalizeNotifier( | | | 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 |
* Finalize is called.
*
*----------------------------------------------------------------------
*/
void
Tcl_FinalizeNotifier(
ClientData clientData)
{
if (tclNotifierHooks.finalizeNotifierProc) {
tclNotifierHooks.finalizeNotifierProc(clientData);
return;
} else {
PlatformEventsFinalize();
}
|
| ︙ | ︙ | |||
234 235 236 237 238 239 240 |
if (filePtr->mask & (TCL_READABLE | TCL_EXCEPTION)) {
newEvent.events |= EPOLLIN;
}
if (filePtr->mask & TCL_WRITABLE) {
newEvent.events |= EPOLLOUT;
}
if (isNew) {
| | | 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 |
if (filePtr->mask & (TCL_READABLE | TCL_EXCEPTION)) {
newEvent.events |= EPOLLIN;
}
if (filePtr->mask & TCL_WRITABLE) {
newEvent.events |= EPOLLOUT;
}
if (isNew) {
newPedPtr = (struct PlatformEventData *)ckalloc(sizeof(struct PlatformEventData));
newPedPtr->filePtr = filePtr;
newPedPtr->tsdPtr = tsdPtr;
filePtr->pedPtr = newPedPtr;
}
newEvent.data.ptr = filePtr->pedPtr;
/*
|
| ︙ | ︙ | |||
314 315 316 317 318 319 320 |
tsdPtr->triggerPipe[0] = -1;
}
if (tsdPtr->triggerPipe[1]) {
close(tsdPtr->triggerPipe[1]);
tsdPtr->triggerPipe[1] = -1;
}
#endif /* HAVE_EVENTFD */
| | | | | 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 |
tsdPtr->triggerPipe[0] = -1;
}
if (tsdPtr->triggerPipe[1]) {
close(tsdPtr->triggerPipe[1]);
tsdPtr->triggerPipe[1] = -1;
}
#endif /* HAVE_EVENTFD */
ckfree(tsdPtr->triggerFilePtr->pedPtr);
ckfree(tsdPtr->triggerFilePtr);
if (tsdPtr->eventsFd > 0) {
close(tsdPtr->eventsFd);
tsdPtr->eventsFd = 0;
}
if (tsdPtr->readyEvents) {
ckfree(tsdPtr->readyEvents);
tsdPtr->maxReadyEvents = 0;
}
pthread_mutex_unlock(&tsdPtr->notifierMutex);
if ((errno = pthread_mutex_destroy(&tsdPtr->notifierMutex))) {
Tcl_Panic("pthread_mutex_destroy: %s", strerror(errno));
}
}
|
| ︙ | ︙ | |||
366 367 368 369 370 371 372 |
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FileHandler *filePtr;
errno = pthread_mutex_init(&tsdPtr->notifierMutex, NULL);
if (errno) {
Tcl_Panic("Tcl_InitNotifier: %s", "could not create mutex");
}
| | | | 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 |
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FileHandler *filePtr;
errno = pthread_mutex_init(&tsdPtr->notifierMutex, NULL);
if (errno) {
Tcl_Panic("Tcl_InitNotifier: %s", "could not create mutex");
}
filePtr = (FileHandler *)ckalloc(sizeof(FileHandler));
#ifdef HAVE_EVENTFD
tsdPtr->triggerEventFd = eventfd(0, EFD_CLOEXEC | EFD_NONBLOCK);
if (tsdPtr->triggerEventFd <= 0) {
Tcl_Panic("Tcl_InitNotifier: %s", "could not create trigger eventfd");
}
filePtr->fd = tsdPtr->triggerEventFd;
#else /* !HAVE_EVENTFD */
if (pipe2(tsdPtr->triggerPipe, O_CLOEXEC | O_NONBLOCK) != 0) {
Tcl_Panic("Tcl_InitNotifier: %s", "could not create trigger pipe");
}
filePtr->fd = tsdPtr->triggerPipe[0];
#endif /* HAVE_EVENTFD */
tsdPtr->triggerFilePtr = filePtr;
if ((tsdPtr->eventsFd = epoll_create1(EPOLL_CLOEXEC)) == -1) {
Tcl_Panic("epoll_create1: %s", strerror(errno));
}
filePtr->mask = TCL_READABLE;
PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_ADD, 1);
if (!tsdPtr->readyEvents) {
tsdPtr->maxReadyEvents = 512;
tsdPtr->readyEvents = (struct epoll_event *)ckalloc(
tsdPtr->maxReadyEvents * sizeof(tsdPtr->readyEvents[0]));
}
LIST_INIT(&tsdPtr->firstReadyFileHandlerPtr);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
546 547 548 549 550 551 552 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
| | | 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
filePtr = (FileHandler *)ckalloc(sizeof(FileHandler));
filePtr->fd = fd;
filePtr->readyMask = 0;
filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
tsdPtr->firstFileHandlerPtr = filePtr;
isNew = 1;
} else {
isNew = 0;
|
| ︙ | ︙ | |||
616 617 618 619 620 621 622 |
/*
* Update the check masks for this file.
*/
PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_DEL, 0);
if (filePtr->pedPtr) {
| | | | 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 |
/*
* Update the check masks for this file.
*/
PlatformEventsControl(filePtr, tsdPtr, EPOLL_CTL_DEL, 0);
if (filePtr->pedPtr) {
ckfree(filePtr->pedPtr);
}
/*
* Clean up information in the callback record.
*/
if (prevPtr == NULL) {
tsdPtr->firstFileHandlerPtr = filePtr->nextPtr;
} else {
prevPtr->nextPtr = filePtr->nextPtr;
}
ckfree(filePtr);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_WaitForEvent --
|
| ︙ | ︙ | |||
729 730 731 732 733 734 735 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
| | | | 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)
ckalloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
numQueued++;
}
filePtr->readyMask = mask;
|
| ︙ | ︙ | |||
768 769 770 771 772 773 774 |
* which in turn will cause PlatformEventsWait() to return
* immediately.
*/
numFound = PlatformEventsWait(tsdPtr->readyEvents,
tsdPtr->maxReadyEvents, timeoutPtr);
for (numEvent = 0; numEvent < numFound; numEvent++) {
| | | 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 |
* which in turn will cause PlatformEventsWait() to return
* immediately.
*/
numFound = PlatformEventsWait(tsdPtr->readyEvents,
tsdPtr->maxReadyEvents, timeoutPtr);
for (numEvent = 0; numEvent < numFound; numEvent++) {
pedPtr = (struct PlatformEventData*)tsdPtr->readyEvents[numEvent].data.ptr;
filePtr = pedPtr->filePtr;
mask = PlatformEventsTranslate(&tsdPtr->readyEvents[numEvent]);
#ifdef HAVE_EVENTFD
if (filePtr->fd == tsdPtr->triggerEventFd) {
uint64_t eventFdVal;
i = read(tsdPtr->triggerEventFd, &eventFdVal,
sizeof(eventFdVal));
|
| ︙ | ︙ | |||
806 807 808 809 810 811 812 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
| | | | 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)
ckalloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
}
filePtr->readyMask = mask;
}
|
| ︙ | ︙ |
Changes to unix/tclKqueueNotfy.c.
| ︙ | ︙ | |||
165 166 167 168 169 170 171 | * Finalize is called. * *---------------------------------------------------------------------- */ void Tcl_FinalizeNotifier( | | | 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 |
* Finalize is called.
*
*----------------------------------------------------------------------
*/
void
Tcl_FinalizeNotifier(
ClientData clientData)
{
if (tclNotifierHooks.finalizeNotifierProc) {
tclNotifierHooks.finalizeNotifierProc(clientData);
return;
} else {
PlatformEventsFinalize();
}
|
| ︙ | ︙ | |||
218 219 220 221 222 223 224 |
{
int numChanges;
struct kevent changeList[2];
struct PlatformEventData *newPedPtr;
struct stat fdStat;
if (isNew) {
| | | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 |
{
int numChanges;
struct kevent changeList[2];
struct PlatformEventData *newPedPtr;
struct stat fdStat;
if (isNew) {
newPedPtr = (struct PlatformEventData *)ckalloc(sizeof(struct PlatformEventData));
newPedPtr->filePtr = filePtr;
newPedPtr->tsdPtr = tsdPtr;
filePtr->pedPtr = newPedPtr;
}
/*
* N.B. As discussed in Tcl_WaitForEvent(), kqueue(2) does not reproduce
|
| ︙ | ︙ | |||
340 341 342 343 344 345 346 |
tsdPtr->triggerPipe[1] = -1;
}
if (tsdPtr->eventsFd > 0) {
close(tsdPtr->eventsFd);
tsdPtr->eventsFd = 0;
}
if (tsdPtr->readyEvents) {
| | | 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 |
tsdPtr->triggerPipe[1] = -1;
}
if (tsdPtr->eventsFd > 0) {
close(tsdPtr->eventsFd);
tsdPtr->eventsFd = 0;
}
if (tsdPtr->readyEvents) {
ckfree(tsdPtr->readyEvents);
tsdPtr->maxReadyEvents = 0;
}
pthread_mutex_unlock(&tsdPtr->notifierMutex);
if ((errno = pthread_mutex_destroy(&tsdPtr->notifierMutex))) {
Tcl_Panic("pthread_mutex_destroy: %s", strerror(errno));
}
}
|
| ︙ | ︙ | |||
405 406 407 408 409 410 411 |
}
}
if ((tsdPtr->eventsFd = kqueue()) == -1) {
Tcl_Panic("kqueue: %s", strerror(errno));
} else if (fcntl(tsdPtr->eventsFd, F_SETFD, FD_CLOEXEC) == -1) {
Tcl_Panic("fcntl: %s", strerror(errno));
}
| | | | 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 |
}
}
if ((tsdPtr->eventsFd = kqueue()) == -1) {
Tcl_Panic("kqueue: %s", strerror(errno));
} else if (fcntl(tsdPtr->eventsFd, F_SETFD, FD_CLOEXEC) == -1) {
Tcl_Panic("fcntl: %s", strerror(errno));
}
filePtr = (FileHandler *)ckalloc(sizeof(FileHandler));
filePtr->fd = tsdPtr->triggerPipe[0];
filePtr->mask = TCL_READABLE;
PlatformEventsControl(filePtr, tsdPtr, EV_ADD, 1);
if (!tsdPtr->readyEvents) {
tsdPtr->maxReadyEvents = 512;
tsdPtr->readyEvents = (struct kevent *)ckalloc(
tsdPtr->maxReadyEvents * sizeof(tsdPtr->readyEvents[0]));
}
LIST_INIT(&tsdPtr->firstReadyFileHandlerPtr);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
576 577 578 579 580 581 582 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
| | | 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
filePtr = (FileHandler *)ckalloc(sizeof(FileHandler));
filePtr->fd = fd;
filePtr->readyMask = 0;
filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
tsdPtr->firstFileHandlerPtr = filePtr;
isNew = 1;
} else {
isNew = 0;
|
| ︙ | ︙ | |||
645 646 647 648 649 650 651 |
/*
* Update the check masks for this file.
*/
PlatformEventsControl(filePtr, tsdPtr, EV_DELETE, 0);
if (filePtr->pedPtr) {
| | | | 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 |
/*
* Update the check masks for this file.
*/
PlatformEventsControl(filePtr, tsdPtr, EV_DELETE, 0);
if (filePtr->pedPtr) {
ckfree(filePtr->pedPtr);
}
/*
* Clean up information in the callback record.
*/
if (prevPtr == NULL) {
tsdPtr->firstFileHandlerPtr = filePtr->nextPtr;
} else {
prevPtr->nextPtr = filePtr->nextPtr;
}
ckfree(filePtr);
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_WaitForEvent --
|
| ︙ | ︙ | |||
764 765 766 767 768 769 770 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
| | | | 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)
ckalloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
numQueued++;
}
filePtr->readyMask = mask;
|
| ︙ | ︙ | |||
824 825 826 827 828 829 830 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
| | | | 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)
ckalloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
}
filePtr->readyMask |= mask;
}
|
| ︙ | ︙ |
Changes to unix/tclLoadAix.c.
| ︙ | ︙ | |||
94 95 96 97 98 99 100 |
static void *findMain(void);
void *
dlopen(
const char *path,
int mode)
{
| | | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 |
static void *findMain(void);
void *
dlopen(
const char *path,
int mode)
{
ModulePtr mp;
static void *mainModule;
/*
* Upon the first call register a terminate handler that will close all
* libraries. Also get a reference to the main module for use with
* loadbind.
*/
|
| ︙ | ︙ | |||
187 188 189 190 191 192 193 |
/*
* If the user wants global binding, loadbind against all other loaded
* modules.
*/
if (mode & RTLD_GLOBAL) {
| | | 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 |
/*
* If the user wants global binding, loadbind against all other loaded
* modules.
*/
if (mode & RTLD_GLOBAL) {
ModulePtr mp1;
for (mp1 = mp->next; mp1; mp1 = mp1->next) {
if (loadbind(0, mp1->entry, mp->entry) == -1) {
goto loadbindFailure;
}
}
}
|
| ︙ | ︙ | |||
239 240 241 242 243 244 245 |
* error message buffer.
*/
static void
caterr(
char *s)
{
| | | 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 |
* error message buffer.
*/
static void
caterr(
char *s)
{
char *p = s;
while (*p >= '0' && *p <= '9') {
p++;
}
switch (atoi(s)) { /* INTL: "C", UTF safe. */
case L_ERROR_TOOMANY:
strcat(errbuf, "to many errors");
|
| ︙ | ︙ | |||
278 279 280 281 282 283 284 |
}
void *
dlsym(
void *handle,
const char *symbol)
{
| | | | | 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 |
}
void *
dlsym(
void *handle,
const char *symbol)
{
ModulePtr mp = (ModulePtr)handle;
ExportPtr ep;
int i;
/*
* Could speed up the search, but I assume that one assigns the result to
* function pointers anyways.
*/
for (ep = mp->exports, i = mp->nExports; i; i--, ep++) {
|
| ︙ | ︙ | |||
313 314 315 316 317 318 319 |
return NULL;
}
int
dlclose(
void *handle)
{
| | | | 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 |
return NULL;
}
int
dlclose(
void *handle)
{
ModulePtr mp = (ModulePtr)handle;
int result;
ModulePtr mp1;
if (--mp->refCnt > 0) {
return 0;
}
if (mp->info && mp->info->fini) {
mp->info->fini();
|
| ︙ | ︙ | |||
339 340 341 342 343 344 345 |
result = unload(mp->entry);
if (result == -1) {
errvalid++;
strcpy(errbuf, strerror(errno));
}
if (mp->exports) {
| | | | 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 |
result = unload(mp->entry);
if (result == -1) {
errvalid++;
strcpy(errbuf, strerror(errno));
}
if (mp->exports) {
ExportPtr ep;
int i;
for (ep = mp->exports, i = mp->nExports; i; i--, ep++) {
if (ep->name) {
free(ep->name);
}
}
free(mp->exports);
}
|
| ︙ | ︙ |
Changes to unix/tclLoadDl.c.
| ︙ | ︙ | |||
79 80 81 82 83 84 85 |
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
| | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 |
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
native = (const char *)Tcl_FSGetNativePath(pathPtr);
/*
* Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
*/
if (flags & TCL_LOAD_GLOBAL) {
dlopenflags |= RTLD_GLOBAL;
} else {
dlopenflags |= RTLD_LOCAL;
|
| ︙ | ︙ | |||
102 103 104 105 106 107 108 | /* * Let the OS loader examine the binary search path for whatever * string the user gave us which hopefully refers to a file on the * binary path. */ Tcl_DString ds; | | | | | 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 |
/*
* Let the OS loader examine the binary search path for whatever
* string the user gave us which hopefully refers to a file on the
* binary path.
*/
Tcl_DString ds;
const char *fileName = Tcl_GetString(pathPtr);
native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
/*
* Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
*/
handle = dlopen(native, dlopenflags);
Tcl_DStringFree(&ds);
}
if (handle == NULL) {
/*
* Write the string to a variable first to work around a compiler bug
* in the Sun Forte 6 compiler. [Bug 1503729]
*/
const char *errorStr = dlerror();
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s",
Tcl_GetString(pathPtr), errorStr));
}
return TCL_ERROR;
}
newHandle = (Tcl_LoadHandle)ckalloc(sizeof(*newHandle));
newHandle->clientData = handle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*unloadProcPtr = &UnloadFile;
*loadHandle = newHandle;
return TCL_OK;
|
| ︙ | ︙ | |||
184 185 186 187 188 189 190 191 192 193 194 195 196 197 |
if (proc == NULL) {
Tcl_DStringInit(&newName);
TclDStringAppendLiteral(&newName, "_");
native = Tcl_DStringAppend(&newName, native, -1);
proc = dlsym(handle, native); /* INTL: Native. */
Tcl_DStringFree(&newName);
}
Tcl_DStringFree(&ds);
if (proc == NULL) {
const char *errorStr = dlerror();
if (interp) {
if (!errorStr) {
errorStr = "unknown";
| > > > > > > > > > > > > > > > > > > > > > > > > > | 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 |
if (proc == NULL) {
Tcl_DStringInit(&newName);
TclDStringAppendLiteral(&newName, "_");
native = Tcl_DStringAppend(&newName, native, -1);
proc = dlsym(handle, native); /* INTL: Native. */
Tcl_DStringFree(&newName);
}
#ifdef __cplusplus
if (proc == NULL) {
char buf[32];
sprintf(buf, "%d", Tcl_DStringLength(&ds));
Tcl_DStringInit(&newName);
TclDStringAppendLiteral(&newName, "__Z");
Tcl_DStringAppend(&newName, buf, -1);
Tcl_DStringAppend(&newName, Tcl_DStringValue(&ds), -1);
TclDStringAppendLiteral(&newName, "P10Tcl_Interp");
native = Tcl_DStringValue(&newName);
proc = dlsym(handle, native + 1); /* INTL: Native. */
if (proc == NULL) {
proc = dlsym(handle, native); /* INTL: Native. */
}
if (proc == NULL) {
TclDStringAppendLiteral(&newName, "i");
native = Tcl_DStringValue(&newName);
proc = dlsym(handle, native + 1); /* INTL: Native. */
}
if (proc == NULL) {
proc = dlsym(handle, native); /* INTL: Native. */
}
Tcl_DStringFree(&newName);
}
#endif
Tcl_DStringFree(&ds);
if (proc == NULL) {
const char *errorStr = dlerror();
if (interp) {
if (!errorStr) {
errorStr = "unknown";
|
| ︙ | ︙ | |||
206 207 208 209 210 211 212 | } /* *---------------------------------------------------------------------- * * UnloadFile -- * | | | < | | | 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 |
}
/*
*----------------------------------------------------------------------
*
* UnloadFile --
*
* Unloads a dynamic shared object, after which all pointers to functions
* in the formerly-loaded object are no longer valid.
*
* Results:
* None.
*
* Side effects:
* Memory for the loaded object is deallocated.
*
*----------------------------------------------------------------------
*/
static void
UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
void *handle = loadHandle->clientData;
dlclose(handle);
ckfree(loadHandle);
}
/*
*----------------------------------------------------------------------
*
* TclGuessPackageName --
*
|
| ︙ | ︙ | |||
253 254 255 256 257 258 259 | * None. * *---------------------------------------------------------------------- */ int TclGuessPackageName( | | < | < | 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 |
* None.
*
*----------------------------------------------------------------------
*/
int
TclGuessPackageName(
TCL_UNUSED(const char *) /*fileName*/,
TCL_UNUSED(Tcl_DString *))
{
return 0;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to unix/tclLoadDyld.c.
| ︙ | ︙ | |||
179 180 181 182 183 184 185 |
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
| | | | 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 |
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
nativePath = (const char *)Tcl_FSGetNativePath(pathPtr);
nativeFileName = Tcl_UtfToExternalDString(NULL, Tcl_GetString(pathPtr),
-1, &ds);
#if TCL_DYLD_USE_DLFCN
/*
* Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
*/
|
| ︙ | ︙ | |||
254 255 256 257 258 259 260 |
if (err == NSObjectFileImageSuccess && dyldObjFileImage) {
int nsflags = NSLINKMODULE_OPTION_RETURN_ON_ERROR;
if (!(flags & 1)) nsflags |= NSLINKMODULE_OPTION_PRIVATE;
if (!(flags & 2)) nsflags |= NSLINKMODULE_OPTION_BINDNOW;
module = NSLinkModule(dyldObjFileImage, nativePath, nsflags);
NSDestroyObjectFileImage(dyldObjFileImage);
if (module) {
| | | | | 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 |
if (err == NSObjectFileImageSuccess && dyldObjFileImage) {
int nsflags = NSLINKMODULE_OPTION_RETURN_ON_ERROR;
if (!(flags & 1)) nsflags |= NSLINKMODULE_OPTION_PRIVATE;
if (!(flags & 2)) nsflags |= NSLINKMODULE_OPTION_BINDNOW;
module = NSLinkModule(dyldObjFileImage, nativePath, nsflags);
NSDestroyObjectFileImage(dyldObjFileImage);
if (module) {
modulePtr = (Tcl_DyldModuleHandle *)ckalloc(sizeof(Tcl_DyldModuleHandle));
modulePtr->module = module;
modulePtr->nextPtr = NULL;
} else {
NSLinkEditError(&editError, &errorNumber, &errorName,
&errMsg);
}
} else {
objFileImageErrMsg = DyldOFIErrorMsg(err);
}
}
}
#endif /* TCL_DYLD_USE_NSMODULE */
}
if (dlHandle
#if TCL_DYLD_USE_NSMODULE
|| dyldLibHeader || modulePtr
#endif /* TCL_DYLD_USE_NSMODULE */
) {
dyldLoadHandle = (Tcl_DyldLoadHandle *)ckalloc(sizeof(Tcl_DyldLoadHandle));
dyldLoadHandle->dlHandle = dlHandle;
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
dyldLoadHandle->dyldLibHeader = dyldLibHeader;
dyldLoadHandle->modulePtr = modulePtr;
#endif /* TCL_DYLD_USE_NSMODULE || TCL_LOAD_FROM_MEMORY */
newHandle = (Tcl_LoadHandle)ckalloc(sizeof(*newHandle));
newHandle->clientData = dyldLoadHandle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*unloadProcPtr = &UnloadFile;
*loadHandle = newHandle;
result = TCL_OK;
} else {
|
| ︙ | ︙ | |||
330 331 332 333 334 335 336 |
static void *
FindSymbol(
Tcl_Interp *interp, /* For error reporting. */
Tcl_LoadHandle loadHandle, /* Handle from TclpDlopen. */
const char *symbol) /* Symbol name to look up. */
{
| | | | 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 |
static void *
FindSymbol(
Tcl_Interp *interp, /* For error reporting. */
Tcl_LoadHandle loadHandle, /* Handle from TclpDlopen. */
const char *symbol) /* Symbol name to look up. */
{
Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *)loadHandle->clientData;
Tcl_PackageInitProc *proc = NULL;
const char *errMsg = NULL;
Tcl_DString ds;
const char *native;
native = Tcl_UtfToExternalDString(NULL, symbol, -1, &ds);
if (dyldLoadHandle->dlHandle) {
#if TCL_DYLD_USE_DLFCN
proc = (Tcl_PackageInitProc *)dlsym(dyldLoadHandle->dlHandle, native);
if (!proc) {
errMsg = dlerror();
}
#endif /* TCL_DYLD_USE_DLFCN */
} else {
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
NSSymbol nsSymbol = NULL;
|
| ︙ | ︙ | |||
377 378 379 380 381 382 383 |
while (modulePtr != NULL) {
if (module == modulePtr->module) {
break;
}
modulePtr = modulePtr->nextPtr;
}
if (modulePtr == NULL) {
| | | | | 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 |
while (modulePtr != NULL) {
if (module == modulePtr->module) {
break;
}
modulePtr = modulePtr->nextPtr;
}
if (modulePtr == NULL) {
modulePtr = (Tcl_DyldModuleHandle *)ckalloc(sizeof(Tcl_DyldModuleHandle));
modulePtr->module = module;
modulePtr->nextPtr = dyldLoadHandle->modulePtr;
dyldLoadHandle->modulePtr = modulePtr;
}
#endif /* DYLD_SUPPORTS_DYLIB_UNLOADING */
} else {
NSLinkEditErrors editError;
int errorNumber;
const char *errorName;
NSLinkEditError(&editError, &errorNumber, &errorName, &errMsg);
}
} else if (dyldLoadHandle->modulePtr) {
nsSymbol = NSLookupSymbolInModule(
dyldLoadHandle->modulePtr->module, native);
}
if (nsSymbol) {
proc = (Tcl_PackageInitProc *)NSAddressOfSymbol(nsSymbol);
}
Tcl_DStringFree(&newName);
#endif /* TCL_DYLD_USE_NSMODULE */
}
Tcl_DStringFree(&ds);
if (errMsg && (interp != NULL)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot find symbol \"%s\": %s", symbol, errMsg));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol,
NULL);
}
return (void *)proc;
}
/*
*----------------------------------------------------------------------
*
* UnloadFile --
*
|
| ︙ | ︙ | |||
436 437 438 439 440 441 442 |
static void
UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
| | | | | | 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 |
static void
UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
Tcl_DyldLoadHandle *dyldLoadHandle = (Tcl_DyldLoadHandle *)loadHandle->clientData;
if (dyldLoadHandle->dlHandle) {
#if TCL_DYLD_USE_DLFCN
(void) dlclose(dyldLoadHandle->dlHandle);
#endif /* TCL_DYLD_USE_DLFCN */
} else {
#if TCL_DYLD_USE_NSMODULE || defined(TCL_LOAD_FROM_MEMORY)
Tcl_DyldModuleHandle *modulePtr = dyldLoadHandle->modulePtr;
while (modulePtr != NULL) {
void *ptr = modulePtr;
(void) NSUnLinkModule(modulePtr->module,
NSUNLINKMODULE_OPTION_RESET_LAZY_REFERENCES);
modulePtr = modulePtr->nextPtr;
ckfree(ptr);
}
#endif /* TCL_DYLD_USE_NSMODULE */
}
ckfree(dyldLoadHandle);
ckfree(loadHandle);
}
/*
*----------------------------------------------------------------------
*
* TclGuessPackageName --
*
|
| ︙ | ︙ | |||
482 483 484 485 486 487 488 | * None. * *---------------------------------------------------------------------- */ int TclGuessPackageName( | | < | < | 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 |
* None.
*
*----------------------------------------------------------------------
*/
int
TclGuessPackageName(
TCL_UNUSED(const char *) /*fileName*/,
TCL_UNUSED(Tcl_DString *) /*bufPtr*/)
{
return 0;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
509 510 511 512 513 514 515 | * *---------------------------------------------------------------------- */ #ifdef TCL_LOAD_FROM_MEMORY MODULE_SCOPE void * TclpLoadMemoryGetBuffer( | | | 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 |
*
*----------------------------------------------------------------------
*/
#ifdef TCL_LOAD_FROM_MEMORY
MODULE_SCOPE void *
TclpLoadMemoryGetBuffer(
TCL_UNUSED(Tcl_Interp *),
int size) /* Size of desired buffer. */
{
void *buffer = NULL;
/*
* NSCreateObjectFileImageFromMemory is available but always fails
* prior to Darwin 7.
|
| ︙ | ︙ | |||
584 585 586 587 588 589 590 |
/*
* Try to create an object file image that we can load from.
*/
if (codeSize >= 0) {
NSObjectFileImageReturnCode err = NSObjectFileImageSuccess;
| | | 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 |
/*
* Try to create an object file image that we can load from.
*/
if (codeSize >= 0) {
NSObjectFileImageReturnCode err = NSObjectFileImageSuccess;
const struct fat_header *fh = (const struct fat_header *)buffer;
uint32_t ms = 0;
#ifndef __LP64__
const struct mach_header *mh = NULL;
# define mh_size sizeof(struct mach_header)
# define mh_magic MH_MAGIC
# define arch_abi 0
#else
|
| ︙ | ︙ | |||
613 614 615 616 617 618 619 |
if ((size_t) codeSize >= sizeof(struct fat_header) +
fh_nfat_arch * sizeof(struct fat_arch)) {
void *fatarchs = (char*)buffer + sizeof(struct fat_header);
const NXArchInfo *arch = NXGetLocalArchInfo();
struct fat_arch *fa;
if (fh->magic != FAT_MAGIC) {
| | | | | | | 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 |
if ((size_t) codeSize >= sizeof(struct fat_header) +
fh_nfat_arch * sizeof(struct fat_arch)) {
void *fatarchs = (char*)buffer + sizeof(struct fat_header);
const NXArchInfo *arch = NXGetLocalArchInfo();
struct fat_arch *fa;
if (fh->magic != FAT_MAGIC) {
swap_fat_arch((struct fat_arch *)fatarchs, fh_nfat_arch, arch->byteorder);
}
fa = NXFindBestFatArch(arch->cputype | arch_abi,
arch->cpusubtype, (struct fat_arch *)fatarchs, fh_nfat_arch);
if (fa) {
mh = (const struct mach_header_64 *)((char *) buffer + fa->offset);
ms = fa->size;
} else {
err = NSObjectFileImageInappropriateFile;
}
if (fh->magic != FAT_MAGIC) {
swap_fat_arch((struct fat_arch *)fatarchs, fh_nfat_arch, arch->byteorder);
}
} else {
err = NSObjectFileImageInappropriateFile;
}
} else {
/*
* Thin binary
*/
mh = (const struct mach_header_64 *)buffer;
ms = codeSize;
}
if (ms && !(ms >= mh_size && mh->magic == mh_magic &&
mh->filetype == MH_BUNDLE)) {
err = NSObjectFileImageInappropriateFile;
}
if (err == NSObjectFileImageSuccess) {
|
| ︙ | ︙ | |||
689 690 691 692 693 694 695 |
return TCL_ERROR;
}
/*
* Stash the module reference within the load handle we create and return.
*/
| | | | | 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 |
return TCL_ERROR;
}
/*
* Stash the module reference within the load handle we create and return.
*/
modulePtr = (Tcl_DyldModuleHandle *)ckalloc(sizeof(Tcl_DyldModuleHandle));
modulePtr->module = module;
modulePtr->nextPtr = NULL;
dyldLoadHandle = (Tcl_DyldLoadHandle *)ckalloc(sizeof(Tcl_DyldLoadHandle));
dyldLoadHandle->dlHandle = NULL;
dyldLoadHandle->dyldLibHeader = NULL;
dyldLoadHandle->modulePtr = modulePtr;
newHandle = (Tcl_LoadHandle)ckalloc(sizeof(*newHandle));
newHandle->clientData = dyldLoadHandle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*loadHandle = newHandle;
*unloadProcPtr = &UnloadFile;
return TCL_OK;
}
|
| ︙ | ︙ |
Changes to unix/tclLoadNext.c.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
char *fileName;
char *files[2];
const char *native;
int result = 1;
NXStream *errorStream = NXOpenMemory(0,0,NX_READWRITE);
| | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
char *fileName;
char *files[2];
const char *native;
int result = 1;
NXStream *errorStream = NXOpenMemory(0,0,NX_READWRITE);
fileName = Tcl_GetString(pathPtr);
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
|
| ︙ | ︙ | |||
97 98 99 100 101 102 103 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s", fileName, data));
NXCloseMemory(errorStream, NX_FREEBUFFER);
return TCL_ERROR;
}
NXCloseMemory(errorStream, NX_FREEBUFFER);
| | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 |
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s", fileName, data));
NXCloseMemory(errorStream, NX_FREEBUFFER);
return TCL_ERROR;
}
NXCloseMemory(errorStream, NX_FREEBUFFER);
newHandle = (Tcl_LoadHandle) ckalloc(sizeof(*newHandle));
newHandle->clientData = INT2PTR(1);
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*loadHandle = newHandle;
*unloadProcPtr = &UnloadFile;
return TCL_OK;
|
| ︙ | ︙ | |||
171 172 173 174 175 176 177 |
void
UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
| | | 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 |
void
UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
ckfree(loadHandle);
}
/*
*----------------------------------------------------------------------
*
* TclGuessPackageName --
*
|
| ︙ | ︙ |
Changes to unix/tclLoadOSF.c.
| ︙ | ︙ | |||
75 76 77 78 79 80 81 |
* function which should be used for this
* file. */
int flags)
{
Tcl_LoadHandle newHandle;
ldr_module_t lm;
char *pkg;
| | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 |
* function which should be used for this
* file. */
int flags)
{
Tcl_LoadHandle newHandle;
ldr_module_t lm;
char *pkg;
char *fileName = Tcl_GetString(pathPtr);
const char *native;
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
|
| ︙ | ︙ | |||
124 125 126 127 128 129 130 |
*/
if ((pkg = strrchr(fileName, '/')) == NULL) {
pkg = fileName;
} else {
pkg++;
}
| | | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 |
*/
if ((pkg = strrchr(fileName, '/')) == NULL) {
pkg = fileName;
} else {
pkg++;
}
newHandle = (Tcl_LoadHandle)ckalloc(sizeof(*newHandle));
newHandle->clientData = pkg;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*loadHandle = newHandle;
*unloadProcPtr = &UnloadFile;
return TCL_OK;
}
|
| ︙ | ︙ | |||
189 190 191 192 193 194 195 |
static void
UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
| | | 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 |
static void
UnloadFile(
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
ckfree(loadHandle);
}
/*
*----------------------------------------------------------------------
*
* TclGuessPackageName --
*
|
| ︙ | ︙ |
Changes to unix/tclLoadShl.c.
| ︙ | ︙ | |||
53 54 55 56 57 58 59 |
* function which should be used for this
* file. */
int flags)
{
shl_t handle;
Tcl_LoadHandle newHandle;
const char *native;
| | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 |
* function which should be used for this
* file. */
int flags)
{
shl_t handle;
Tcl_LoadHandle newHandle;
const char *native;
char *fileName = Tcl_GetString(pathPtr);
/*
* The flags below used to be BIND_IMMEDIATE; they were changed at the
* suggestion of Wolfgang Kechel (wolfgang@prs.de): "This enables
* verbosity for missing symbols when loading a shared lib and allows to
* load libtk8.0.sl into tclsh8.0 without problems. In general, this
* delays resolving symbols until they are actually needed. Shared libs
|
| ︙ | ︙ | |||
93 94 95 96 97 98 99 |
if (handle == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s",
fileName, Tcl_PosixError(interp)));
return TCL_ERROR;
}
| | | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 |
if (handle == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s",
fileName, Tcl_PosixError(interp)));
return TCL_ERROR;
}
newHandle = (Tcl_LoadHandle)ckalloc(sizeof(*newHandle));
newHandle->clientData = handle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = *unloadProcPtr = &UnloadFile;
*loadHandle = newHandle;
return TCL_OK;
}
|
| ︙ | ︙ | |||
178 179 180 181 182 183 184 |
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
shl_t handle = (shl_t) loadHandle->clientData;
shl_unload(handle);
| | | 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 |
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
shl_t handle = (shl_t) loadHandle->clientData;
shl_unload(handle);
ckfree(loadHandle);
}
/*
*----------------------------------------------------------------------
*
* TclGuessPackageName --
*
|
| ︙ | ︙ |
Changes to unix/tclSelectNotfy.c.
| ︙ | ︙ | |||
206 207 208 209 210 211 212 213 214 215 |
static int FileHandlerEventProc(Tcl_Event *evPtr, int flags);
/*
* Import of critical bits of Windows API when building threaded with Cygwin.
*/
#if defined(__CYGWIN__)
typedef struct {
void *hwnd; /* Messaging window. */
unsigned int *message; /* Message payload. */
| > > > | | > | | > > > | | | | | | | > > > | 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 |
static int FileHandlerEventProc(Tcl_Event *evPtr, int flags);
/*
* Import of critical bits of Windows API when building threaded with Cygwin.
*/
#if defined(__CYGWIN__)
#ifdef __cplusplus
extern "C" {
#endif
typedef struct {
void *hwnd; /* Messaging window. */
unsigned int *message; /* Message payload. */
size_t wParam; /* Event-specific "word" parameter. */
size_t lParam; /* Event-specific "long" parameter. */
int time; /* Event timestamp. */
int x; /* Event location (where meaningful). */
int y;
int lPrivate;
} MSG;
typedef struct {
unsigned int style;
void *lpfnWndProc;
int cbClsExtra;
int cbWndExtra;
void *hInstance;
void *hIcon;
void *hCursor;
void *hbrBackground;
const void *lpszMenuName;
const void *lpszClassName;
} WNDCLASSW;
#ifdef __clang__
#pragma clang diagnostic ignored "-Wignored-attributes"
#endif
extern void __stdcall CloseHandle(void *);
extern void *__stdcall CreateEventW(void *, unsigned char, unsigned char,
void *);
extern void *__stdcall CreateWindowExW(void *, const void *, const void *,
unsigned int, int, int, int, int, void *, void *, void *,
void *);
extern unsigned int __stdcall DefWindowProcW(void *, int, void *, void *);
extern unsigned char __stdcall DestroyWindow(void *);
extern int __stdcall DispatchMessageW(const MSG *);
extern unsigned char __stdcall GetMessageW(MSG *, void *, int, int);
extern void __stdcall MsgWaitForMultipleObjects(unsigned int, void *,
unsigned char, unsigned int, unsigned int);
extern unsigned char __stdcall PeekMessageW(MSG *, void *, int, int, int);
extern unsigned char __stdcall PostMessageW(void *, unsigned int, void *,
void *);
extern void __stdcall PostQuitMessage(int);
extern void *__stdcall RegisterClassW(const WNDCLASSW *);
extern unsigned char __stdcall ResetEvent(void *);
extern unsigned char __stdcall TranslateMessage(const MSG *);
/*
* Threaded-cygwin specific constants and functions in this file:
*/
static const wchar_t className[] = L"TclNotifier";
static unsigned int __stdcall NotifierProc(void *hwnd, unsigned int message,
void *wParam, void *lParam);
#ifdef __cplusplus
}
#endif
#endif /* TCL_THREADS && __CYGWIN__ */
#include "tclUnixNotfy.c"
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
293 294 295 296 297 298 299 |
tsdPtr->eventReady = 0;
/*
* Initialize thread specific condition variable for this thread.
*/
if (tsdPtr->waitCVinitialized == 0) {
#ifdef __CYGWIN__
| | | | | | | | | | | | | | | | | 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 |
tsdPtr->eventReady = 0;
/*
* Initialize thread specific condition variable for this thread.
*/
if (tsdPtr->waitCVinitialized == 0) {
#ifdef __CYGWIN__
WNDCLASSW clazz;
clazz.style = 0;
clazz.cbClsExtra = 0;
clazz.cbWndExtra = 0;
clazz.hInstance = TclWinGetTclInstance();
clazz.hbrBackground = NULL;
clazz.lpszMenuName = NULL;
clazz.lpszClassName = className;
clazz.lpfnWndProc = (void *)NotifierProc;
clazz.hIcon = NULL;
clazz.hCursor = NULL;
RegisterClassW(&clazz);
tsdPtr->hwnd = CreateWindowExW(NULL, clazz.lpszClassName,
clazz.lpszClassName, 0, 0, 0, 0, 0, NULL, NULL,
clazz.hInstance, NULL);
tsdPtr->event = CreateEventW(NULL, 1 /* manual */,
0 /* !signaled */, NULL);
#else
pthread_cond_init(&tsdPtr->waitCV, NULL);
#endif /* __CYGWIN__ */
tsdPtr->waitCVinitialized = 1;
}
|
| ︙ | ︙ | |||
363 364 365 366 367 368 369 | * notifier instance. * *---------------------------------------------------------------------- */ void Tcl_FinalizeNotifier( | | | 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 |
* notifier instance.
*
*----------------------------------------------------------------------
*/
void
Tcl_FinalizeNotifier(
ClientData clientData)
{
if (tclNotifierHooks.finalizeNotifierProc) {
tclNotifierHooks.finalizeNotifierProc(clientData);
return;
} else {
#if TCL_THREADS
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
460 461 462 463 464 465 466 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
| | | 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 |
for (filePtr = tsdPtr->firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
filePtr = (FileHandler *)ckalloc(sizeof(FileHandler));
filePtr->fd = fd;
filePtr->readyMask = 0;
filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
tsdPtr->firstFileHandlerPtr = filePtr;
}
filePtr->proc = proc;
filePtr->clientData = clientData;
|
| ︙ | ︙ | |||
579 580 581 582 583 584 585 |
*/
if (prevPtr == NULL) {
tsdPtr->firstFileHandlerPtr = filePtr->nextPtr;
} else {
prevPtr->nextPtr = filePtr->nextPtr;
}
| | | | 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 |
*/
if (prevPtr == NULL) {
tsdPtr->firstFileHandlerPtr = filePtr->nextPtr;
} else {
prevPtr->nextPtr = filePtr->nextPtr;
}
ckfree(filePtr);
}
}
#if defined(__CYGWIN__)
static unsigned int __stdcall
NotifierProc(
void *hwnd,
unsigned int message,
void *wParam,
void *lParam)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 |
{
if (tclNotifierHooks.waitForEventProc) {
return tclNotifierHooks.waitForEventProc(timePtr);
} else {
FileHandler *filePtr;
int mask;
Tcl_Time vTime;
#if TCL_THREADS
int waitForFiles;
# ifdef __CYGWIN__
MSG msg;
# endif /* __CYGWIN__ */
#else /* !TCL_THREADS */
/*
* Impl. notes: timeout & timeoutPtr are used if, and only if threads
* are not enabled. They are the arguments for the regular select()
* used when the core is not thread-enabled.
*/
struct timeval timeout, *timeoutPtr;
int numFound;
#endif /* TCL_THREADS */
| > < | 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 |
{
if (tclNotifierHooks.waitForEventProc) {
return tclNotifierHooks.waitForEventProc(timePtr);
} else {
FileHandler *filePtr;
int mask;
Tcl_Time vTime;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#if TCL_THREADS
int waitForFiles;
# ifdef __CYGWIN__
MSG msg;
# endif /* __CYGWIN__ */
#else /* !TCL_THREADS */
/*
* Impl. notes: timeout & timeoutPtr are used if, and only if threads
* are not enabled. They are the arguments for the regular select()
* used when the core is not thread-enabled.
*/
struct timeval timeout, *timeoutPtr;
int numFound;
#endif /* TCL_THREADS */
/*
* Set up the timeout structure. Note that if there are no events to
* check for, we return with a negative result rather than blocking
* forever.
*/
|
| ︙ | ︙ | |||
756 757 758 759 760 761 762 |
FD_ZERO(&tsdPtr->readyMasks.readable);
FD_ZERO(&tsdPtr->readyMasks.writable);
FD_ZERO(&tsdPtr->readyMasks.exception);
if (!tsdPtr->eventReady) {
#ifdef __CYGWIN__
if (!PeekMessageW(&msg, NULL, 0, 0, 0)) {
| | | 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 |
FD_ZERO(&tsdPtr->readyMasks.readable);
FD_ZERO(&tsdPtr->readyMasks.writable);
FD_ZERO(&tsdPtr->readyMasks.exception);
if (!tsdPtr->eventReady) {
#ifdef __CYGWIN__
if (!PeekMessageW(&msg, NULL, 0, 0, 0)) {
unsigned int timeout;
if (timePtr) {
timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
} else {
timeout = 0xFFFFFFFF;
}
pthread_mutex_unlock(¬ifierMutex);
|
| ︙ | ︙ | |||
791 792 793 794 795 796 797 |
#ifdef __CYGWIN__
while (PeekMessageW(&msg, NULL, 0, 0, 0)) {
/*
* Retrieve and dispatch the message.
*/
| | | | 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 |
#ifdef __CYGWIN__
while (PeekMessageW(&msg, NULL, 0, 0, 0)) {
/*
* Retrieve and dispatch the message.
*/
unsigned int result = GetMessageW(&msg, NULL, 0, 0);
if (result == 0) {
PostQuitMessage(msg.wParam);
/* What to do here? */
} else if (result != (unsigned int) -1) {
TranslateMessage(&msg);
DispatchMessageW(&msg);
}
}
ResetEvent(tsdPtr->event);
#endif /* __CYGWIN__ */
|
| ︙ | ︙ | |||
873 874 875 876 877 878 879 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr =
| | | 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 |
/*
* Don't bother to queue an event if the mask was previously
* non-zero since an event must still be on the queue.
*/
if (filePtr->readyMask == 0) {
FileHandlerEvent *fileEvPtr =
(FileHandlerEvent *)ckalloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
}
filePtr->readyMask = mask;
}
|
| ︙ | ︙ | |||
915 916 917 918 919 920 921 | * *---------------------------------------------------------------------- */ #if TCL_THREADS static TCL_NORETURN void NotifierThreadProc( | | | | 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 |
*
*----------------------------------------------------------------------
*/
#if TCL_THREADS
static TCL_NORETURN void
NotifierThreadProc(
TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr;
fd_set readableMask;
fd_set writableMask;
fd_set exceptionMask;
int i;
int fds[2], receivePipe;
long found;
struct timeval poll = {0, 0}, *timePtr;
char buf[2];
int numFdBits = 0;
if (pipe(fds) != 0) {
Tcl_Panic("NotifierThreadProc: %s", "could not create trigger pipe");
}
|
| ︙ | ︙ |
Changes to unix/tclUnixChan.c.
| ︙ | ︙ | |||
92 93 94 95 96 97 98 | #endif /* SUPPORTS_TTY */ } TtyState; #ifdef SUPPORTS_TTY /* * The following structure is used to set or get the serial port attributes in | | | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 |
#endif /* SUPPORTS_TTY */
} TtyState;
#ifdef SUPPORTS_TTY
/*
* The following structure is used to set or get the serial port attributes in
* a platform-independent manner.
*/
typedef struct {
int baud;
int parity;
int data;
int stop;
|
| ︙ | ︙ | |||
115 116 117 118 119 120 121 |
Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); \
}
/*
* Static routines for this file:
*/
| | | | | | | | > | > | | | | | | | | > > > > | | | | 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 |
Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL); \
}
/*
* Static routines for this file:
*/
static int FileBlockModeProc(void *instanceData, int mode);
static int FileCloseProc(void *instanceData,
Tcl_Interp *interp, int flags);
static int FileGetHandleProc(void *instanceData,
int direction, void **handlePtr);
static int FileInputProc(void *instanceData, char *buf,
int toRead, int *errorCode);
static int FileOutputProc(void *instanceData,
const char *buf, int toWrite, int *errorCode);
#ifndef TCL_NO_DEPRECATED
static int FileSeekProc(void *instanceData, long offset,
int mode, int *errorCode);
#endif
static int FileTruncateProc(void *instanceData,
Tcl_WideInt length);
static Tcl_WideInt FileWideSeekProc(void *instanceData,
Tcl_WideInt offset, int mode, int *errorCode);
static void FileWatchProc(void *instanceData, int mask);
#ifdef SUPPORTS_TTY
static int TtyCloseProc(void *instanceData,
Tcl_Interp *interp, int flags);
static void TtyGetAttributes(int fd, TtyAttrs *ttyPtr);
static int TtyGetOptionProc(void *instanceData,
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
static int TtyGetBaud(speed_t speed);
static speed_t TtyGetSpeed(int baud);
static void TtyInit(int fd);
static void TtyModemStatusStr(int status, Tcl_DString *dsPtr);
static int TtyParseMode(Tcl_Interp *interp, const char *mode,
TtyAttrs *ttyPtr);
static void TtySetAttributes(int fd, TtyAttrs *ttyPtr);
static int TtySetOptionProc(void *instanceData,
Tcl_Interp *interp, const char *optionName,
const char *value);
#endif /* SUPPORTS_TTY */
/*
* This structure describes the channel type structure for file based IO:
*/
static const Tcl_ChannelType fileChannelType = {
"file", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
TCL_CLOSE2PROC, /* Close proc. */
FileInputProc, /* Input proc. */
FileOutputProc, /* Output proc. */
#ifndef TCL_NO_DEPRECATED
FileSeekProc, /* Seek proc. */
#else
NULL,
#endif
NULL, /* Set option proc. */
NULL, /* Get option proc. */
FileWatchProc, /* Initialize notifier. */
FileGetHandleProc, /* Get OS handles out of channel. */
FileCloseProc, /* close2proc. */
FileBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
FileWideSeekProc, /* wide seek proc. */
NULL,
FileTruncateProc /* truncate proc. */
};
#ifdef SUPPORTS_TTY
/*
* This structure describes the channel type structure for serial IO.
* Note that this type is a subclass of the "file" type.
*/
static const Tcl_ChannelType ttyChannelType = {
"tty", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
TCL_CLOSE2PROC, /* Close proc. */
FileInputProc, /* Input proc. */
FileOutputProc, /* Output proc. */
NULL, /* Seek proc. */
TtySetOptionProc, /* Set option proc. */
TtyGetOptionProc, /* Get option proc. */
FileWatchProc, /* Initialize notifier. */
FileGetHandleProc, /* Get OS handles out of channel. */
TtyCloseProc, /* close2proc. */
FileBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
NULL, /* wide seek proc. */
NULL, /* thread action proc. */
NULL /* truncate proc. */
};
|
| ︙ | ︙ | |||
218 219 220 221 222 223 224 | * * Side effects: * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ | < | | | 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 |
*
* Side effects:
* Sets the device into blocking or non-blocking mode.
*
*----------------------------------------------------------------------
*/
static int
FileBlockModeProc(
void *instanceData, /* File state. */
int mode) /* The mode to set. Can be TCL_MODE_BLOCKING
* or TCL_MODE_NONBLOCKING. */
{
FileState *fsPtr = (FileState *)instanceData;
if (TclUnixSetBlockingMode(fsPtr->fd, mode) < 0) {
return errno;
}
return 0;
}
|
| ︙ | ︙ | |||
254 255 256 257 258 259 260 | * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ static int FileInputProc( | | | | | 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 |
* Reads input from the input device of the channel.
*
*----------------------------------------------------------------------
*/
static int
FileInputProc(
void *instanceData, /* File state. */
char *buf, /* Where to store data read. */
int toRead, /* How much space is available in the
* buffer? */
int *errorCodePtr) /* Where to store error code. */
{
FileState *fsPtr = (FileState *)instanceData;
int bytesRead; /* How many bytes were actually read from the
* input device? */
*errorCodePtr = 0;
/*
* Assume there is always enough input available. This will block
* appropriately, and read will unblock as soon as a short read is
* possible, if the channel is in blocking mode. If the channel is
* nonblocking, the read will never block.
*/
bytesRead = read(fsPtr->fd, buf, (size_t) toRead);
if (bytesRead > -1) {
return bytesRead;
}
*errorCodePtr = errno;
return -1;
}
|
| ︙ | ︙ | |||
301 302 303 304 305 306 307 | * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ static int FileOutputProc( | | | | | 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 |
* Writes output on the output device of the channel.
*
*----------------------------------------------------------------------
*/
static int
FileOutputProc(
void *instanceData, /* File state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
{
FileState *fsPtr = (FileState *)instanceData;
int written;
*errorCodePtr = 0;
if (toWrite == 0) {
/*
* SF Tcl Bug 465765. Do not try to write nothing into a file. STREAM
* based implementations will considers this as EOF (if there is a
* pipe behind the file).
*/
return 0;
}
written = write(fsPtr->fd, buf, (size_t) toWrite);
if (written > -1) {
return written;
}
*errorCodePtr = errno;
return -1;
}
|
| ︙ | ︙ | |||
348 349 350 351 352 353 354 | * Closes the device of the channel. * *---------------------------------------------------------------------- */ static int FileCloseProc( | | | > | > > > > | | | > | > > > | 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 |
* Closes the device of the channel.
*
*----------------------------------------------------------------------
*/
static int
FileCloseProc(
void *instanceData, /* File state. */
TCL_UNUSED(Tcl_Interp *),
int flags)
{
FileState *fsPtr = (FileState *)instanceData;
int errorCode = 0;
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
Tcl_DeleteFileHandler(fsPtr->fd);
/*
* Do not close standard channels while in thread-exit.
*/
if (!TclInThreadExit()
|| ((fsPtr->fd != 0) && (fsPtr->fd != 1) && (fsPtr->fd != 2))) {
if (close(fsPtr->fd) < 0) {
errorCode = errno;
}
}
ckfree(fsPtr);
return errorCode;
}
#ifdef SUPPORTS_TTY
static int
TtyCloseProc(
void *instanceData,
Tcl_Interp *interp,
int flags)
{
TtyState *ttyPtr = (TtyState*)instanceData;
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
/*
* If we've been asked by the user to drain or flush, do so now.
*/
switch (ttyPtr->closeMode) {
case CLOSE_DRAIN:
tcdrain(ttyPtr->fileState.fd);
|
| ︙ | ︙ | |||
406 407 408 409 410 411 412 |
tcsetattr(ttyPtr->fileState.fd, TCSANOW, &ttyPtr->initState);
}
/*
* Delegate to close for files.
*/
| | | 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 |
tcsetattr(ttyPtr->fileState.fd, TCSANOW, &ttyPtr->initState);
}
/*
* Delegate to close for files.
*/
return FileCloseProc(instanceData, interp, flags);
}
#endif /* SUPPORTS_TTY */
/*
*----------------------------------------------------------------------
*
* FileSeekProc --
|
| ︙ | ︙ | |||
428 429 430 431 432 433 434 | * * Side effects: * Moves the location at which the channel will be accessed in future * operations. * *---------------------------------------------------------------------- */ | | | | | 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 |
*
* Side effects:
* Moves the location at which the channel will be accessed in future
* operations.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
static int
FileSeekProc(
void *instanceData, /* File state. */
long offset, /* Offset to seek to. */
int mode, /* Relative to where should we seek? Can be
* one of SEEK_START, SEEK_SET or SEEK_END. */
int *errorCodePtr) /* To store error code. */
{
FileState *fsPtr = (FileState *)instanceData;
Tcl_WideInt oldLoc, newLoc;
/*
* Save our current place in case we need to roll-back the seek.
*/
oldLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) 0, SEEK_CUR);
|
| ︙ | ︙ | |||
469 470 471 472 473 474 475 476 477 478 479 480 481 482 |
TclOSseek(fsPtr->fd, (Tcl_SeekOffset) oldLoc, SEEK_SET);
return -1;
} else {
*errorCodePtr = (newLoc == -1) ? errno : 0;
}
return (int) newLoc;
}
/*
*----------------------------------------------------------------------
*
* FileWideSeekProc --
*
* This function is called by the generic IO level to move the access
| > | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 |
TclOSseek(fsPtr->fd, (Tcl_SeekOffset) oldLoc, SEEK_SET);
return -1;
} else {
*errorCodePtr = (newLoc == -1) ? errno : 0;
}
return (int) newLoc;
}
#endif
/*
*----------------------------------------------------------------------
*
* FileWideSeekProc --
*
* This function is called by the generic IO level to move the access
|
| ︙ | ︙ | |||
492 493 494 495 496 497 498 | * operations. * *---------------------------------------------------------------------- */ static Tcl_WideInt FileWideSeekProc( | | | | 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 |
* operations.
*
*----------------------------------------------------------------------
*/
static Tcl_WideInt
FileWideSeekProc(
void *instanceData, /* File state. */
Tcl_WideInt offset, /* Offset to seek to. */
int mode, /* Relative to where should we seek? Can be
* one of SEEK_START, SEEK_CUR or SEEK_END. */
int *errorCodePtr) /* To store error code. */
{
FileState *fsPtr = (FileState *)instanceData;
Tcl_WideInt newLoc;
newLoc = TclOSseek(fsPtr->fd, (Tcl_SeekOffset) offset, mode);
*errorCodePtr = (newLoc == -1) ? errno : 0;
return newLoc;
}
|
| ︙ | ︙ | |||
526 527 528 529 530 531 532 | * be seen by Tcl. * *---------------------------------------------------------------------- */ static void FileWatchProc( | | | | 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 |
* be seen by Tcl.
*
*----------------------------------------------------------------------
*/
static void
FileWatchProc(
void *instanceData, /* The file state. */
int mask) /* Events of interest; an OR-ed combination of
* TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
FileState *fsPtr = (FileState *)instanceData;
/*
* Make sure we only register for events that are valid on this file. Note
* that we are passing Tcl_NotifyChannel directly to Tcl_CreateFileHandler
* with the channel pointer as the client data.
*/
|
| ︙ | ︙ | |||
568 569 570 571 572 573 574 | * None. * *---------------------------------------------------------------------- */ static int FileGetHandleProc( | | | | | 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 |
* None.
*
*----------------------------------------------------------------------
*/
static int
FileGetHandleProc(
void *instanceData, /* The file state. */
int direction, /* TCL_READABLE or TCL_WRITABLE */
void **handlePtr) /* Where to store the handle. */
{
FileState *fsPtr = (FileState *)instanceData;
if (direction & fsPtr->validMask) {
*handlePtr = INT2PTR(fsPtr->fd);
return TCL_OK;
}
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
635 636 637 638 639 640 641 | * calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int TtySetOptionProc( | | | | | 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 |
* calling Tcl_BadChannelOption).
*
*----------------------------------------------------------------------
*/
static int
TtySetOptionProc(
void *instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Which option to set? */
const char *value) /* New value for option. */
{
TtyState *fsPtr = (TtyState *)instanceData;
unsigned int len, vlen;
TtyAttrs tty;
int argc;
const char **argv;
struct termios iostate;
len = strlen(optionName);
vlen = strlen(value);
|
| ︙ | ︙ | |||
726 727 728 729 730 731 732 |
badXchar:
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -xchar: should be a list of"
" two elements with each a single 8-bit character", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL);
}
| | | 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 |
badXchar:
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -xchar: should be a list of"
" two elements with each a single 8-bit character", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL);
}
ckfree(argv);
return TCL_ERROR;
}
tcgetattr(fsPtr->fileState.fd, &iostate);
iostate.c_cc[VSTART] = argv[0][0];
iostate.c_cc[VSTOP] = argv[1][0];
|
| ︙ | ︙ | |||
749 750 751 752 753 754 755 |
iostate.c_cc[VSTART] = character;
charLen = Tcl_UtfToUniChar(argv[1], &character);
if ((character > 0xFF) || argv[1][charLen]) {
goto badXchar;
}
iostate.c_cc[VSTOP] = character;
}
| | | 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 |
iostate.c_cc[VSTART] = character;
charLen = Tcl_UtfToUniChar(argv[1], &character);
if ((character > 0xFF) || argv[1][charLen]) {
goto badXchar;
}
iostate.c_cc[VSTOP] = character;
}
ckfree(argv);
tcsetattr(fsPtr->fileState.fd, TCSADRAIN, &iostate);
return TCL_OK;
}
/*
* Option -timeout msec
|
| ︙ | ︙ | |||
791 792 793 794 795 796 797 |
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -ttycontrol: should be a list of"
" signal,value pairs", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
| | | | 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 |
if (interp) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -ttycontrol: should be a list of"
" signal,value pairs", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
ckfree(argv);
return TCL_ERROR;
}
ioctl(fsPtr->fileState.fd, TIOCMGET, &control);
for (i = 0; i < argc-1; i += 2) {
if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) {
ckfree(argv);
return TCL_ERROR;
}
if (Tcl_UtfNcasecmp(argv[i], "DTR", strlen(argv[i])) == 0) {
if (flag) {
SET_BITS(control, TIOCM_DTR);
} else {
CLEAR_BITS(control, TIOCM_DTR);
|
| ︙ | ︙ | |||
822 823 824 825 826 827 828 |
if (flag) {
ioctl(fsPtr->fileState.fd, TIOCSBRK, NULL);
} else {
ioctl(fsPtr->fileState.fd, TIOCCBRK, NULL);
}
#else /* TIOCSBRK & TIOCCBRK */
UNSUPPORTED_OPTION("-ttycontrol BREAK");
| | | | | 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 |
if (flag) {
ioctl(fsPtr->fileState.fd, TIOCSBRK, NULL);
} else {
ioctl(fsPtr->fileState.fd, TIOCCBRK, NULL);
}
#else /* TIOCSBRK & TIOCCBRK */
UNSUPPORTED_OPTION("-ttycontrol BREAK");
ckfree(argv);
return TCL_ERROR;
#endif /* TIOCSBRK & TIOCCBRK */
} else {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad signal \"%s\" for -ttycontrol: must be"
" DTR, RTS or BREAK", argv[i]));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
"VALUE", NULL);
}
ckfree(argv);
return TCL_ERROR;
}
} /* -ttycontrol options loop */
ioctl(fsPtr->fileState.fd, TIOCMSET, &control);
ckfree(argv);
return TCL_OK;
#else /* TIOCMGET&TIOCMSET */
UNSUPPORTED_OPTION("-ttycontrol");
#endif /* TIOCMGET&TIOCMSET */
}
/*
|
| ︙ | ︙ | |||
974 975 976 977 978 979 980 | * (by calling Tcl_BadChannelOption). * *---------------------------------------------------------------------- */ static int TtyGetOptionProc( | | | | | 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 |
* (by calling Tcl_BadChannelOption).
*
*----------------------------------------------------------------------
*/
static int
TtyGetOptionProc(
void *instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Option to get. */
Tcl_DString *dsPtr) /* Where to store value(s). */
{
TtyState *fsPtr = (TtyState *)instanceData;
unsigned int len;
char buf[3*TCL_INTEGER_SPACE + 16];
int valid = 0; /* Flag if valid option parsed. */
struct termios iostate;
if (optionName == NULL) {
len = 0;
} else {
|
| ︙ | ︙ | |||
1648 1649 1650 1651 1652 1653 1654 |
* This may occurr if modeString was "", for example.
*/
Tcl_Panic("TclpOpenFileChannel: invalid mode value");
return NULL;
}
| | | 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 |
* This may occurr if modeString was "", for example.
*/
Tcl_Panic("TclpOpenFileChannel: invalid mode value");
return NULL;
}
native = (const char *)Tcl_FSGetNativePath(pathPtr);
if (native == NULL) {
if (interp != (Tcl_Interp *) NULL) {
Tcl_AppendResult(interp, "couldn't open \"",
TclGetString(pathPtr), "\": filename is invalid on this platform",
NULL);
}
return NULL;
|
| ︙ | ︙ | |||
1708 1709 1710 1711 1712 1713 1714 |
#endif /* SUPPORTS_TTY */
{
translation = NULL;
channelTypePtr = &fileChannelType;
sprintf(channelName, "file%d", fd);
}
| | | 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 |
#endif /* SUPPORTS_TTY */
{
translation = NULL;
channelTypePtr = &fileChannelType;
sprintf(channelName, "file%d", fd);
}
fsPtr = (TtyState *)ckalloc(sizeof(TtyState));
fsPtr->fileState.validMask = channelPermissions | TCL_EXCEPTION;
fsPtr->fileState.fd = fd;
#ifdef SUPPORTS_TTY
if (channelTypePtr == &ttyChannelType) {
fsPtr->closeMode = CLOSE_DEFAULT;
fsPtr->doReset = 0;
tcgetattr(fsPtr->fileState.fd, &fsPtr->initState);
|
| ︙ | ︙ | |||
1759 1760 1761 1762 1763 1764 1765 | * None. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_MakeFileChannel( | | | > > > < < < < < | | | | | < < < | | 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 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 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_MakeFileChannel(
void *handle, /* OS level handle. */
int mode) /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
TtyState *fsPtr;
char channelName[16 + TCL_INTEGER_SPACE];
int fd = PTR2INT(handle);
const Tcl_ChannelType *channelTypePtr;
struct sockaddr sockaddr;
socklen_t sockaddrLen = sizeof(sockaddr);
if (mode == 0) {
return NULL;
}
sockaddr.sa_family = AF_UNSPEC;
#ifdef SUPPORTS_TTY
if (isatty(fd)) {
channelTypePtr = &ttyChannelType;
sprintf(channelName, "serial%d", fd);
} else
#endif /* SUPPORTS_TTY */
if ((getsockname(fd, (struct sockaddr *) &sockaddr, &sockaddrLen) == 0)
&& (sockaddrLen > 0)
&& (sockaddr.sa_family == AF_INET
|| sockaddr.sa_family == AF_INET6)) {
return (Tcl_Channel)TclpMakeTcpClientChannelMode(INT2PTR(fd), mode);
} else {
channelTypePtr = &fileChannelType;
sprintf(channelName, "file%d", fd);
}
fsPtr = (TtyState *)ckalloc(sizeof(TtyState));
fsPtr->fileState.fd = fd;
fsPtr->fileState.validMask = mode | TCL_EXCEPTION;
fsPtr->fileState.channel = Tcl_CreateChannel(channelTypePtr, channelName,
fsPtr, mode);
#ifdef SUPPORTS_TTY
if (channelTypePtr == &ttyChannelType) {
fsPtr->closeMode = CLOSE_DEFAULT;
|
| ︙ | ︙ | |||
1928 1929 1930 1931 1932 1933 1934 |
int
Tcl_GetOpenFile(
Tcl_Interp *interp, /* Interpreter in which to find file. */
const char *chanID, /* String that identifies file. */
int forWriting, /* 1 means the file is going to be used for
* writing, 0 means for reading. */
| | < | | | | 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 |
int
Tcl_GetOpenFile(
Tcl_Interp *interp, /* Interpreter in which to find file. */
const char *chanID, /* String that identifies file. */
int forWriting, /* 1 means the file is going to be used for
* writing, 0 means for reading. */
TCL_UNUSED(int), /* Obsolete argument.
* Ignored, we always check that
* the channel is open for the requested
* mode. */
void **filePtr) /* Store pointer to FILE structure here. */
{
Tcl_Channel chan;
int chanMode, fd;
const Tcl_ChannelType *chanTypePtr;
void *data;
FILE *f;
chan = Tcl_GetChannel(interp, chanID, &chanMode);
if (chan == NULL) {
return TCL_ERROR;
}
if (forWriting && !(chanMode & TCL_WRITABLE)) {
|
| ︙ | ︙ | |||
2023 2024 2025 2026 2027 2028 2029 | * places later in the file than the truncate point. * *---------------------------------------------------------------------- */ static int FileTruncateProc( | | | | 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 |
* places later in the file than the truncate point.
*
*----------------------------------------------------------------------
*/
static int
FileTruncateProc(
void *instanceData,
Tcl_WideInt length)
{
FileState *fsPtr = (FileState *)instanceData;
int result;
#ifdef HAVE_TYPE_OFF64_T
/*
* We assume this goes with the type for now...
*/
|
| ︙ | ︙ |
Changes to unix/tclUnixCompat.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | /* * tclUnixCompat.c * * Written by: Zoran Vasiljevic (vasiljevic@users.sourceforge.net). * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include <errno.h> #include <string.h> /* * See also: SC_BLOCKING_STYLE in unix/tcl.m4 */ | > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclUnixCompat.c * * Written by: Zoran Vasiljevic (vasiljevic@users.sourceforge.net). * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include <pwd.h> #include <grp.h> #include <errno.h> #include <string.h> /* * See also: SC_BLOCKING_STYLE in unix/tcl.m4 */ |
| ︙ | ︙ | |||
112 113 114 115 116 117 118 | static int CopyHostent(struct hostent *tgtPtr, char *buf, int buflen); static int CopyString(const char *src, char *buf, int buflen); #endif #ifdef NEED_PW_CLEANER | | | | 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 | static int CopyHostent(struct hostent *tgtPtr, char *buf, int buflen); static int CopyString(const char *src, char *buf, int buflen); #endif #ifdef NEED_PW_CLEANER static void FreePwBuf(ClientData dummy); #endif #ifdef NEED_GR_CLEANER static void FreeGrBuf(ClientData dummy); #endif #endif /* TCL_THREADS */ /* *--------------------------------------------------------------------------- * * TclUnixSetBlockingMode -- |
| ︙ | ︙ | |||
195 196 197 198 199 200 201 |
*/
if (tsdPtr->pbuf == NULL) {
tsdPtr->pbuflen = (int) sysconf(_SC_GETPW_R_SIZE_MAX);
if (tsdPtr->pbuflen < 1) {
tsdPtr->pbuflen = 1024;
}
| | | | 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 |
*/
if (tsdPtr->pbuf == NULL) {
tsdPtr->pbuflen = (int) sysconf(_SC_GETPW_R_SIZE_MAX);
if (tsdPtr->pbuflen < 1) {
tsdPtr->pbuflen = 1024;
}
tsdPtr->pbuf = (char *)ckalloc(tsdPtr->pbuflen);
Tcl_CreateThreadExitHandler(FreePwBuf, NULL);
}
while (1) {
int e = getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, tsdPtr->pbuflen,
&pwPtr);
if (e == 0) {
break;
} else if (e != ERANGE) {
return NULL;
}
tsdPtr->pbuflen *= 2;
tsdPtr->pbuf = (char *)ckrealloc(tsdPtr->pbuf, tsdPtr->pbuflen);
}
return (pwPtr != NULL ? &tsdPtr->pwd : NULL);
#elif defined(HAVE_GETPWNAM_R_4)
return getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf));
#else
|
| ︙ | ︙ | |||
275 276 277 278 279 280 281 |
*/
if (tsdPtr->pbuf == NULL) {
tsdPtr->pbuflen = (int) sysconf(_SC_GETPW_R_SIZE_MAX);
if (tsdPtr->pbuflen < 1) {
tsdPtr->pbuflen = 1024;
}
| | | | 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 |
*/
if (tsdPtr->pbuf == NULL) {
tsdPtr->pbuflen = (int) sysconf(_SC_GETPW_R_SIZE_MAX);
if (tsdPtr->pbuflen < 1) {
tsdPtr->pbuflen = 1024;
}
tsdPtr->pbuf = (char *)ckalloc(tsdPtr->pbuflen);
Tcl_CreateThreadExitHandler(FreePwBuf, NULL);
}
while (1) {
int e = getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, tsdPtr->pbuflen,
&pwPtr);
if (e == 0) {
break;
} else if (e != ERANGE) {
return NULL;
}
tsdPtr->pbuflen *= 2;
tsdPtr->pbuf = (char *)ckrealloc(tsdPtr->pbuf, tsdPtr->pbuflen);
}
return (pwPtr != NULL ? &tsdPtr->pwd : NULL);
#elif defined(HAVE_GETPWUID_R_4)
return getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf));
#else
|
| ︙ | ︙ | |||
330 331 332 333 334 335 336 | * *--------------------------------------------------------------------------- */ #ifdef NEED_PW_CLEANER static void FreePwBuf( | | | | 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 |
*
*---------------------------------------------------------------------------
*/
#ifdef NEED_PW_CLEANER
static void
FreePwBuf(
TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ckfree(tsdPtr->pbuf);
}
#endif /* NEED_PW_CLEANER */
/*
*---------------------------------------------------------------------------
*
* TclpGetGrNam --
|
| ︙ | ︙ | |||
378 379 380 381 382 383 384 |
*/
if (tsdPtr->gbuf == NULL) {
tsdPtr->gbuflen = (int) sysconf(_SC_GETGR_R_SIZE_MAX);
if (tsdPtr->gbuflen < 1) {
tsdPtr->gbuflen = 1024;
}
| | | | 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 |
*/
if (tsdPtr->gbuf == NULL) {
tsdPtr->gbuflen = (int) sysconf(_SC_GETGR_R_SIZE_MAX);
if (tsdPtr->gbuflen < 1) {
tsdPtr->gbuflen = 1024;
}
tsdPtr->gbuf = (char*)ckalloc(tsdPtr->gbuflen);
Tcl_CreateThreadExitHandler(FreeGrBuf, NULL);
}
while (1) {
int e = getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, tsdPtr->gbuflen,
&grPtr);
if (e == 0) {
break;
} else if (e != ERANGE) {
return NULL;
}
tsdPtr->gbuflen *= 2;
tsdPtr->gbuf = (char *)ckrealloc(tsdPtr->gbuf, tsdPtr->gbuflen);
}
return (grPtr != NULL ? &tsdPtr->grp : NULL);
#elif defined(HAVE_GETGRNAM_R_4)
return getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf));
#else
|
| ︙ | ︙ | |||
458 459 460 461 462 463 464 |
*/
if (tsdPtr->gbuf == NULL) {
tsdPtr->gbuflen = (int) sysconf(_SC_GETGR_R_SIZE_MAX);
if (tsdPtr->gbuflen < 1) {
tsdPtr->gbuflen = 1024;
}
| | | | 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 |
*/
if (tsdPtr->gbuf == NULL) {
tsdPtr->gbuflen = (int) sysconf(_SC_GETGR_R_SIZE_MAX);
if (tsdPtr->gbuflen < 1) {
tsdPtr->gbuflen = 1024;
}
tsdPtr->gbuf = (char*)ckalloc(tsdPtr->gbuflen);
Tcl_CreateThreadExitHandler(FreeGrBuf, NULL);
}
while (1) {
int e = getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, tsdPtr->gbuflen,
&grPtr);
if (e == 0) {
break;
} else if (e != ERANGE) {
return NULL;
}
tsdPtr->gbuflen *= 2;
tsdPtr->gbuf = (char *)ckrealloc(tsdPtr->gbuf, tsdPtr->gbuflen);
}
return (grPtr != NULL ? &tsdPtr->grp : NULL);
#elif defined(HAVE_GETGRGID_R_4)
return getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf));
#else
|
| ︙ | ︙ | |||
513 514 515 516 517 518 519 | * *--------------------------------------------------------------------------- */ #ifdef NEED_GR_CLEANER static void FreeGrBuf( | | | | 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 |
*
*---------------------------------------------------------------------------
*/
#ifdef NEED_GR_CLEANER
static void
FreeGrBuf(
TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ckfree(tsdPtr->gbuf);
}
#endif /* NEED_GR_CLEANER */
/*
*---------------------------------------------------------------------------
*
* TclpGetHostByName --
|
| ︙ | ︙ | |||
679 680 681 682 683 684 685 |
static int
CopyGrp(
struct group *tgtPtr,
char *buf,
int buflen)
{
| | | | 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 |
static int
CopyGrp(
struct group *tgtPtr,
char *buf,
int buflen)
{
char *p = buf;
int copied, len = 0;
/*
* Copy username.
*/
copied = CopyString(tgtPtr->gr_name, p, buflen - len);
if (copied == -1) {
|
| ︙ | ︙ | |||
881 882 883 884 885 886 887 |
int elsize, /* Size of each element, or -1 to indicate
* that they are C strings of dynamic
* length. */
char *buf, /* Buffer to copy into. */
int buflen) /* Size of buffer. */
{
int i, j, len = 0;
| | | | | | 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 |
int elsize, /* Size of each element, or -1 to indicate
* that they are C strings of dynamic
* length. */
char *buf, /* Buffer to copy into. */
int buflen) /* Size of buffer. */
{
int i, j, len = 0;
char *p, **newBuffer;
if (src == NULL) {
return 0;
}
for (i = 0; src[i] != NULL; i++) {
/*
* Empty loop to count how many.
*/
}
len = sizeof(char *) * (i + 1); /* Leave place for the array. */
if (len > buflen) {
return -1;
}
newBuffer = (char **) buf;
p = buf + len;
for (j = 0; j < i; j++) {
int sz = (elsize<0 ? (int) strlen(src[j]) + 1 : elsize);
len += sz;
if (len > buflen) {
return -1;
}
memcpy(p, src[j], sz);
newBuffer[j] = p;
p = buf + len;
}
newBuffer[j] = NULL;
return len;
}
#endif /* NEED_COPYARRAY */
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ |
Changes to unix/tclUnixFCmd.c.
| ︙ | ︙ | |||
37 38 39 40 41 42 43 44 45 46 47 48 49 50 | * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH * DAMAGE. */ #include "tclInt.h" #ifndef HAVE_STRUCT_STAT_ST_BLKSIZE #ifndef NO_FSTATFS #include <sys/statfs.h> #endif #endif /* !HAVE_STRUCT_STAT_ST_BLKSIZE */ #ifdef HAVE_FTS #include <fts.h> | > > | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH * DAMAGE. */ #include "tclInt.h" #include <utime.h> #include <grp.h> #ifndef HAVE_STRUCT_STAT_ST_BLKSIZE #ifndef NO_FSTATFS #include <sys/statfs.h> #endif #endif /* !HAVE_STRUCT_STAT_ST_BLKSIZE */ #ifdef HAVE_FTS #include <fts.h> |
| ︙ | ︙ | |||
107 108 109 110 111 112 113 | * Constants and variables necessary for file attributes subcommand. * * IMPORTANT: The permissions attribute is assumed to be the third item (i.e. * to be indexed with '2' in arrays) in code in tclIOUtil.c and possibly * elsewhere in Tcl's core. */ | | < < < < < < < < | < | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 |
* Constants and variables necessary for file attributes subcommand.
*
* IMPORTANT: The permissions attribute is assumed to be the third item (i.e.
* to be indexed with '2' in arrays) in code in tclIOUtil.c and possibly
* elsewhere in Tcl's core.
*/
#ifndef DJGPP
enum {
#if defined(__CYGWIN__)
UNIX_ARCHIVE_ATTRIBUTE,
#endif
UNIX_GROUP_ATTRIBUTE,
#if defined(__CYGWIN__)
UNIX_HIDDEN_ATTRIBUTE,
#endif
UNIX_OWNER_ATTRIBUTE, UNIX_PERMISSIONS_ATTRIBUTE,
#if defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE) || defined(__CYGWIN__)
UNIX_READONLY_ATTRIBUTE,
#endif
#if defined(__CYGWIN__)
UNIX_SYSTEM_ATTRIBUTE,
#endif
#ifdef MAC_OSX_TCL
MACOSX_CREATOR_ATTRIBUTE, MACOSX_TYPE_ATTRIBUTE, MACOSX_HIDDEN_ATTRIBUTE,
MACOSX_RSRCLENGTH_ATTRIBUTE,
#endif
UNIX_INVALID_ATTRIBUTE
};
const char *const tclpFileAttrStrings[] = {
#if defined(__CYGWIN__)
"-archive",
#endif
"-group",
#if defined(__CYGWIN__)
"-hidden",
|
| ︙ | ︙ | |||
161 162 163 164 165 166 167 |
#endif
#ifdef MAC_OSX_TCL
"-creator", "-type", "-hidden", "-rsrclength",
#endif
NULL
};
| < | 154 155 156 157 158 159 160 161 162 163 164 165 166 167 |
#endif
#ifdef MAC_OSX_TCL
"-creator", "-type", "-hidden", "-rsrclength",
#endif
NULL
};
const TclFileAttrProcs tclpFileAttrProcs[] = {
#if defined(__CYGWIN__)
{GetUnixFileAttributes, SetUnixFileAttributes},
#endif
{GetGroupAttribute, SetGroupAttribute},
#if defined(__CYGWIN__)
{GetUnixFileAttributes, SetUnixFileAttributes},
|
| ︙ | ︙ | |||
325 326 327 328 329 330 331 |
*/
int
TclpObjRenameFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
| | | | 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 |
*/
int
TclpObjRenameFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
return DoRenameFile((const char *)Tcl_FSGetNativePath(srcPathPtr),
(const char *)Tcl_FSGetNativePath(destPathPtr));
}
static int
DoRenameFile(
const char *src, /* Pathname of file or dir to be renamed
* (native). */
const char *dst) /* New pathname of file or directory
|
| ︙ | ︙ | |||
441 442 443 444 445 446 447 |
*/
int
TclpObjCopyFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
| | | | 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 |
*/
int
TclpObjCopyFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
const char *src = (const char *)Tcl_FSGetNativePath(srcPathPtr);
Tcl_StatBuf srcStatBuf;
if (TclOSlstat(src, &srcStatBuf) != 0) { /* INTL: Native. */
return TCL_ERROR;
}
return DoCopyFile(src, (const char *)Tcl_FSGetNativePath(destPathPtr), &srcStatBuf);
}
static int
DoCopyFile(
const char *src, /* Pathname of file to be copied (native). */
const char *dst, /* Pathname of file to copy to (native). */
const Tcl_StatBuf *statBufPtr)
|
| ︙ | ︙ | |||
548 549 550 551 552 553 554 |
const char *dst, /* Pathname of file to create/overwrite
* (native). */
const Tcl_StatBuf *statBufPtr,
/* Used to determine mode and blocksize. */
int dontCopyAtts) /* If flag set, don't copy attributes. */
{
int srcFd, dstFd;
| | | 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 |
const char *dst, /* Pathname of file to create/overwrite
* (native). */
const Tcl_StatBuf *statBufPtr,
/* Used to determine mode and blocksize. */
int dontCopyAtts) /* If flag set, don't copy attributes. */
{
int srcFd, dstFd;
unsigned blockSize; /* Optimal I/O blocksize for filesystem */
char *buffer; /* Data buffer for copy */
size_t nread;
#ifdef DJGPP
#define BINMODE |O_BINARY
#else
#define BINMODE
|
| ︙ | ︙ | |||
604 605 606 607 608 609 610 |
* detecting such a situation we now simply fall back to a hardwired
* default size.
*/
if (blockSize <= 0) {
blockSize = DEFAULT_COPY_BLOCK_SIZE;
}
| | | | | | | | 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 |
* detecting such a situation we now simply fall back to a hardwired
* default size.
*/
if (blockSize <= 0) {
blockSize = DEFAULT_COPY_BLOCK_SIZE;
}
buffer = (char *)ckalloc(blockSize);
while (1) {
nread = (size_t) read(srcFd, buffer, blockSize);
if ((nread == (size_t) -1) || (nread == 0)) {
break;
}
if ((size_t) write(dstFd, buffer, nread) != nread) {
nread = (size_t) -1;
break;
}
}
ckfree(buffer);
close(srcFd);
if ((close(dstFd) != 0) || (nread == (size_t) -1)) {
unlink(dst); /* INTL: Native. */
return TCL_ERROR;
}
if (!dontCopyAtts && CopyFileAtts(src, dst, statBufPtr) == TCL_ERROR) {
/*
* The copy succeeded, but setting the permissions failed, so be in a
* consistent state, we remove the file that was created by the copy.
|
| ︙ | ︙ | |||
703 704 705 706 707 708 709 |
*---------------------------------------------------------------------------
*/
int
TclpObjCreateDirectory(
Tcl_Obj *pathPtr)
{
| | | 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 |
*---------------------------------------------------------------------------
*/
int
TclpObjCreateDirectory(
Tcl_Obj *pathPtr)
{
return DoCreateDirectory((const char *)Tcl_FSGetNativePath(pathPtr));
}
static int
DoCreateDirectory(
const char *path) /* Pathname of directory to create (native). */
{
mode_t mode;
|
| ︙ | ︙ | |||
954 955 956 957 958 959 960 |
* traverseProc has returned TCL_OK; this is
* required when traverseProc modifies the
* source hierarchy, e.g. by deleting
* files. */
{
Tcl_StatBuf statBuf;
const char *source, *errfile;
| | | | | 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 |
* traverseProc has returned TCL_OK; this is
* required when traverseProc modifies the
* source hierarchy, e.g. by deleting
* files. */
{
Tcl_StatBuf statBuf;
const char *source, *errfile;
int result, sourceLen;
int targetLen;
#ifndef HAVE_FTS
int numProcessed = 0;
Tcl_DirEntry *dirEntPtr;
TclDIR *dirPtr;
#else
const char *paths[2] = {NULL, NULL};
FTS *fts = NULL;
FTSENT *ent;
#endif
errfile = NULL;
result = TCL_OK;
targetLen = 0;
source = Tcl_DStringValue(sourcePtr);
if (TclOSlstat(source, &statBuf) != 0) { /* INTL: Native. */
errfile = source;
goto end;
}
if (!S_ISDIR(statBuf.st_mode)) {
|
| ︙ | ︙ | |||
1234 1235 1236 1237 1238 1239 1240 |
*
*----------------------------------------------------------------------
*/
static int
TraversalDelete(
Tcl_DString *srcPtr, /* Source pathname (native). */
| | | < > | 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 |
*
*----------------------------------------------------------------------
*/
static int
TraversalDelete(
Tcl_DString *srcPtr, /* Source pathname (native). */
TCL_UNUSED(Tcl_DString *),
TCL_UNUSED(const Tcl_StatBuf *),
int type, /* Reason for call - see TraverseUnixTree(). */
Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free DString
* filled with UTF-8 name of file causing
* error. */
{
switch (type) {
case DOTREE_F:
if (TclpDeleteFile(Tcl_DStringValue(srcPtr)) == 0) {
return TCL_OK;
}
break;
case DOTREE_PRED:
|
| ︙ | ︙ | |||
1283 1284 1285 1286 1287 1288 1289 | * access time are updated in the new file to reflect the old file. * *--------------------------------------------------------------------------- */ static int CopyFileAtts( | > | > > > | 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 |
* access time are updated in the new file to reflect the old file.
*
*---------------------------------------------------------------------------
*/
static int
CopyFileAtts(
#ifdef MAC_OSX_TCL
const char *src, /* Path name of source file (native). */
#else
TCL_UNUSED(const char *) /*src*/,
#endif
const char *dst, /* Path name of target file (native). */
const Tcl_StatBuf *statBufPtr)
/* Stat info for source file */
{
struct utimbuf tval;
mode_t newMode;
|
| ︙ | ︙ | |||
1309 1310 1311 1312 1313 1314 1315 |
if (chmod(dst, newMode)) { /* INTL: Native. */
newMode &= ~(S_ISUID | S_ISGID);
if (chmod(dst, newMode)) { /* INTL: Native. */
return TCL_ERROR;
}
}
| | | | 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 |
if (chmod(dst, newMode)) { /* INTL: Native. */
newMode &= ~(S_ISUID | S_ISGID);
if (chmod(dst, newMode)) { /* INTL: Native. */
return TCL_ERROR;
}
}
tval.actime = Tcl_GetAccessTimeFromStat(statBufPtr);
tval.modtime = Tcl_GetModificationTimeFromStat(statBufPtr);
if (utime(dst, &tval)) { /* INTL: Native. */
return TCL_ERROR;
}
#ifdef MAC_OSX_TCL
TclMacOSXCopyFileAttributes(src, dst, statBufPtr);
#endif
|
| ︙ | ︙ | |||
1341 1342 1343 1344 1345 1346 1347 |
*
*----------------------------------------------------------------------
*/
static int
GetGroupAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
| | | 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 |
*
*----------------------------------------------------------------------
*/
static int
GetGroupAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
Tcl_StatBuf statBuf;
struct group *groupPtr;
int result;
|
| ︙ | ︙ | |||
1395 1396 1397 1398 1399 1400 1401 |
*
*----------------------------------------------------------------------
*/
static int
GetOwnerAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
| | | 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 |
*
*----------------------------------------------------------------------
*/
static int
GetOwnerAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
Tcl_StatBuf statBuf;
struct passwd *pwPtr;
int result;
|
| ︙ | ︙ | |||
1447 1448 1449 1450 1451 1452 1453 |
*
*----------------------------------------------------------------------
*/
static int
GetPermissionsAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
| | | 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 |
*
*----------------------------------------------------------------------
*/
static int
GetPermissionsAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
Tcl_StatBuf statBuf;
int result;
result = TclpObjStat(fileName, &statBuf);
|
| ︙ | ︙ | |||
1489 1490 1491 1492 1493 1494 1495 |
*
*---------------------------------------------------------------------------
*/
static int
SetGroupAttribute(
Tcl_Interp *interp, /* The interp for error reporting. */
| | < | | | | 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 |
*
*---------------------------------------------------------------------------
*/
static int
SetGroupAttribute(
Tcl_Interp *interp, /* The interp for error reporting. */
TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr) /* New group for file. */
{
Tcl_WideInt gid;
int result;
const char *native;
if (Tcl_GetWideIntFromObj(NULL, attributePtr, &gid) != TCL_OK) {
Tcl_DString ds;
struct group *groupPtr = NULL;
const char *string;
string = TclGetString(attributePtr);
native = Tcl_UtfToExternalDString(NULL, string, attributePtr->length, &ds);
groupPtr = TclpGetGrNam(native); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (groupPtr == NULL) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set group for file \"%s\":"
" group \"%s\" does not exist",
TclGetString(fileName), string));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SETGRP",
"NO_GROUP", NULL);
}
return TCL_ERROR;
}
gid = groupPtr->gr_gid;
}
native = (const char *)Tcl_FSGetNativePath(fileName);
result = chown(native, (uid_t) -1, (gid_t) gid); /* INTL: Native. */
if (result != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set group for file \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
|
| ︙ | ︙ | |||
1556 1557 1558 1559 1560 1561 1562 |
*
*---------------------------------------------------------------------------
*/
static int
SetOwnerAttribute(
Tcl_Interp *interp, /* The interp for error reporting. */
| | < | | | | 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 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 |
*
*---------------------------------------------------------------------------
*/
static int
SetOwnerAttribute(
Tcl_Interp *interp, /* The interp for error reporting. */
TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr) /* New owner for file. */
{
Tcl_WideInt uid;
int result;
const char *native;
if (Tcl_GetWideIntFromObj(NULL, attributePtr, &uid) != TCL_OK) {
Tcl_DString ds;
struct passwd *pwPtr = NULL;
const char *string;
string = TclGetString(attributePtr);
native = Tcl_UtfToExternalDString(NULL, string, attributePtr->length, &ds);
pwPtr = TclpGetPwNam(native); /* INTL: Native. */
Tcl_DStringFree(&ds);
if (pwPtr == NULL) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set owner for file \"%s\":"
" user \"%s\" does not exist",
TclGetString(fileName), string));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SETOWN",
"NO_USER", NULL);
}
return TCL_ERROR;
}
uid = pwPtr->pw_uid;
}
native = (const char *)Tcl_FSGetNativePath(fileName);
result = chown(native, (uid_t) uid, (gid_t) -1); /* INTL: Native. */
if (result != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set owner for file \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
|
| ︙ | ︙ | |||
1623 1624 1625 1626 1627 1628 1629 |
*
*---------------------------------------------------------------------------
*/
static int
SetPermissionsAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
| | | 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 |
*
*---------------------------------------------------------------------------
*/
static int
SetPermissionsAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr) /* The attribute to set. */
{
Tcl_WideInt mode;
mode_t newMode;
int result = TCL_ERROR;
const char *native;
|
| ︙ | ︙ | |||
1684 1685 1686 1687 1688 1689 1690 |
modeStringPtr));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PERMISSION", NULL);
}
return TCL_ERROR;
}
}
| | | 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 |
modeStringPtr));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "PERMISSION", NULL);
}
return TCL_ERROR;
}
}
native = (const char *)Tcl_FSGetNativePath(fileName);
result = chmod(native, newMode); /* INTL: Native. */
if (result != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set permissions for file \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
|
| ︙ | ︙ | |||
1745 1746 1747 1748 1749 1750 1751 | * See the user documentation. * *---------------------------------------------------------------------- */ static int GetModeFromPermString( | | | 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
GetModeFromPermString(
TCL_UNUSED(Tcl_Interp *),
const char *modeStringPtr, /* Permissions string */
mode_t *modePtr) /* pointer to the mode value */
{
mode_t newMode;
mode_t oldMode; /* Storage for the value of the old mode (that
* is passed in), to allow for the chmod style
* manipulation. */
|
| ︙ | ︙ | |||
1835 1836 1837 1838 1839 1840 1841 |
oldMode = *modePtr;
who = op = what = op_found = who_found = 0;
for (i = 0 ; *(modeStringPtr+n+i) != '\0' ; i++ ) {
if (!who_found) {
/* who */
switch (*(modeStringPtr+n+i)) {
case 'u':
| | | | | 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 |
oldMode = *modePtr;
who = op = what = op_found = who_found = 0;
for (i = 0 ; *(modeStringPtr+n+i) != '\0' ; i++ ) {
if (!who_found) {
/* who */
switch (*(modeStringPtr+n+i)) {
case 'u':
who |= 0x9C0;
continue;
case 'g':
who |= 0x438;
continue;
case 'o':
who |= 0x207;
continue;
case 'a':
who |= 0xFFF;
continue;
}
}
who_found = 1;
if (who == 0) {
who = 0xFFF;
}
if (!op_found) {
/* op */
switch (*(modeStringPtr+n+i)) {
case '+':
op = 1;
op_found = 1;
|
| ︙ | ︙ | |||
1883 1884 1885 1886 1887 1888 1889 | case 'w': what |= 0x92; continue; case 'x': what |= 0x49; continue; case 's': | | | 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 | case 'w': what |= 0x92; continue; case 'x': what |= 0x49; continue; case 's': what |= 0xC00; continue; case 't': what |= 0x200; continue; case ',': break; default: |
| ︙ | ︙ | |||
1918 1919 1920 1921 1922 1923 1924 | } /* *--------------------------------------------------------------------------- * * TclpObjNormalizePath -- * | | < | < < > | < | | > | > > > > > < | > < < < < < < > | | | < | | > > | > > > | 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 |
}
/*
*---------------------------------------------------------------------------
*
* TclpObjNormalizePath --
*
* Replaces each component except that last one in a pathname that is a
* symbolic link with the fully resolved target of that link.
*
* Results:
* Stores the resulting path in pathPtr and returns the offset of the last
* byte processed to obtain the resulting path.
*
* Side effects:
*
*---------------------------------------------------------------------------
*/
int
TclpObjNormalizePath(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *pathPtr, /* An unshared object containing the path to
* normalize. */
int nextCheckpoint) /* offset to start at in pathPtr. Must either
* be 0 or the offset of a directory separator
* at the end of a path part that is already
* normalized. I.e. this is not the index of
* the byte just after the separator. */
{
const char *currentPathEndPosition;
char cur;
const char *path = TclGetString(pathPtr);
size_t pathLen = pathPtr->length;
Tcl_DString ds;
const char *nativePath;
#ifndef NO_REALPATH
char normPath[MAXPATHLEN];
#endif
currentPathEndPosition = path + nextCheckpoint;
if (*currentPathEndPosition == '/') {
currentPathEndPosition++;
}
#ifndef NO_REALPATH
if (nextCheckpoint == 0 && haveRealpath) {
/*
* Try to get the entire path in one go
*/
const char *lastDir = strrchr(currentPathEndPosition, '/');
if (lastDir != NULL) {
nativePath = Tcl_UtfToExternalDString(NULL, path,
lastDir-path, &ds);
if (Realpath(nativePath, normPath) != NULL) {
if (*nativePath != '/' && *normPath == '/') {
/*
* realpath transformed a relative path into an
* absolute path. Fall back to the long way.
*/
/*
* To do: This logic seems to be out of date. This whole
* routine should be reviewed and cleaed up.
*/
} else {
nextCheckpoint = lastDir - path;
goto wholeStringOk;
}
}
Tcl_DStringFree(&ds);
|
| ︙ | ︙ | |||
2014 2015 2016 2017 2018 2019 2020 | * File doesn't exist. */ break; } /* | | | | < < < > | | | | | | < | | | > | < | | | > < | | | | > < < < < | 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 |
* File doesn't exist.
*/
break;
}
/*
* Assign the end of the current component to nextCheckpoint
*/
nextCheckpoint = currentPathEndPosition - path;
} else if (cur == 0) {
/*
* The end of the string.
*/
break;
}
currentPathEndPosition++;
}
/*
* Call 'realpath' to obtain a canonical path.
*/
#ifndef NO_REALPATH
if (haveRealpath) {
if (nextCheckpoint == 0) {
/*
* The path contains at most one component, e.g. '/foo' or '/', so
* so there is nothing to resolve. Also, on some platforms
* 'Realpath' transforms an empty string into the normalized pwd,
* which is the wrong answer.
*/
return 0;
}
nativePath = Tcl_UtfToExternalDString(NULL, path,nextCheckpoint, &ds);
if (Realpath(nativePath, normPath) != NULL) {
int newNormLen;
wholeStringOk:
newNormLen = strlen(normPath);
if ((newNormLen == Tcl_DStringLength(&ds))
&& (strcmp(normPath, nativePath) == 0)) {
/*
* The original path is unchanged.
*/
Tcl_DStringFree(&ds);
/*
* Uncommenting this would mean that this native filesystem
* routine claims the path is normalized if the file exists,
* which would permit the caller to avoid iterating through
* other filesystems filesystems. Saving lots of calls is
* probably worth the extra access() time, but in the common
* case that no other filesystems are registered this is an
* unnecessary expense.
*
if (0 == access(normPath, F_OK)) {
return pathLen;
}
*/
return nextCheckpoint;
}
/*
* Free the original path and replace it with the normalized path.
*/
Tcl_DStringFree(&ds);
Tcl_ExternalToUtfDString(NULL, normPath, (int) newNormLen, &ds);
if (path[nextCheckpoint] != '\0') {
/*
* Append the remaining path components.
*/
int normLen = Tcl_DStringLength(&ds);
Tcl_DStringAppend(&ds, path + nextCheckpoint,
pathLen - nextCheckpoint);
/*
* characters up to and including the directory separator have
* been processed
*/
nextCheckpoint = normLen + 1;
} else {
/*
* We recognise the whole string.
*/
nextCheckpoint = Tcl_DStringLength(&ds);
}
Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds),
Tcl_DStringLength(&ds));
}
Tcl_DStringFree(&ds);
}
#endif /* !NO_REALPATH */
|
| ︙ | ︙ | |||
2169 2170 2171 2172 2173 2174 2175 |
int
TclUnixOpenTemporaryFile(
Tcl_Obj *dirObj,
Tcl_Obj *basenameObj,
Tcl_Obj *extensionObj,
Tcl_Obj *resultingNameObj)
{
| | < | | | | | | | | | | | | | | | | | | | | | 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 |
int
TclUnixOpenTemporaryFile(
Tcl_Obj *dirObj,
Tcl_Obj *basenameObj,
Tcl_Obj *extensionObj,
Tcl_Obj *resultingNameObj)
{
Tcl_DString templ, tmp;
const char *string;
int fd;
/*
* We should also check against making more then TMP_MAX of these.
*/
if (dirObj) {
string = TclGetString(dirObj);
Tcl_UtfToExternalDString(NULL, string, dirObj->length, &templ);
} else {
Tcl_DStringInit(&templ);
Tcl_DStringAppend(&templ, DefaultTempDir(), -1); /* INTL: native */
}
TclDStringAppendLiteral(&templ, "/");
if (basenameObj) {
string = TclGetString(basenameObj);
Tcl_UtfToExternalDString(NULL, string, basenameObj->length, &tmp);
TclDStringAppendDString(&templ, &tmp);
Tcl_DStringFree(&tmp);
} else {
TclDStringAppendLiteral(&templ, "tcl");
}
TclDStringAppendLiteral(&templ, "_XXXXXX");
#ifdef HAVE_MKSTEMPS
if (extensionObj) {
string = TclGetString(extensionObj);
Tcl_UtfToExternalDString(NULL, string, extensionObj->length, &tmp);
TclDStringAppendDString(&templ, &tmp);
fd = mkstemps(Tcl_DStringValue(&templ), Tcl_DStringLength(&tmp));
Tcl_DStringFree(&tmp);
} else
#endif
{
fd = mkstemp(Tcl_DStringValue(&templ));
}
if (fd == -1) {
Tcl_DStringFree(&templ);
return -1;
}
if (resultingNameObj) {
Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&templ),
Tcl_DStringLength(&templ), &tmp);
Tcl_SetStringObj(resultingNameObj, Tcl_DStringValue(&tmp),
Tcl_DStringLength(&tmp));
Tcl_DStringFree(&tmp);
} else {
/*
* Try to delete the file immediately since we're not reporting the
* name to anyone. Note that we're *not* handling any errors from
* this!
*/
unlink(Tcl_DStringValue(&templ));
errno = 0;
}
Tcl_DStringFree(&templ);
return fd;
}
/*
* Helper that does *part* of what tempnam() does.
*/
|
| ︙ | ︙ | |||
2293 2294 2295 2296 2297 2298 2299 |
*/
Tcl_Obj *
TclpCreateTemporaryDirectory(
Tcl_Obj *dirObj,
Tcl_Obj *basenameObj)
{
| | | | | | | | | | | | | | | | | | | | | < > | > > | | | | | 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 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 |
*/
Tcl_Obj *
TclpCreateTemporaryDirectory(
Tcl_Obj *dirObj,
Tcl_Obj *basenameObj)
{
Tcl_DString templ, tmp;
const char *string;
#define DEFAULT_TEMP_DIR_PREFIX "tcl"
/*
* Build the template in writable memory from the user-supplied pieces and
* some defaults.
*/
if (dirObj) {
string = TclGetString(dirObj);
Tcl_UtfToExternalDString(NULL, string, dirObj->length, &templ);
} else {
Tcl_DStringInit(&templ);
Tcl_DStringAppend(&templ, DefaultTempDir(), -1); /* INTL: native */
}
if (Tcl_DStringValue(&templ)[Tcl_DStringLength(&templ) - 1] != '/') {
TclDStringAppendLiteral(&templ, "/");
}
if (basenameObj) {
string = TclGetString(basenameObj);
if (basenameObj->length) {
Tcl_UtfToExternalDString(NULL, string, basenameObj->length, &tmp);
TclDStringAppendDString(&templ, &tmp);
Tcl_DStringFree(&tmp);
} else {
TclDStringAppendLiteral(&templ, DEFAULT_TEMP_DIR_PREFIX);
}
} else {
TclDStringAppendLiteral(&templ, DEFAULT_TEMP_DIR_PREFIX);
}
TclDStringAppendLiteral(&templ, "_XXXXXX");
/*
* Make the temporary directory.
*/
if (mkdtemp(Tcl_DStringValue(&templ)) == NULL) {
Tcl_DStringFree(&templ);
return NULL;
}
/*
* The template has been updated. Tell the caller what it was.
*/
Tcl_ExternalToUtfDString(NULL, Tcl_DStringValue(&templ),
Tcl_DStringLength(&templ), &tmp);
Tcl_DStringFree(&templ);
return TclDStringToObj(&tmp);
}
#if defined(__CYGWIN__)
static void
StatError(
Tcl_Interp *interp, /* The interp that has the error */
Tcl_Obj *fileName) /* The name of the file which caused the
* error. */
{
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not read \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
static WCHAR *
winPathFromObj(
Tcl_Obj *fileName)
{
int size;
const char *native = (const char *)Tcl_FSGetNativePath(fileName);
WCHAR *winPath;
size = cygwin_conv_path(1, native, NULL, 0);
winPath = (WCHAR *)ckalloc(size);
cygwin_conv_path(1, native, winPath, size);
return winPath;
}
static const int attributeArray[] = {
0x20, 0, 2, 0, 0, 1, 4
};
/*
*----------------------------------------------------------------------
*
* GetUnixFileAttributes
*
* Gets an attribute of a file.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* If there is no error assigns to *attributePtrPtr the address of a new
* Tcl_Obj having a refCount of zero and containing the value of the
* specified attribute.
*
*
*----------------------------------------------------------------------
*/
static int
GetUnixFileAttributes(
Tcl_Interp *interp, /* The interp to report errors to. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The pathname of the file (UTF-8). */
Tcl_Obj **attributePtrPtr) /* Where to store the result. */
{
int fileAttributes;
WCHAR *winPath = winPathFromObj(fileName);
fileAttributes = GetFileAttributesW(winPath);
ckfree(winPath);
if (fileAttributes == -1) {
StatError(interp, fileName);
return TCL_ERROR;
}
*attributePtrPtr = Tcl_NewWideIntObj(
|
| ︙ | ︙ | |||
2456 2457 2458 2459 2460 2461 2462 |
}
winPath = winPathFromObj(fileName);
fileAttributes = old = GetFileAttributesW(winPath);
if (fileAttributes == -1) {
| | | | | 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 |
}
winPath = winPathFromObj(fileName);
fileAttributes = old = GetFileAttributesW(winPath);
if (fileAttributes == -1) {
ckfree(winPath);
StatError(interp, fileName);
return TCL_ERROR;
}
if (yesNo) {
fileAttributes |= attributeArray[objIndex];
} else {
fileAttributes &= ~attributeArray[objIndex];
}
if ((fileAttributes != old)
&& !SetFileAttributesW(winPath, fileAttributes)) {
ckfree(winPath);
StatError(interp, fileName);
return TCL_ERROR;
}
ckfree(winPath);
return TCL_OK;
}
#elif defined(HAVE_CHFLAGS) && defined(UF_IMMUTABLE)
/*
*----------------------------------------------------------------------
*
* GetUnixFileAttributes
|
| ︙ | ︙ | |||
2498 2499 2500 2501 2502 2503 2504 |
*
*----------------------------------------------------------------------
*/
static int
GetUnixFileAttributes(
Tcl_Interp *interp, /* The interp we are using for errors. */
| | | 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 |
*
*----------------------------------------------------------------------
*/
static int
GetUnixFileAttributes(
Tcl_Interp *interp, /* The interp we are using for errors. */
TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
Tcl_StatBuf statBuf;
int result;
result = TclpObjStat(fileName, &statBuf);
|
| ︙ | ︙ | |||
2539 2540 2541 2542 2543 2544 2545 |
*
*---------------------------------------------------------------------------
*/
static int
SetUnixFileAttributes(
Tcl_Interp *interp, /* The interp we are using for errors. */
| | | 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 |
*
*---------------------------------------------------------------------------
*/
static int
SetUnixFileAttributes(
Tcl_Interp *interp, /* The interp we are using for errors. */
TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file (UTF-8). */
Tcl_Obj *attributePtr) /* The attribute to set. */
{
Tcl_StatBuf statBuf;
int result, readonly;
const char *native;
|
| ︙ | ︙ | |||
2568 2569 2570 2571 2572 2573 2574 |
if (readonly) {
statBuf.st_flags |= UF_IMMUTABLE;
} else {
statBuf.st_flags &= ~UF_IMMUTABLE;
}
| | | 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 |
if (readonly) {
statBuf.st_flags |= UF_IMMUTABLE;
} else {
statBuf.st_flags &= ~UF_IMMUTABLE;
}
native = (const char *)Tcl_FSGetNativePath(fileName);
result = chflags(native, statBuf.st_flags); /* INTL: Native. */
if (result != 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not set flags for file \"%s\": %s",
TclGetString(fileName), Tcl_PosixError(interp)));
}
|
| ︙ | ︙ |
Changes to unix/tclUnixFile.c.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 37 38 | * * Side effects: * The computed path name is stored as a ProcessGlobalValue. * *--------------------------------------------------------------------------- */ void TclpFindExecutable( | > | < < | | | > > > > > > > > | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
*
* Side effects:
* The computed path name is stored as a ProcessGlobalValue.
*
*---------------------------------------------------------------------------
*/
#ifdef __CYGWIN__
void
TclpFindExecutable(
TCL_UNUSED(const char *) /*argv0*/)
{
Tcl_Encoding encoding;
int length;
wchar_t buf[PATH_MAX];
char name[PATH_MAX * 3 + 1];
GetModuleFileNameW(NULL, buf, PATH_MAX);
cygwin_conv_path(3, buf, name, PATH_MAX);
length = strlen(name);
if ((length > 4) && !strcasecmp(name + length - 4, ".exe")) {
/* Strip '.exe' part. */
length -= 4;
}
encoding = Tcl_GetEncoding(NULL, NULL);
TclSetObjNameOfExecutable(
Tcl_NewStringObj(name, length), encoding);
}
#else
void
TclpFindExecutable(
const char *argv0) /* The value of the application's argv[0]
* (native). */
{
Tcl_Encoding encoding;
const char *name, *p;
Tcl_StatBuf statBuf;
Tcl_DString buffer, nameString, cwd, utfName;
if (argv0 == NULL) {
return;
}
|
| ︙ | ︙ | |||
94 95 96 97 98 99 100 |
/*
* Search through all the directories named in the PATH variable to see if
* argv[0] is in one of them. If so, use that file name.
*/
while (1) {
| | | 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 |
/*
* Search through all the directories named in the PATH variable to see if
* argv[0] is in one of them. If so, use that file name.
*/
while (1) {
while (TclIsSpaceProcM(*p)) {
p++;
}
name = p;
while ((*p != ':') && (*p != 0)) {
p++;
}
TclDStringClear(&buffer);
|
| ︙ | ︙ | |||
188 189 190 191 192 193 194 |
&utfName);
TclSetObjNameOfExecutable(
Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding);
Tcl_DStringFree(&utfName);
done:
Tcl_DStringFree(&buffer);
| < > | 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 |
&utfName);
TclSetObjNameOfExecutable(
Tcl_NewStringObj(Tcl_DStringValue(&utfName), -1), encoding);
Tcl_DStringFree(&utfName);
done:
Tcl_DStringFree(&buffer);
}
#endif
/*
*----------------------------------------------------------------------
*
* TclpMatchInDirectory --
*
* This routine is used by the globbing code to search a directory for
|
| ︙ | ︙ | |||
245 246 247 248 249 250 251 | /* * Match a file directly. */ Tcl_Obj *tailPtr; const char *nativeTail; | | | | > | 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 |
/*
* Match a file directly.
*/
Tcl_Obj *tailPtr;
const char *nativeTail;
native = (const char *)Tcl_FSGetNativePath(pathPtr);
tailPtr = TclPathPart(interp, pathPtr, TCL_PATH_TAIL);
nativeTail = (const char *)Tcl_FSGetNativePath(tailPtr);
matchResult = NativeMatchType(interp, native, nativeTail, types);
if (matchResult == 1) {
Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
}
Tcl_DecrRefCount(tailPtr);
Tcl_DecrRefCount(fileNamePtr);
} else {
TclDIR *d;
Tcl_DirEntry *entryPtr;
const char *dirName;
size_t dirLength, nativeDirLen;
int matchHidden, matchHiddenPat;
Tcl_StatBuf statBuf;
Tcl_DString ds; /* native encoding of dir */
Tcl_DString dsOrig; /* utf-8 encoding of dir */
Tcl_DStringInit(&dsOrig);
dirName = TclGetString(fileNamePtr);
dirLength = fileNamePtr->length;
Tcl_DStringAppend(&dsOrig, dirName, dirLength);
/*
* Make sure that the directory part of the name really is a
* directory. If the directory name is "", use the name "." instead,
* because some UNIX systems don't treat "" like "." automatically.
* Keep the "" for use in generating file names, otherwise "glob
|
| ︙ | ︙ | |||
550 551 552 553 554 555 556 557 558 559 560 561 562 563 |
matchResult = TclMacOSXMatchType(interp, nativeEntry, nativeName,
&buf, types);
if (matchResult != 1) {
return matchResult;
}
}
#endif /* MAC_OSX_TCL */
return 1;
}
/*
*---------------------------------------------------------------------------
| > > | 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 |
matchResult = TclMacOSXMatchType(interp, nativeEntry, nativeName,
&buf, types);
if (matchResult != 1) {
return matchResult;
}
}
#else
(void)interp;
#endif /* MAC_OSX_TCL */
return 1;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
617 618 619 620 621 622 623 |
*/
int
TclpObjAccess(
Tcl_Obj *pathPtr, /* Path of file to access */
int mode) /* Permission setting. */
{
| | | 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 |
*/
int
TclpObjAccess(
Tcl_Obj *pathPtr, /* Path of file to access */
int mode) /* Permission setting. */
{
const char *path = (const char *)Tcl_FSGetNativePath(pathPtr);
if (path == NULL) {
return -1;
}
return access(path, mode);
}
|
| ︙ | ︙ | |||
645 646 647 648 649 650 651 |
*---------------------------------------------------------------------------
*/
int
TclpObjChdir(
Tcl_Obj *pathPtr) /* Path to new working directory */
{
| | | 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 |
*---------------------------------------------------------------------------
*/
int
TclpObjChdir(
Tcl_Obj *pathPtr) /* Path to new working directory */
{
const char *path = (const char *)Tcl_FSGetNativePath(pathPtr);
if (path == NULL) {
return -1;
}
return chdir(path);
}
|
| ︙ | ︙ | |||
674 675 676 677 678 679 680 |
*/
int
TclpObjLstat(
Tcl_Obj *pathPtr, /* Path of file to stat */
Tcl_StatBuf *bufPtr) /* Filled with results of stat call. */
{
| | | 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 |
*/
int
TclpObjLstat(
Tcl_Obj *pathPtr, /* Path of file to stat */
Tcl_StatBuf *bufPtr) /* Filled with results of stat call. */
{
return TclOSlstat((const char *)Tcl_FSGetNativePath(pathPtr), bufPtr);
}
/*
*---------------------------------------------------------------------------
*
* TclpGetNativeCwd --
*
|
| ︙ | ︙ | |||
715 716 717 718 719 720 721 |
#else
if (getcwd(buffer, MAXPATHLEN+1) == NULL) { /* INTL: Native. */
return NULL;
}
#endif /* USEGETWD */
if ((clientData == NULL) || strcmp(buffer, (const char *) clientData)) {
| | | 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 |
#else
if (getcwd(buffer, MAXPATHLEN+1) == NULL) { /* INTL: Native. */
return NULL;
}
#endif /* USEGETWD */
if ((clientData == NULL) || strcmp(buffer, (const char *) clientData)) {
char *newCd = (char*)ckalloc(strlen(buffer) + 1);
strcpy(newCd, buffer);
return newCd;
}
/*
* No change to pwd.
|
| ︙ | ︙ | |||
842 843 844 845 846 847 848 |
*/
int
TclpObjStat(
Tcl_Obj *pathPtr, /* Path of file to stat */
Tcl_StatBuf *bufPtr) /* Filled with results of stat call. */
{
| | | | 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 |
*/
int
TclpObjStat(
Tcl_Obj *pathPtr, /* Path of file to stat */
Tcl_StatBuf *bufPtr) /* Filled with results of stat call. */
{
const char *path = (const char *)Tcl_FSGetNativePath(pathPtr);
if (path == NULL) {
return -1;
}
return TclOSstat(path, bufPtr);
}
#ifdef S_IFLNK
Tcl_Obj *
TclpObjLink(
Tcl_Obj *pathPtr,
Tcl_Obj *toPtr,
int linkAction)
{
if (toPtr != NULL) {
const char *src = (const char *)Tcl_FSGetNativePath(pathPtr);
const char *target = NULL;
if (src == NULL) {
return NULL;
}
/*
|
| ︙ | ︙ | |||
905 906 907 908 909 910 911 |
/*
* Target exists; we'll construct the relative path we want below.
*/
Tcl_DecrRefCount(absPtr);
Tcl_DecrRefCount(dirPtr);
} else {
| | | 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 |
/*
* Target exists; we'll construct the relative path we want below.
*/
Tcl_DecrRefCount(absPtr);
Tcl_DecrRefCount(dirPtr);
} else {
target = (const char*)Tcl_FSGetNativePath(toPtr);
if (target == NULL) {
return NULL;
}
if (access(target, F_OK) == -1) {
/*
* Target doesn't exist.
*/
|
| ︙ | ︙ | |||
935 936 937 938 939 940 941 |
/*
* Check symbolic link flag first, since we prefer to create these.
*/
if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
Tcl_DString ds;
Tcl_Obj *transPtr;
| < | | | 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 |
/*
* Check symbolic link flag first, since we prefer to create these.
*/
if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
Tcl_DString ds;
Tcl_Obj *transPtr;
/*
* Now we don't want to link to the absolute, normalized path.
* Relative links are quite acceptable (but links to ~user are not
* -- these must be expanded first).
*/
transPtr = Tcl_FSGetTranslatedPath(NULL, toPtr);
if (transPtr == NULL) {
return NULL;
}
target = TclGetString(transPtr);
target = Tcl_UtfToExternalDString(NULL, target, transPtr->length, &ds);
Tcl_DecrRefCount(transPtr);
if (symlink(target, src) != 0) {
toPtr = NULL;
}
Tcl_DStringFree(&ds);
} else if (linkAction & TCL_CREATE_HARD_LINK) {
|
| ︙ | ︙ | |||
978 979 980 981 982 983 984 |
transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (transPtr == NULL) {
return NULL;
}
Tcl_DecrRefCount(transPtr);
| | | 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 |
transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
if (transPtr == NULL) {
return NULL;
}
Tcl_DecrRefCount(transPtr);
length = readlink((const char *)Tcl_FSGetNativePath(pathPtr), link, sizeof(link));
if (length < 0) {
return NULL;
}
Tcl_ExternalToUtfDString(NULL, link, length, &ds);
linkPtr = TclDStringToObj(&ds);
Tcl_IncrRefCount(linkPtr);
|
| ︙ | ︙ | |||
1012 1013 1014 1015 1016 1017 1018 | * None. * *--------------------------------------------------------------------------- */ Tcl_Obj * TclpFilesystemPathType( | | | 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 |
* None.
*
*---------------------------------------------------------------------------
*/
Tcl_Obj *
TclpFilesystemPathType(
TCL_UNUSED(Tcl_Obj *))
{
/*
* All native paths are of the same type.
*/
return NULL;
}
|
| ︙ | ︙ | |||
1101 1102 1103 1104 1105 1106 1107 |
validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
Tcl_IncrRefCount(validPathPtr);
}
| | > | | 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 |
validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (validPathPtr == NULL) {
return NULL;
}
Tcl_IncrRefCount(validPathPtr);
}
str = TclGetString(validPathPtr);
len = validPathPtr->length;
Tcl_UtfToExternalDString(NULL, str, len, &ds);
len = Tcl_DStringLength(&ds) + sizeof(char);
if (strlen(Tcl_DStringValue(&ds)) < len - sizeof(char)) {
/* See bug [3118489]: NUL in filenames */
Tcl_DecrRefCount(validPathPtr);
Tcl_DStringFree(&ds);
return NULL;
}
Tcl_DecrRefCount(validPathPtr);
nativePathPtr = (char *)ckalloc(len);
memcpy(nativePathPtr, Tcl_DStringValue(&ds), len);
Tcl_DStringFree(&ds);
return nativePathPtr;
}
/*
|
| ︙ | ︙ | |||
1152 1153 1154 1155 1156 1157 1158 |
/*
* ASCII representation when running on Unix.
*/
len = (strlen((const char*) clientData) + 1) * sizeof(char);
| | | 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 |
/*
* ASCII representation when running on Unix.
*/
len = (strlen((const char*) clientData) + 1) * sizeof(char);
copy = (char *)ckalloc(len);
memcpy(copy, clientData, len);
return copy;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1178 1179 1180 1181 1182 1183 1184 |
*/
int
TclpUtime(
Tcl_Obj *pathPtr, /* File to modify */
struct utimbuf *tval) /* New modification date structure */
{
| | | | 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 |
*/
int
TclpUtime(
Tcl_Obj *pathPtr, /* File to modify */
struct utimbuf *tval) /* New modification date structure */
{
return utime((const char *)Tcl_FSGetNativePath(pathPtr), tval);
}
#ifdef __CYGWIN__
int
TclOSstat(
const char *name,
void *cygstat)
{
struct stat buf;
Tcl_StatBuf *statBuf = (Tcl_StatBuf *)cygstat;
int result = stat(name, &buf);
statBuf->st_mode = buf.st_mode;
statBuf->st_ino = buf.st_ino;
statBuf->st_dev = buf.st_dev;
statBuf->st_rdev = buf.st_rdev;
statBuf->st_nlink = buf.st_nlink;
|
| ︙ | ︙ | |||
1212 1213 1214 1215 1216 1217 1218 |
int
TclOSlstat(
const char *name,
void *cygstat)
{
struct stat buf;
| | | 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 |
int
TclOSlstat(
const char *name,
void *cygstat)
{
struct stat buf;
Tcl_StatBuf *statBuf = (Tcl_StatBuf *)cygstat;
int result = lstat(name, &buf);
statBuf->st_mode = buf.st_mode;
statBuf->st_ino = buf.st_ino;
statBuf->st_dev = buf.st_dev;
statBuf->st_rdev = buf.st_rdev;
statBuf->st_nlink = buf.st_nlink;
|
| ︙ | ︙ |
Changes to unix/tclUnixInit.c.
1 2 3 4 5 6 7 8 9 10 11 | /* * tclUnixInit.c -- * * Contains the Unix-specific interpreter initialization functions. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. * All rights reserved. */ #include "tclInt.h" | < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | /* * tclUnixInit.c -- * * Contains the Unix-specific interpreter initialization functions. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. * All rights reserved. */ #include "tclInt.h" #ifdef HAVE_LANGINFO # include <langinfo.h> # ifdef __APPLE__ # if defined(HAVE_WEAK_IMPORT) && MAC_OS_X_VERSION_MIN_REQUIRED < 1030 /* Support for weakly importing nl_langinfo on Darwin. */ # define WEAK_IMPORT_NL_LANGINFO extern char *nl_langinfo(nl_item) WEAK_IMPORT_ATTRIBUTE; |
| ︙ | ︙ | |||
29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 |
# include <sys/param.h>
# if _BSDI_VERSION > 199501
# include <dlfcn.h>
# endif
#endif
#ifdef __CYGWIN__
DLLIMPORT extern __stdcall unsigned char GetVersionExW(void *);
DLLIMPORT extern __stdcall void *GetModuleHandleW(const void *);
DLLIMPORT extern __stdcall void FreeLibrary(void *);
DLLIMPORT extern __stdcall void *GetProcAddress(void *, const char *);
DLLIMPORT extern __stdcall void GetSystemInfo(void *);
#define NUMPROCESSORS 11
static const char *const processors[NUMPROCESSORS] = {
"intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
"amd64", "ia32_on_win64"
};
typedef struct {
union {
| > > > > > > > > > | | | | | | | | | | | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 |
# include <sys/param.h>
# if _BSDI_VERSION > 199501
# include <dlfcn.h>
# endif
#endif
#ifdef __CYGWIN__
#ifdef __cplusplus
extern "C" {
#endif
#ifdef __clang__
#pragma clang diagnostic ignored "-Wignored-attributes"
#endif
DLLIMPORT extern __stdcall unsigned char GetVersionExW(void *);
DLLIMPORT extern __stdcall void *GetModuleHandleW(const void *);
DLLIMPORT extern __stdcall void FreeLibrary(void *);
DLLIMPORT extern __stdcall void *GetProcAddress(void *, const char *);
DLLIMPORT extern __stdcall void GetSystemInfo(void *);
#ifdef __cplusplus
}
#endif
#define NUMPROCESSORS 11
static const char *const processors[NUMPROCESSORS] = {
"intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
"amd64", "ia32_on_win64"
};
typedef struct {
union {
unsigned int dwOemId;
struct {
int wProcessorArchitecture;
int wReserved;
};
};
unsigned int dwPageSize;
void *lpMinimumApplicationAddress;
void *lpMaximumApplicationAddress;
void *dwActiveProcessorMask;
unsigned int dwNumberOfProcessors;
unsigned int dwProcessorType;
unsigned int dwAllocationGranularity;
int wProcessorLevel;
int wProcessorRevision;
} SYSTEM_INFO;
typedef struct {
unsigned int dwOSVersionInfoSize;
unsigned int dwMajorVersion;
unsigned int dwMinorVersion;
unsigned int dwBuildNumber;
unsigned int dwPlatformId;
wchar_t szCSDVersion[128];
} OSVERSIONINFOW;
#endif
#ifdef HAVE_COREFOUNDATION
#include <CoreFoundation/CoreFoundation.h>
#endif
|
| ︙ | ︙ | |||
122 123 124 125 126 127 128 |
* default encoding directory. Indented by one TAB are the encoding names that
* are common alternative spellings. Indented by two TABs are the accumulated
* "bug fixes" that have been added to deal with the wide variability seen
* among existing platforms.
*/
static const LocaleTable localeTable[] = {
| | | | | 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 |
* default encoding directory. Indented by one TAB are the encoding names that
* are common alternative spellings. Indented by two TABs are the accumulated
* "bug fixes" that have been added to deal with the wide variability seen
* among existing platforms.
*/
static const LocaleTable localeTable[] = {
{"", "iso8859-1"},
{"ansi-1251", "cp1251"},
{"ansi_x3.4-1968", "iso8859-1"},
{"ascii", "ascii"},
{"big5", "big5"},
{"cp1250", "cp1250"},
{"cp1251", "cp1251"},
{"cp1252", "cp1252"},
{"cp1253", "cp1253"},
{"cp1254", "cp1254"},
|
| ︙ | ︙ | |||
161 162 163 164 165 166 167 |
{"cp949", "cp949"},
{"cp950", "cp950"},
{"dingbats", "dingbats"},
{"ebcdic", "ebcdic"},
{"euc-cn", "euc-cn"},
{"euc-jp", "euc-jp"},
{"euc-kr", "euc-kr"},
| | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 |
{"cp949", "cp949"},
{"cp950", "cp950"},
{"dingbats", "dingbats"},
{"ebcdic", "ebcdic"},
{"euc-cn", "euc-cn"},
{"euc-jp", "euc-jp"},
{"euc-kr", "euc-kr"},
{"eucjp", "euc-jp"},
{"euckr", "euc-kr"},
{"euctw", "euc-cn"},
{"gb12345", "gb12345"},
{"gb1988", "gb1988"},
{"gb2312", "gb2312"},
{"gb2312-1980", "gb2312"},
{"gb2312-raw", "gb2312-raw"},
{"greek8", "cp869"},
{"ibm1250", "cp1250"},
{"ibm1251", "cp1251"},
{"ibm1252", "cp1252"},
{"ibm1253", "cp1253"},
{"ibm1254", "cp1254"},
{"ibm1255", "cp1255"},
{"ibm1256", "cp1256"},
{"ibm1257", "cp1257"},
{"ibm1258", "cp1258"},
{"ibm437", "cp437"},
{"ibm737", "cp737"},
{"ibm775", "cp775"},
{"ibm850", "cp850"},
{"ibm852", "cp852"},
{"ibm855", "cp855"},
{"ibm857", "cp857"},
{"ibm860", "cp860"},
{"ibm861", "cp861"},
{"ibm862", "cp862"},
{"ibm863", "cp863"},
{"ibm864", "cp864"},
{"ibm865", "cp865"},
{"ibm866", "cp866"},
{"ibm869", "cp869"},
{"ibm874", "cp874"},
{"ibm932", "cp932"},
{"ibm936", "cp936"},
{"ibm949", "cp949"},
{"ibm950", "cp950"},
{"iso-2022", "iso2022"},
{"iso-2022-jp", "iso2022-jp"},
{"iso-2022-kr", "iso2022-kr"},
{"iso-8859-1", "iso8859-1"},
{"iso-8859-10", "iso8859-10"},
{"iso-8859-13", "iso8859-13"},
{"iso-8859-14", "iso8859-14"},
{"iso-8859-15", "iso8859-15"},
{"iso-8859-16", "iso8859-16"},
{"iso-8859-2", "iso8859-2"},
{"iso-8859-3", "iso8859-3"},
{"iso-8859-4", "iso8859-4"},
{"iso-8859-5", "iso8859-5"},
{"iso-8859-6", "iso8859-6"},
{"iso-8859-7", "iso8859-7"},
{"iso-8859-8", "iso8859-8"},
{"iso-8859-9", "iso8859-9"},
{"iso2022", "iso2022"},
{"iso2022-jp", "iso2022-jp"},
{"iso2022-kr", "iso2022-kr"},
{"iso8859-1", "iso8859-1"},
{"iso8859-10", "iso8859-10"},
{"iso8859-13", "iso8859-13"},
{"iso8859-14", "iso8859-14"},
{"iso8859-15", "iso8859-15"},
{"iso8859-16", "iso8859-16"},
{"iso8859-2", "iso8859-2"},
{"iso8859-3", "iso8859-3"},
{"iso8859-4", "iso8859-4"},
{"iso8859-5", "iso8859-5"},
{"iso8859-6", "iso8859-6"},
{"iso8859-7", "iso8859-7"},
{"iso8859-8", "iso8859-8"},
{"iso8859-9", "iso8859-9"},
{"iso88591", "iso8859-1"},
{"iso885915", "iso8859-15"},
{"iso88592", "iso8859-2"},
{"iso88595", "iso8859-5"},
{"iso88596", "iso8859-6"},
{"iso88597", "iso8859-7"},
{"iso88598", "iso8859-8"},
{"iso88599", "iso8859-9"},
#ifdef hpux
{"ja", "shiftjis"},
#else
{"ja", "euc-jp"},
#endif
{"ja_jp", "euc-jp"},
{"ja_jp.euc", "euc-jp"},
{"ja_jp.eucjp", "euc-jp"},
{"ja_jp.jis", "iso2022-jp"},
{"ja_jp.mscode", "shiftjis"},
{"ja_jp.sjis", "shiftjis"},
{"ja_jp.ujis", "euc-jp"},
{"japan", "euc-jp"},
#ifdef hpux
{"japanese", "shiftjis"},
#else
{"japanese", "euc-jp"},
#endif
{"japanese-sjis", "shiftjis"},
{"japanese-ujis", "euc-jp"},
{"japanese.euc", "euc-jp"},
{"japanese.sjis", "shiftjis"},
{"jis0201", "jis0201"},
{"jis0208", "jis0208"},
{"jis0212", "jis0212"},
{"jp_jp", "shiftjis"},
{"ko", "euc-kr"},
{"ko_kr", "euc-kr"},
{"ko_kr.euc", "euc-kr"},
{"ko_kw.euckw", "euc-kr"},
{"koi8-r", "koi8-r"},
{"koi8-u", "koi8-u"},
{"korean", "euc-kr"},
{"ksc5601", "ksc5601"},
{"maccenteuro", "macCentEuro"},
{"maccroatian", "macCroatian"},
{"maccyrillic", "macCyrillic"},
{"macdingbats", "macDingbats"},
{"macgreek", "macGreek"},
{"maciceland", "macIceland"},
{"macjapan", "macJapan"},
{"macroman", "macRoman"},
{"macromania", "macRomania"},
{"macthai", "macThai"},
{"macturkish", "macTurkish"},
{"macukraine", "macUkraine"},
{"roman8", "iso8859-1"},
{"ru", "iso8859-5"},
{"ru_ru", "iso8859-5"},
{"ru_su", "iso8859-5"},
{"shiftjis", "shiftjis"},
{"sjis", "shiftjis"},
{"symbol", "symbol"},
{"tis-620", "tis-620"},
{"tis620", "tis-620"},
{"turkish8", "cp857"},
{"utf8", "utf-8"},
{"zh", "cp936"},
{"zh_cn.gb2312", "euc-cn"},
{"zh_cn.gbk", "euc-cn"},
{"zh_cz.gb2312", "euc-cn"},
{"zh_tw", "euc-tw"},
{"zh_tw.big5", "big5"},
};
#ifdef HAVE_COREFOUNDATION
static int MacOSXGetLibraryPath(Tcl_Interp *interp,
int maxPathLen, char *tclLibPath);
#endif /* HAVE_COREFOUNDATION */
#if defined(__APPLE__) && (defined(TCL_LOAD_FROM_MEMORY) || ( \
|
| ︙ | ︙ | |||
331 332 333 334 335 336 337 | /* *--------------------------------------------------------------------------- * * TclpInitPlatform -- * | | | 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 | /* *--------------------------------------------------------------------------- * * TclpInitPlatform -- * * Initialize all the platform-dependent things like signals and * floating-point error handling. * * Called at process initialization time. * * Results: * None. * |
| ︙ | ︙ | |||
407 408 409 410 411 412 413 |
*/
setlocale(LC_CTYPE, "");
/*
* In case the initial locale is not "C", ensure that the numeric
* processing is done in "C" locale regardless. This is needed because Tcl
| | | 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 |
*/
setlocale(LC_CTYPE, "");
/*
* In case the initial locale is not "C", ensure that the numeric
* processing is done in "C" locale regardless. This is needed because Tcl
* relies on routines like strtol/strtoul, but should not have locale dependent
* behavior.
*/
setlocale(LC_NUMERIC, "C");
#ifdef GET_DARWIN_RELEASE
{
|
| ︙ | ︙ | |||
444 445 446 447 448 449 450 |
*
*-------------------------------------------------------------------------
*/
void
TclpInitLibraryPath(
char **valuePtr,
| | | 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 |
*
*-------------------------------------------------------------------------
*/
void
TclpInitLibraryPath(
char **valuePtr,
unsigned int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
#define LIBRARY_SIZE 32
Tcl_Obj *pathPtr, *objPtr;
const char *str;
Tcl_DString buffer;
|
| ︙ | ︙ | |||
501 502 503 504 505 506 507 | * string. */ pathv[pathc - 1] = installLib + 4; str = Tcl_JoinPath(pathc, pathv, &ds); Tcl_ListObjAppendElement(NULL, pathPtr, TclDStringToObj(&ds)); } | | | 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 |
* string.
*/
pathv[pathc - 1] = installLib + 4;
str = Tcl_JoinPath(pathc, pathv, &ds);
Tcl_ListObjAppendElement(NULL, pathPtr, TclDStringToObj(&ds));
}
ckfree(pathv);
}
/*
* Finally, look for the library relative to the compiled-in path. This is
* needed when users install Tcl with an exec-prefix that is different
* from the prefix.
*/
|
| ︙ | ︙ | |||
533 534 535 536 537 538 539 |
objPtr = Tcl_NewStringObj(str, -1);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
}
}
Tcl_DStringFree(&buffer);
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
| | > | | 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 |
objPtr = Tcl_NewStringObj(str, -1);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
}
}
Tcl_DStringFree(&buffer);
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
str = TclGetString(pathPtr);
*lengthPtr = pathPtr->length;
*valuePtr = (char *)ckalloc(*lengthPtr + 1);
memcpy(*valuePtr, str, *lengthPtr + 1);
Tcl_DecrRefCount(pathPtr);
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
874 875 876 877 878 879 880 |
GetVersionExW(&osInfo);
}
osInfoInitialized = 1;
}
GetSystemInfo(&sysInfo);
| | > | 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 |
GetVersionExW(&osInfo);
}
osInfoInitialized = 1;
}
GetSystemInfo(&sysInfo);
Tcl_SetVar2(interp, "tcl_platform", "os",
"Windows NT", TCL_GLOBAL_ONLY);
sprintf(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY);
if (sysInfo.wProcessorArchitecture < NUMPROCESSORS) {
Tcl_SetVar2(interp, "tcl_platform", "machine",
processors[sysInfo.wProcessorArchitecture],
TCL_GLOBAL_ONLY);
}
|
| ︙ | ︙ | |||
976 977 978 979 980 981 982 | * TclpFindVariable -- * * Locate the entry in environ for a given name. On Unix this routine is * case sensetive, on Windows this matches mixed case. * * Results: * The return value is the index in environ of an entry with the name | | | | | | | 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 |
* TclpFindVariable --
*
* Locate the entry in environ for a given name. On Unix this routine is
* case sensetive, on Windows this matches mixed case.
*
* Results:
* The return value is the index in environ of an entry with the name
* "name", or -1 if there is no such entry. The integer at *lengthPtr is
* filled in with the length of name (if a matching entry is found) or
* the length of the environ array (if no matching entry is found).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclpFindVariable(
const char *name, /* Name of desired environment variable
* (native). */
int *lengthPtr) /* Used to return length of name (for
* successful searches) or number of non-NULL
* entries in environ (for unsuccessful
* searches). */
{
int i, result = -1;
const char *env, *p1, *p2;
Tcl_DString envString;
Tcl_DStringInit(&envString);
for (i = 0, env = environ[i]; env != NULL; i++, env = environ[i]) {
p1 = Tcl_ExternalToUtfDString(NULL, env, -1, &envString);
p2 = name;
|
| ︙ | ︙ | |||
1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 |
* Side effects:
* Same as for Tcl_MacOSXOpenVersionedBundleResources.
*
*----------------------------------------------------------------------
*/
#ifdef HAVE_COREFOUNDATION
static int
MacOSXGetLibraryPath(
Tcl_Interp *interp,
int maxPathLen,
char *tclLibPath)
{
| > < < < | > | > > > > > | | > | 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 |
* Side effects:
* Same as for Tcl_MacOSXOpenVersionedBundleResources.
*
*----------------------------------------------------------------------
*/
#ifdef HAVE_COREFOUNDATION
#ifdef TCL_FRAMEWORK
static int
MacOSXGetLibraryPath(
Tcl_Interp *interp,
int maxPathLen,
char *tclLibPath)
{
return Tcl_MacOSXOpenVersionedBundleResources(interp,
"com.tcltk.tcllibrary", TCL_FRAMEWORK_VERSION, 0, maxPathLen,
tclLibPath);
}
#else
static int
MacOSXGetLibraryPath(
TCL_UNUSED(Tcl_Interp *),
TCL_UNUSED(int),
TCL_UNUSED(char *))
{
return TCL_ERROR;
}
#endif
#endif /* HAVE_COREFOUNDATION */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to unix/tclUnixNotfy.c.
| ︙ | ︙ | |||
104 105 106 107 108 109 110 |
{
if (tclNotifierHooks.alertNotifierProc) {
tclNotifierHooks.alertNotifierProc(clientData);
return;
} else {
#ifdef NOTIFIER_SELECT
#if TCL_THREADS
| | | | 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 |
{
if (tclNotifierHooks.alertNotifierProc) {
tclNotifierHooks.alertNotifierProc(clientData);
return;
} else {
#ifdef NOTIFIER_SELECT
#if TCL_THREADS
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)clientData;
pthread_mutex_lock(¬ifierMutex);
tsdPtr->eventReady = 1;
# ifdef __CYGWIN__
PostMessageW(tsdPtr->hwnd, 1024, 0, 0);
# else
pthread_cond_broadcast(&tsdPtr->waitCV);
# endif /* __CYGWIN__ */
pthread_mutex_unlock(¬ifierMutex);
#endif /* TCL_THREADS */
#else /* !NOTIFIER_SELECT */
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)clientData;
#if defined(NOTIFIER_EPOLL) && defined(HAVE_EVENTFD)
uint64_t eventFdVal = 1;
if (write(tsdPtr->triggerEventFd, &eventFdVal,
sizeof(eventFdVal)) != sizeof(eventFdVal)) {
Tcl_Panic("Tcl_AlertNotifier: unable to write to %p->triggerEventFd",
(void *)tsdPtr);
}
|
| ︙ | ︙ |
Changes to unix/tclUnixPipe.c.
| ︙ | ︙ | |||
44 45 46 47 48 49 50 | * the children at close time. */ } PipeState; /* * Declarations for local functions defined in this file: */ | | | | | | | | | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | * the children at close time. */ } PipeState; /* * Declarations for local functions defined in this file: */ static int PipeBlockModeProc(void *instanceData, int mode); static int PipeClose2Proc(void *instanceData, Tcl_Interp *interp, int flags); static int PipeGetHandleProc(void *instanceData, int direction, void **handlePtr); static int PipeInputProc(void *instanceData, char *buf, int toRead, int *errorCode); static int PipeOutputProc(void *instanceData, const char *buf, int toWrite, int *errorCode); static void PipeWatchProc(void *instanceData, int mask); static void RestoreSignals(void); static int SetupStdFile(TclFile file, int type); /* * This structure describes the channel type structure for command pipe based * I/O: */ |
| ︙ | ︙ | |||
103 104 105 106 107 108 109 |
*/
TclFile
TclpMakeFile(
Tcl_Channel channel, /* Channel to get file from. */
int direction) /* Either TCL_READABLE or TCL_WRITABLE. */
{
| | | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 |
*/
TclFile
TclpMakeFile(
Tcl_Channel channel, /* Channel to get file from. */
int direction) /* Either TCL_READABLE or TCL_WRITABLE. */
{
void *data;
if (Tcl_GetChannelHandle(channel, direction, &data) != TCL_OK) {
return NULL;
}
return MakeFile(PTR2INT(data));
}
|
| ︙ | ︙ | |||
264 265 266 267 268 269 270 |
*
*----------------------------------------------------------------------------
*/
Tcl_Obj *
TclpTempFileNameForLibrary(
Tcl_Interp *interp, /* Tcl interpreter. */
| | | 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 |
*
*----------------------------------------------------------------------------
*/
Tcl_Obj *
TclpTempFileNameForLibrary(
Tcl_Interp *interp, /* Tcl interpreter. */
TCL_UNUSED(Tcl_Obj *) /*path*/)
{
Tcl_Obj *retval = TclpTempFileName();
if (retval == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't create temporary file: %s",
Tcl_PosixError(interp)));
|
| ︙ | ︙ | |||
370 371 372 373 374 375 376 | * * Side effects: * A process is created. * *--------------------------------------------------------------------------- */ | < | 370 371 372 373 374 375 376 377 378 379 380 381 382 383 |
*
* Side effects:
* A process is created.
*
*---------------------------------------------------------------------------
*/
int
TclpCreateProcess(
Tcl_Interp *interp, /* Interpreter in which to leave errors that
* occurred when creating the child process.
* Error messages from the child process
* itself are sent to errorFile. */
int argc, /* Number of arguments in following array. */
|
| ︙ | ︙ | |||
428 429 430 431 432 433 434 |
}
/*
* We need to allocate and convert this before the fork so it is properly
* deallocated later
*/
| | | | 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 |
}
/*
* We need to allocate and convert this before the fork so it is properly
* deallocated later
*/
dsArray = (Tcl_DString *)TclStackAlloc(interp, argc * sizeof(Tcl_DString));
newArgv = (char **)TclStackAlloc(interp, (argc+1) * sizeof(char *));
newArgv[argc] = NULL;
for (i = 0; i < argc; i++) {
newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]);
}
#ifdef USE_VFORK
/*
|
| ︙ | ︙ | |||
520 521 522 523 524 525 526 |
* an error message.
*/
TclpCloseFile(errPipeOut);
errPipeOut = NULL;
fd = GetFd(errPipeIn);
| | | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 |
* an error message.
*/
TclpCloseFile(errPipeOut);
errPipeOut = NULL;
fd = GetFd(errPipeIn);
count = read(fd, errSpace, (size_t) (sizeof(errSpace) - 1));
if (count > 0) {
char *end;
errSpace[count] = 0;
errno = strtol(errSpace, &end, 10);
Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s: %s",
end, Tcl_PosixError(interp)));
|
| ︙ | ︙ | |||
740 741 742 743 744 745 746 |
Tcl_Pid *pidPtr) /* An array of process identifiers. Allocated
* by the caller, freed when the channel is
* closed or the processes are detached (in a
* background exec). */
{
char channelName[16 + TCL_INTEGER_SPACE];
int channelId;
| | | 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 |
Tcl_Pid *pidPtr) /* An array of process identifiers. Allocated
* by the caller, freed when the channel is
* closed or the processes are detached (in a
* background exec). */
{
char channelName[16 + TCL_INTEGER_SPACE];
int channelId;
PipeState *statePtr = (PipeState *)ckalloc(sizeof(PipeState));
int mode;
statePtr->inFile = readFile;
statePtr->outFile = writeFile;
statePtr->errorFile = errorFile;
statePtr->numPids = numPids;
statePtr->pidPtr = pidPtr;
|
| ︙ | ︙ | |||
806 807 808 809 810 811 812 |
*/
int
Tcl_CreatePipe(
Tcl_Interp *interp, /* Errors returned in result. */
Tcl_Channel *rchan, /* Returned read side. */
Tcl_Channel *wchan, /* Returned write side. */
| | | 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 |
*/
int
Tcl_CreatePipe(
Tcl_Interp *interp, /* Errors returned in result. */
Tcl_Channel *rchan, /* Returned read side. */
Tcl_Channel *wchan, /* Returned write side. */
TCL_UNUSED(int) /*flags*/) /* Reserved for future use. */
{
int fileNums[2];
if (pipe(fileNums) < 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("pipe creation failed: %s",
Tcl_PosixError(interp)));
return TCL_ERROR;
|
| ︙ | ︙ | |||
865 866 867 868 869 870 871 |
*/
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
return;
}
| | | | 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 |
*/
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
return;
}
pipePtr = (PipeState *)Tcl_GetChannelInstanceData(chan);
TclNewObj(pidsObj);
for (i = 0; i < pipePtr->numPids; i++) {
Tcl_ListObjAppendElement(NULL, pidsObj, Tcl_NewWideIntObj(
PTR2INT(pipePtr->pidPtr[i])));
Tcl_DetachPids(1, &pipePtr->pidPtr[i]);
}
Tcl_SetObjResult(interp, pidsObj);
if (pipePtr->numPids > 0) {
ckfree(pipePtr->pidPtr);
pipePtr->numPids = 0;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
896 897 898 899 900 901 902 | * * Side effects: * Sets the device into blocking or non-blocking mode. * *---------------------------------------------------------------------- */ | < | | | 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 |
*
* Side effects:
* Sets the device into blocking or non-blocking mode.
*
*----------------------------------------------------------------------
*/
static int
PipeBlockModeProc(
void *instanceData, /* Pipe state. */
int mode) /* The mode to set. Can be one of
* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
PipeState *psPtr = (PipeState *)instanceData;
if (psPtr->inFile
&& TclUnixSetBlockingMode(GetFd(psPtr->inFile), mode) < 0) {
return errno;
}
if (psPtr->outFile
&& TclUnixSetBlockingMode(GetFd(psPtr->outFile), mode) < 0) {
|
| ︙ | ︙ | |||
939 940 941 942 943 944 945 | * Closes the command pipeline channel. * *---------------------------------------------------------------------- */ static int PipeClose2Proc( | | | | 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 |
* Closes the command pipeline channel.
*
*----------------------------------------------------------------------
*/
static int
PipeClose2Proc(
void *instanceData, /* The pipe to close. */
Tcl_Interp *interp, /* For error reporting. */
int flags) /* Flags that indicate which side to close. */
{
PipeState *pipePtr = (PipeState *)instanceData;
Tcl_Channel errChan;
int errorCode, result;
errorCode = 0;
result = 0;
if (((!flags) || (flags & TCL_CLOSE_READ)) && (pipePtr->inFile != NULL)) {
|
| ︙ | ︙ | |||
1005 1006 1007 1008 1009 1010 1011 |
errChan = NULL;
}
result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr,
errChan);
}
if (pipePtr->numPids != 0) {
| | | | 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 |
errChan = NULL;
}
result = TclCleanupChildren(interp, pipePtr->numPids, pipePtr->pidPtr,
errChan);
}
if (pipePtr->numPids != 0) {
ckfree(pipePtr->pidPtr);
}
ckfree(pipePtr);
if (errorCode == 0) {
return result;
}
return errorCode;
}
/*
|
| ︙ | ︙ | |||
1034 1035 1036 1037 1038 1039 1040 | * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ static int PipeInputProc( | | | | | 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 |
* Reads input from the input device of the channel.
*
*----------------------------------------------------------------------
*/
static int
PipeInputProc(
void *instanceData, /* Pipe state. */
char *buf, /* Where to store data read. */
int toRead, /* How much space is available in the
* buffer? */
int *errorCodePtr) /* Where to store error code. */
{
PipeState *psPtr = (PipeState *)instanceData;
int bytesRead; /* How many bytes were actually read from the
* input device? */
*errorCodePtr = 0;
/*
* Assume there is always enough input available. This will block
* 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. Some OSes can throw an
* interrupt error, for which we should immediately retry. [Bug #415131]
*/
do {
bytesRead = read(GetFd(psPtr->inFile), buf, (size_t) toRead);
} while ((bytesRead < 0) && (errno == EINTR));
if (bytesRead < 0) {
*errorCodePtr = errno;
return -1;
}
return bytesRead;
|
| ︙ | ︙ | |||
1085 1086 1087 1088 1089 1090 1091 | * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ static int PipeOutputProc( | | | | | 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 |
* Writes output on the output device of the channel.
*
*----------------------------------------------------------------------
*/
static int
PipeOutputProc(
void *instanceData, /* Pipe state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
{
PipeState *psPtr = (PipeState *)instanceData;
int written;
*errorCodePtr = 0;
/*
* Some OSes can throw an interrupt error, for which we should immediately
* retry. [Bug #415131]
*/
do {
written = write(GetFd(psPtr->outFile), buf, (size_t) toWrite);
} while ((written < 0) && (errno == EINTR));
if (written < 0) {
*errorCodePtr = errno;
return -1;
}
return written;
|
| ︙ | ︙ | |||
1130 1131 1132 1133 1134 1135 1136 | * seen by Tcl. * *---------------------------------------------------------------------- */ static void PipeWatchProc( | | | | 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 |
* seen by Tcl.
*
*----------------------------------------------------------------------
*/
static void
PipeWatchProc(
void *instanceData, /* The pipe state. */
int mask) /* Events of interest; an OR-ed combination of
* TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
PipeState *psPtr = (PipeState *)instanceData;
int newmask;
if (psPtr->inFile) {
newmask = mask & (TCL_READABLE | TCL_EXCEPTION);
if (newmask) {
Tcl_CreateFileHandler(GetFd(psPtr->inFile), newmask,
(Tcl_FileProc *) Tcl_NotifyChannel, psPtr->channel);
|
| ︙ | ︙ | |||
1178 1179 1180 1181 1182 1183 1184 | * None. * *---------------------------------------------------------------------- */ static int PipeGetHandleProc( | | | | | 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 |
* None.
*
*----------------------------------------------------------------------
*/
static int
PipeGetHandleProc(
void *instanceData, /* The pipe state. */
int direction, /* TCL_READABLE or TCL_WRITABLE */
void **handlePtr) /* Where to store the handle. */
{
PipeState *psPtr = (PipeState *)instanceData;
if (direction == TCL_READABLE && psPtr->inFile) {
*handlePtr = INT2PTR(GetFd(psPtr->inFile));
return TCL_OK;
}
if (direction == TCL_WRITABLE && psPtr->outFile) {
*handlePtr = INT2PTR(GetFd(psPtr->outFile));
|
| ︙ | ︙ | |||
1245 1246 1247 1248 1249 1250 1251 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_PidObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
Tcl_Channel chan;
PipeState *pipePtr;
int i;
|
| ︙ | ︙ | |||
1270 1271 1272 1273 1274 1275 1276 |
if (objc == 1) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(getpid()));
} else {
/*
* Get the channel and make sure that it refers to a pipe.
*/
| | | | 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 |
if (objc == 1) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(getpid()));
} else {
/*
* Get the channel and make sure that it refers to a pipe.
*/
chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
if (chan == NULL) {
return TCL_ERROR;
}
if (Tcl_GetChannelType(chan) != &pipeChannelType) {
return TCL_OK;
}
/*
* Extract the process IDs from the pipe structure.
*/
pipePtr = (PipeState *)Tcl_GetChannelInstanceData(chan);
resultPtr = Tcl_NewObj();
for (i = 0; i < pipePtr->numPids; i++) {
Tcl_ListObjAppendElement(NULL, resultPtr,
Tcl_NewWideIntObj(PTR2INT(TclpGetPid(pipePtr->pidPtr[i]))));
}
Tcl_SetObjResult(interp, resultPtr);
}
|
| ︙ | ︙ |
Changes to unix/tclUnixPort.h.
| ︙ | ︙ | |||
82 83 84 85 86 87 88 | #else typedef off_t Tcl_SeekOffset; # define TclOSseek lseek # define TclOSopen open #endif #ifdef __CYGWIN__ | | > > > > > > | | | | < < | < < > > > > | | | | | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 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 |
#else
typedef off_t Tcl_SeekOffset;
# define TclOSseek lseek
# define TclOSopen open
#endif
#ifdef __CYGWIN__
#ifdef __cplusplus
extern "C" {
#endif
/* Make some symbols available without including <windows.h> */
# define DWORD unsigned int
# define CP_UTF8 65001
# define GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS 0x00000004
# define HANDLE void *
# define HINSTANCE void *
# define SOCKET unsigned int
# define WSAEWOULDBLOCK 10035
typedef unsigned short WCHAR;
#ifdef __clang__
#pragma clang diagnostic push
#pragma clang diagnostic ignored "-Wignored-attributes"
#endif
__declspec(dllimport) extern __stdcall int GetModuleHandleExW(unsigned int, const void *, void *);
__declspec(dllimport) extern __stdcall int GetModuleFileNameW(void *, const void *, int);
__declspec(dllimport) extern __stdcall int WideCharToMultiByte(int, int, const void *, int,
char *, int, const char *, void *);
__declspec(dllimport) extern __stdcall int MultiByteToWideChar(int, int, const char *, int,
WCHAR *, int);
__declspec(dllimport) extern __stdcall void OutputDebugStringW(const WCHAR *);
__declspec(dllimport) extern __stdcall int IsDebuggerPresent(void);
__declspec(dllimport) extern __stdcall int GetLastError(void);
__declspec(dllimport) extern __stdcall int GetFileAttributesW(const WCHAR *);
__declspec(dllimport) extern __stdcall int SetFileAttributesW(const WCHAR *, int);
__declspec(dllimport) extern int cygwin_conv_path(int, const void *, void *, int);
#ifdef __clang__
#pragma clang diagnostic pop
#endif
# define timezone _timezone
extern int TclOSstat(const char *name, void *statBuf);
extern int TclOSlstat(const char *name, void *statBuf);
#ifdef __cplusplus
}
#endif
#elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__)
# define TclOSstat(name, buf) stat64(name, (struct stat64 *)buf)
# define TclOSlstat(name,buf) lstat64(name, (struct stat64 *)buf)
#else
# define TclOSstat(name, buf) stat(name, (struct stat *)buf)
# define TclOSlstat(name, buf) lstat(name, (struct stat *)buf)
#endif
/*
*---------------------------------------------------------------------------
* Miscellaneous includes that might be missing.
*---------------------------------------------------------------------------
*/
|
| ︙ | ︙ | |||
151 152 153 154 155 156 157 158 159 160 161 162 163 164 | #endif #ifdef HAVE_INTTYPES_H # include <inttypes.h> #endif #include <limits.h> #ifdef HAVE_STDINT_H # include <stdint.h> #endif #include <unistd.h> MODULE_SCOPE int TclUnixSetBlockingMode(int fd, int mode); #include <utime.h> | > > | 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 | #endif #ifdef HAVE_INTTYPES_H # include <inttypes.h> #endif #include <limits.h> #ifdef HAVE_STDINT_H # include <stdint.h> #else # include "../compat/stdint.h" #endif #include <unistd.h> MODULE_SCOPE int TclUnixSetBlockingMode(int fd, int mode); #include <utime.h> |
| ︙ | ︙ | |||
236 237 238 239 240 241 242 | *--------------------------------------------------------------------------- * Supply definitions for macros to query wait status, if not already defined * in header files above. *--------------------------------------------------------------------------- */ #ifndef WIFEXITED | | | | | | | | 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 | *--------------------------------------------------------------------------- * Supply definitions for macros to query wait status, if not already defined * in header files above. *--------------------------------------------------------------------------- */ #ifndef WIFEXITED # define WIFEXITED(stat) (((*((int *) &(stat))) & 0xFF) == 0) #endif #ifndef WEXITSTATUS # define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xFF) #endif #ifndef WIFSIGNALED # define WIFSIGNALED(stat) \ (((*((int *) &(stat)))) && ((*((int *) &(stat))) \ == ((*((int *) &(stat))) & 0x00FF))) #endif #ifndef WTERMSIG # define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7F) #endif #ifndef WIFSTOPPED # define WIFSTOPPED(stat) (((*((int *) &(stat))) & 0xFF) == 0177) #endif #ifndef WSTOPSIG # define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xFF) #endif /* *--------------------------------------------------------------------------- * Define constants for waitpid() system call if they aren't defined by a * system header file. *--------------------------------------------------------------------------- |
| ︙ | ︙ | |||
667 668 669 670 671 672 673 | /* *--------------------------------------------------------------------------- * The following defines wrap the system memory allocation routines. *--------------------------------------------------------------------------- */ | | | | | 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 | /* *--------------------------------------------------------------------------- * The following defines wrap the system memory allocation routines. *--------------------------------------------------------------------------- */ #define TclpSysAlloc(size, isBin) malloc((size_t)(size)) #define TclpSysFree(ptr) free((char *)(ptr)) #define TclpSysRealloc(ptr, size) realloc((char *)(ptr), (size_t)(size)) /* *--------------------------------------------------------------------------- * The following macros and declaration wrap the C runtime library functions. *--------------------------------------------------------------------------- */ |
| ︙ | ︙ |
Changes to unix/tclUnixSock.c.
| ︙ | ︙ | |||
62 63 64 65 66 67 68 |
/*
* Only needed for server sockets
*/
Tcl_TcpAcceptProc *acceptProc;
/* Proc to call on accept. */
| | | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 |
/*
* Only needed for server sockets
*/
Tcl_TcpAcceptProc *acceptProc;
/* Proc to call on accept. */
void *acceptProcData; /* The data for the accept proc. */
/*
* Only needed for client sockets
*/
struct addrinfo *addrlist; /* Addresses to connect to. */
struct addrinfo *addr; /* Iterator over addrlist. */
|
| ︙ | ︙ | |||
125 126 127 128 129 130 131 132 | #define SOCKET_BUFSIZE 4096 /* * Static routines for this file: */ static int TcpConnect(Tcl_Interp *interp, TcpState *state); | > | | | | | | | | | > | | > > > > | | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 |
#define SOCKET_BUFSIZE 4096
/*
* Static routines for this file:
*/
static void TcpAsyncCallback(void *clientData, int mask);
static int TcpConnect(Tcl_Interp *interp, TcpState *state);
static void TcpAccept(void *data, int mask);
static int TcpBlockModeProc(void *data, int mode);
static int TcpCloseProc(void *instanceData,
Tcl_Interp *interp);
static int TcpClose2Proc(void *instanceData,
Tcl_Interp *interp, int flags);
static int TcpGetHandleProc(void *instanceData,
int direction, void **handlePtr);
static int TcpGetOptionProc(void *instanceData,
Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
static int TcpInputProc(void *instanceData, char *buf,
int toRead, int *errorCode);
static int TcpOutputProc(void *instanceData,
const char *buf, int toWrite, int *errorCode);
static void TcpThreadActionProc(void *instanceData, int action);
static void TcpWatchProc(void *instanceData, int mask);
static int WaitForConnect(TcpState *statePtr, int *errorCodePtr);
static void WrapNotify(void *clientData, int mask);
/*
* This structure describes the channel type structure for TCP socket
* based IO:
*/
static const Tcl_ChannelType tcpChannelType = {
"tcp", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
#ifndef TCL_NO_DEPRECATED
TcpCloseProc, /* Close proc. */
#else
TCL_CLOSE2PROC, /* Close proc. */
#endif
TcpInputProc, /* Input proc. */
TcpOutputProc, /* Output proc. */
NULL, /* Seek proc. */
NULL, /* Set option proc. */
TcpGetOptionProc, /* Get option proc. */
TcpWatchProc, /* Initialize notifier. */
TcpGetHandleProc, /* Get OS handles out of channel. */
TcpClose2Proc, /* Close2 proc. */
TcpBlockModeProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
NULL, /* wide seek proc. */
TcpThreadActionProc, /* thread action proc. */
NULL /* truncate proc. */
};
/*
* The following variable holds the network name of this host.
*/
|
| ︙ | ︙ | |||
213 214 215 216 217 218 219 |
*
* ----------------------------------------------------------------------
*/
static void
InitializeHostName(
char **valuePtr,
| | | 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 |
*
* ----------------------------------------------------------------------
*/
static void
InitializeHostName(
char **valuePtr,
unsigned int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
const char *native = NULL;
#ifndef NO_UNAME
struct utsname u;
struct hostent *hp;
|
| ︙ | ︙ | |||
235 236 237 238 239 240 241 |
* as it exceeds SYS_NMLN. See if we can just get the immediate
* nodename and get a proper answer that way.
*/
char *dot = strchr(u.nodename, '.');
if (dot != NULL) {
| | | | 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 |
* as it exceeds SYS_NMLN. See if we can just get the immediate
* nodename and get a proper answer that way.
*/
char *dot = strchr(u.nodename, '.');
if (dot != NULL) {
char *node = (char *)ckalloc(dot - u.nodename + 1);
memcpy(node, u.nodename, dot - u.nodename);
node[dot - u.nodename] = '\0';
hp = TclpGetHostByName(node);
ckfree(node);
}
}
if (hp != NULL) {
native = hp->h_name;
} else {
native = u.nodename;
}
|
| ︙ | ︙ | |||
279 280 281 282 283 284 285 |
native = buffer;
}
#endif /* NO_UNAME */
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
if (native) {
*lengthPtr = strlen(native);
| | | | 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 |
native = buffer;
}
#endif /* NO_UNAME */
*encodingPtr = Tcl_GetEncoding(NULL, NULL);
if (native) {
*lengthPtr = strlen(native);
*valuePtr = (char *)ckalloc(*lengthPtr + 1);
memcpy(*valuePtr, native, *lengthPtr + 1);
} else {
*lengthPtr = 0;
*valuePtr = (char *)ckalloc(1);
*valuePtr[0] = '\0';
}
}
/*
* ----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
309 310 311 312 313 314 315 |
*
* ----------------------------------------------------------------------
*/
const char *
Tcl_GetHostName(void)
{
| | < | | 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 |
*
* ----------------------------------------------------------------------
*/
const char *
Tcl_GetHostName(void)
{
return Tcl_GetString(TclGetProcessGlobalValue(&hostName));
}
/*
* ----------------------------------------------------------------------
*
* TclpHasSockets --
*
* Detect if sockets are available on this platform.
*
* Results:
* Returns TCL_OK.
*
* Side effects:
* None.
*
* ----------------------------------------------------------------------
*/
int
TclpHasSockets(
TCL_UNUSED(Tcl_Interp *))
{
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
375 376 377 378 379 380 381 | * * Side effects: * Sets the device into blocking or nonblocking mode. * * ---------------------------------------------------------------------- */ | < | | | 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 |
*
* Side effects:
* Sets the device into blocking or nonblocking mode.
*
* ----------------------------------------------------------------------
*/
static int
TcpBlockModeProc(
void *instanceData, /* Socket state. */
int mode) /* The mode to set. Can be one of
* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
TcpState *statePtr = (TcpState *)instanceData;
if (mode == TCL_MODE_BLOCKING) {
CLEAR_BITS(statePtr->flags, TCP_NONBLOCKING);
} else {
SET_BITS(statePtr->flags, TCP_NONBLOCKING);
}
if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) {
|
| ︙ | ︙ | |||
521 522 523 524 525 526 527 | * * Side effects: * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ | < | | | | 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 |
*
* Side effects:
* Reads input from the input device of the channel.
*
*----------------------------------------------------------------------
*/
static int
TcpInputProc(
void *instanceData, /* Socket state. */
char *buf, /* Where to store data read. */
int bufSize, /* How much space is available in the
* buffer? */
int *errorCodePtr) /* Where to store error code. */
{
TcpState *statePtr = (TcpState *)instanceData;
int bytesRead;
*errorCodePtr = 0;
if (WaitForConnect(statePtr, errorCodePtr) != 0) {
return -1;
}
bytesRead = recv(statePtr->fds.fd, buf, (size_t) bufSize, 0);
if (bytesRead > -1) {
return bytesRead;
}
if (errno == ECONNRESET) {
/*
* Turn ECONNRESET into a soft EOF condition.
*/
|
| ︙ | ︙ | |||
575 576 577 578 579 580 581 | * Writes output on the output device of the channel. * *---------------------------------------------------------------------- */ static int TcpOutputProc( | | | | | 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 |
* Writes output on the output device of the channel.
*
*----------------------------------------------------------------------
*/
static int
TcpOutputProc(
void *instanceData, /* Socket state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
{
TcpState *statePtr = (TcpState *)instanceData;
int written;
*errorCodePtr = 0;
if (WaitForConnect(statePtr, errorCodePtr) != 0) {
return -1;
}
written = send(statePtr->fds.fd, buf, (size_t) toWrite, 0);
if (written > -1) {
return written;
}
*errorCodePtr = errno;
return -1;
}
|
| ︙ | ︙ | |||
614 615 616 617 618 619 620 | * * Side effects: * Closes the socket of the channel. * *---------------------------------------------------------------------- */ | < | | | | 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 |
*
* Side effects:
* Closes the socket of the channel.
*
*----------------------------------------------------------------------
*/
static int
TcpCloseProc(
void *instanceData, /* The socket to close. */
TCL_UNUSED(Tcl_Interp *))
{
TcpState *statePtr = (TcpState *)instanceData;
int errorCode = 0;
TcpFdList *fds;
/*
* Delete a file handler that may be active for this socket if this is a
* server socket - the file handler was created automatically by Tcl as
* part of the mechanism to accept new client connections. Channel
|
| ︙ | ︙ | |||
646 647 648 649 650 651 652 |
}
}
fds = statePtr->fds.next;
while (fds != NULL) {
TcpFdList *next = fds->next;
| | | | 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 |
}
}
fds = statePtr->fds.next;
while (fds != NULL) {
TcpFdList *next = fds->next;
ckfree(fds);
fds = next;
}
if (statePtr->addrlist != NULL) {
freeaddrinfo(statePtr->addrlist);
}
if (statePtr->myaddrlist != NULL) {
freeaddrinfo(statePtr->myaddrlist);
}
ckfree(statePtr);
return errorCode;
}
/*
*----------------------------------------------------------------------
*
* TcpClose2Proc --
|
| ︙ | ︙ | |||
678 679 680 681 682 683 684 | * Shuts down one side of the socket. * *---------------------------------------------------------------------- */ static int TcpClose2Proc( | | | | | | < < < < < | < < < | < < | > | | | | < | 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 |
* Shuts down one side of the socket.
*
*----------------------------------------------------------------------
*/
static int
TcpClose2Proc(
void *instanceData, /* The socket to close. */
TCL_UNUSED(Tcl_Interp *),
int flags) /* Flags that indicate which side to close. */
{
TcpState *statePtr = (TcpState *)instanceData;
int readError = 0;
int writeError = 0;
/*
* Shutdown the OS socket handle.
*/
if ((flags & (TCL_CLOSE_READ|TCL_CLOSE_WRITE)) == 0) {
return TcpCloseProc(instanceData, NULL);
}
if ((flags & TCL_CLOSE_READ) && (shutdown(statePtr->fds.fd, SHUT_RD) < 0)) {
readError = errno;
}
if ((flags & TCL_CLOSE_WRITE) && (shutdown(statePtr->fds.fd, SHUT_WR) < 0)) {
writeError = errno;
}
return (readError != 0) ? readError : writeError;
}
/*
*----------------------------------------------------------------------
*
* TcpHostPortList --
*
|
| ︙ | ︙ | |||
839 840 841 842 843 844 845 | * None. * *---------------------------------------------------------------------- */ static int TcpGetOptionProc( | | | | 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TcpGetOptionProc(
void *instanceData, /* Socket state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Name of the option to retrieve the value
* for, or NULL to get all options and their
* values. */
Tcl_DString *dsPtr) /* Where to store the computed value;
* initialized by caller. */
{
TcpState *statePtr = (TcpState *)instanceData;
size_t len = 0;
WaitForConnect(statePtr, NULL);
if (optionName != NULL) {
len = strlen(optionName);
}
|
| ︙ | ︙ | |||
989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 |
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* TcpWatchProc --
*
* Initialize the notifier to watch the fd from this channel.
*
* Results:
* None.
*
* Side effects:
* Sets up the notifier so that a future event on the channel will be
* seen by Tcl.
*
* ----------------------------------------------------------------------
*/
static void
WrapNotify(
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 |
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* TcpThreadActionProc --
*
* Handles detach/attach for asynchronously connecting socket.
*
* Reassigning the file handler associated with thread-related channel
* notification, responsible for callbacks (signaling that asynchronous
* connection attempt has succeeded or failed).
*
* Results:
* None.
*
* ----------------------------------------------------------------------
*/
static void
TcpThreadActionProc(
void *instanceData,
int action)
{
TcpState *statePtr = (TcpState *)instanceData;
if (GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT)) {
/*
* Async-connecting socket must get reassigned handler if it have been
* transferred to another thread. Remove the handler if the socket is
* not managed by this thread anymore and create new handler (TSD related)
* so the callback will run in the correct thread, bug [f583715154].
*/
switch (action) {
case TCL_CHANNEL_THREAD_REMOVE:
CLEAR_BITS(statePtr->flags, TCP_ASYNC_PENDING);
Tcl_DeleteFileHandler(statePtr->fds.fd);
break;
case TCL_CHANNEL_THREAD_INSERT:
Tcl_CreateFileHandler(statePtr->fds.fd,
TCL_WRITABLE | TCL_EXCEPTION, TcpAsyncCallback, statePtr);
SET_BITS(statePtr->flags, TCP_ASYNC_PENDING);
break;
}
}
}
/*
* ----------------------------------------------------------------------
*
* TcpWatchProc --
*
* Initialize the notifier to watch the fd from this channel.
*
* Results:
* None.
*
* Side effects:
* Sets up the notifier so that a future event on the channel will be
* seen by Tcl.
*
* ----------------------------------------------------------------------
*/
static void
WrapNotify(
void *clientData,
int mask)
{
TcpState *statePtr = (TcpState *) clientData;
int newmask = mask & statePtr->interest;
if (newmask == 0) {
/*
|
| ︙ | ︙ | |||
1034 1035 1036 1037 1038 1039 1040 |
newmask = TCL_WRITABLE;
}
Tcl_NotifyChannel(statePtr->channel, newmask);
}
static void
TcpWatchProc(
| | | | 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 |
newmask = TCL_WRITABLE;
}
Tcl_NotifyChannel(statePtr->channel, newmask);
}
static void
TcpWatchProc(
void *instanceData, /* The socket state. */
int mask) /* Events of interest; an OR-ed combination of
* TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
TcpState *statePtr = (TcpState *)instanceData;
if (statePtr->acceptProc != NULL) {
/*
* Make sure we don't mess with server sockets since they will never
* be readable or writable at the Tcl level. This keeps Tcl scripts
* from interfering with the -accept behavior (bug #3394732).
*/
|
| ︙ | ︙ | |||
1105 1106 1107 1108 1109 1110 1111 | * * Side effects: * None. * * ---------------------------------------------------------------------- */ | < | | | | | < < | | | 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 |
*
* Side effects:
* None.
*
* ----------------------------------------------------------------------
*/
static int
TcpGetHandleProc(
void *instanceData, /* The socket state. */
TCL_UNUSED(int) /*direction*/,
void **handlePtr) /* Where to store the handle. */
{
TcpState *statePtr = (TcpState *)instanceData;
*handlePtr = INT2PTR(statePtr->fds.fd);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* TcpAsyncCallback --
*
* Called by the event handler that TcpConnect sets up internally for
* [socket -async] to get notified when the asynchronous connection
* attempt has succeeded or failed.
*
* ----------------------------------------------------------------------
*/
static void
TcpAsyncCallback(
void *clientData, /* The socket state. */
TCL_UNUSED(int) /*mask*/)
{
TcpConnect(NULL, (TcpState *)clientData);
}
/*
* ----------------------------------------------------------------------
*
* TcpConnect --
*
|
| ︙ | ︙ | |||
1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 |
Tcl_Interp *interp, /* For error reporting; can be NULL. */
TcpState *statePtr)
{
socklen_t optlen;
int async_callback = GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING);
int ret = -1, error = EHOSTUNREACH;
int async = GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
if (async_callback) {
goto reenter;
}
for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL;
statePtr->addr = statePtr->addr->ai_next) {
for (statePtr->myaddr = statePtr->myaddrlist;
statePtr->myaddr != NULL;
statePtr->myaddr = statePtr->myaddr->ai_next) {
| > < | 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 |
Tcl_Interp *interp, /* For error reporting; can be NULL. */
TcpState *statePtr)
{
socklen_t optlen;
int async_callback = GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING);
int ret = -1, error = EHOSTUNREACH;
int async = GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
static const int reuseaddr = 1;
if (async_callback) {
goto reenter;
}
for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL;
statePtr->addr = statePtr->addr->ai_next) {
for (statePtr->myaddr = statePtr->myaddrlist;
statePtr->myaddr != NULL;
statePtr->myaddr = statePtr->myaddr->ai_next) {
/*
* No need to try combinations of local and remote addresses of
* different families.
*/
if (statePtr->myaddr->ai_family != statePtr->addr->ai_family) {
|
| ︙ | ︙ | |||
1396 1397 1398 1399 1400 1401 1402 |
return NULL;
}
/*
* Allocate a new TcpState for this socket.
*/
| | | 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 |
return NULL;
}
/*
* Allocate a new TcpState for this socket.
*/
statePtr = (TcpState *)ckalloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
statePtr->flags = async ? TCP_ASYNC_CONNECT : 0;
statePtr->cachedBlocking = TCL_MODE_BLOCKING;
statePtr->addrlist = addrlist;
statePtr->myaddrlist = myaddrlist;
statePtr->fds.fd = -1;
|
| ︙ | ︙ | |||
1443 1444 1445 1446 1447 1448 1449 | * None. * *---------------------------------------------------------------------- */ Tcl_Channel Tcl_MakeTcpClientChannel( | | | 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 |
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
Tcl_MakeTcpClientChannel(
void *sock) /* The socket to wrap up into a channel. */
{
return (Tcl_Channel) TclpMakeTcpClientChannelMode(sock,
TCL_READABLE | TCL_WRITABLE);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1475 1476 1477 1478 1479 1480 1481 |
void *sock, /* The socket to wrap up into a channel. */
int mode) /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
TcpState *statePtr;
char channelName[SOCK_CHAN_LENGTH];
| | | 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 |
void *sock, /* The socket to wrap up into a channel. */
int mode) /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
TcpState *statePtr;
char channelName[SOCK_CHAN_LENGTH];
statePtr = (TcpState *)ckalloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
statePtr->fds.fd = PTR2INT(sock);
statePtr->flags = 0;
sprintf(channelName, SOCK_TEMPLATE, (long)statePtr);
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
|
| ︙ | ︙ | |||
1518 1519 1520 1521 1522 1523 1524 |
Tcl_Interp *interp, /* For error reporting - may be NULL. */
const char *service, /* Port number to open. */
const char *myHost, /* Name of local host. */
unsigned int flags, /* Flags. */
Tcl_TcpAcceptProc *acceptProc,
/* Callback for accepting connections from new
* clients. */
| | | 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 |
Tcl_Interp *interp, /* For error reporting - may be NULL. */
const char *service, /* Port number to open. */
const char *myHost, /* Name of local host. */
unsigned int flags, /* Flags. */
Tcl_TcpAcceptProc *acceptProc,
/* Callback for accepting connections from new
* clients. */
void *acceptProcData) /* Data for the callback. */
{
int status = 0, sock = -1, optvalue, port, chosenport;
struct addrinfo *addrlist = NULL, *addrPtr; /* socket address */
TcpState *statePtr = NULL;
char channelName[SOCK_CHAN_LENGTH];
const char *errorMsg = NULL;
TcpFdList *fds = NULL, *newfds;
|
| ︙ | ︙ | |||
1698 1699 1700 1701 1702 1703 1704 |
continue;
}
if (statePtr == NULL) {
/*
* Allocate a new TcpState for this socket.
*/
| | | | 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 |
continue;
}
if (statePtr == NULL) {
/*
* Allocate a new TcpState for this socket.
*/
statePtr = (TcpState *)ckalloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
statePtr->acceptProc = acceptProc;
statePtr->acceptProcData = acceptProcData;
sprintf(channelName, SOCK_TEMPLATE, (long) statePtr);
newfds = &statePtr->fds;
} else {
newfds = (TcpFdList *)ckalloc(sizeof(TcpFdList));
memset(newfds, (int) 0, sizeof(TcpFdList));
fds->next = newfds;
}
newfds->fd = sock;
newfds->statePtr = statePtr;
fds = newfds;
|
| ︙ | ︙ | |||
1763 1764 1765 1766 1767 1768 1769 | * Side effects: * Creates a new connection socket. Calls the registered callback for the * connection acceptance mechanism. * *---------------------------------------------------------------------- */ | < | | | | | 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 |
* Side effects:
* Creates a new connection socket. Calls the registered callback for the
* connection acceptance mechanism.
*
*----------------------------------------------------------------------
*/
static void
TcpAccept(
void *data, /* Callback token. */
TCL_UNUSED(int) /*mask*/)
{
TcpFdList *fds = (TcpFdList *)data; /* Client data of server socket. */
int newsock; /* The new client socket */
TcpState *newSockState; /* State for new socket. */
address addr; /* The remote address */
socklen_t len; /* For accept interface */
char channelName[SOCK_CHAN_LENGTH];
char host[NI_MAXHOST], port[NI_MAXSERV];
len = sizeof(addr);
newsock = accept(fds->fd, &addr.sa, &len);
if (newsock < 0) {
return;
}
/*
* Set close-on-exec flag to prevent the newly accepted socket from being
* inherited by child processes.
*/
(void) fcntl(newsock, F_SETFD, FD_CLOEXEC);
newSockState = (TcpState *)ckalloc(sizeof(TcpState));
memset(newSockState, 0, sizeof(TcpState));
newSockState->flags = 0;
newSockState->fds.fd = newsock;
sprintf(channelName, SOCK_TEMPLATE, (long) newSockState);
newSockState->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
newSockState, TCL_READABLE | TCL_WRITABLE);
|
| ︙ | ︙ |
Changes to unix/tclUnixTest.c.
| ︙ | ︙ | |||
58 59 60 61 62 63 64 | static const char *gotsig = "0"; /* * Forward declarations of functions defined later in this file: */ | | | | < | | < < | | 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | static const char *gotsig = "0"; /* * Forward declarations of functions defined later in this file: */ static Tcl_ObjCmdProc TestalarmCmd; static Tcl_ObjCmdProc TestchmodCmd; static Tcl_ObjCmdProc TestfilehandlerCmd; static Tcl_ObjCmdProc TestfilewaitCmd; static Tcl_ObjCmdProc TestfindexecutableCmd; static Tcl_ObjCmdProc TestforkCmd; static Tcl_ObjCmdProc TestgotsigCmd; static Tcl_FileProc TestFileHandlerProc; static void AlarmHandler(int signum); /* *---------------------------------------------------------------------- * * TclplatformtestInit -- |
| ︙ | ︙ | |||
94 95 96 97 98 99 100 |
int
TclplatformtestInit(
Tcl_Interp *interp) /* Interpreter to add commands to. */
{
Tcl_CreateObjCommand(interp, "testchmod", TestchmodCmd,
NULL, NULL);
| | | | | < < | | < < < < | 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 |
int
TclplatformtestInit(
Tcl_Interp *interp) /* Interpreter to add commands to. */
{
Tcl_CreateObjCommand(interp, "testchmod", TestchmodCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfilehandler", TestfilehandlerCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfilewait", TestfilewaitCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfindexecutable", TestfindexecutableCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testfork", TestforkCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testalarm", TestalarmCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testgotsig", TestgotsigCmd,
NULL, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
134 135 136 137 138 139 140 | * None. * *---------------------------------------------------------------------- */ static int TestfilehandlerCmd( | | | | | | < | | | | | | | < | | | < | | < | | | | | | | | | | | | < | | | < | | | | | < | | | < | | | | | | | | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestfilehandlerCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
Pipe *pipePtr;
int i, mask, timeout;
static int initialized = 0;
char buffer[4000];
TclFile file;
/*
* NOTE: When we make this code work on Windows also, the following
* variable needs to be made Unix-only.
*/
if (!initialized) {
for (i = 0; i < MAX_PIPES; i++) {
testPipes[i].readFile = NULL;
}
initialized = 1;
}
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ...");
return TCL_ERROR;
}
pipePtr = NULL;
if (objc >= 3) {
if (Tcl_GetIntFromObj(interp, objv[2], &i) != TCL_OK) {
return TCL_ERROR;
}
if (i >= MAX_PIPES) {
Tcl_AppendResult(interp, "bad index ", objv[2], NULL);
return TCL_ERROR;
}
pipePtr = &testPipes[i];
}
if (strcmp(Tcl_GetString(objv[1]), "close") == 0) {
for (i = 0; i < MAX_PIPES; i++) {
if (testPipes[i].readFile != NULL) {
TclpCloseFile(testPipes[i].readFile);
testPipes[i].readFile = NULL;
TclpCloseFile(testPipes[i].writeFile);
testPipes[i].writeFile = NULL;
}
}
} else if (strcmp(Tcl_GetString(objv[1]), "clear") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "index");
return TCL_ERROR;
}
pipePtr->readCount = pipePtr->writeCount = 0;
} else if (strcmp(Tcl_GetString(objv[1]), "counts") == 0) {
char buf[TCL_INTEGER_SPACE * 2];
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "index");
return TCL_ERROR;
}
sprintf(buf, "%d %d", pipePtr->readCount, pipePtr->writeCount);
Tcl_AppendResult(interp, buf, NULL);
} else if (strcmp(Tcl_GetString(objv[1]), "create") == 0) {
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "index readMode writeMode");
return TCL_ERROR;
}
if (pipePtr->readFile == NULL) {
if (!TclpCreatePipe(&pipePtr->readFile, &pipePtr->writeFile)) {
Tcl_AppendResult(interp, "couldn't open pipe: ",
Tcl_PosixError(interp), NULL);
return TCL_ERROR;
}
#ifdef O_NONBLOCK
fcntl(GetFd(pipePtr->readFile), F_SETFL, O_NONBLOCK);
fcntl(GetFd(pipePtr->writeFile), F_SETFL, O_NONBLOCK);
#else
Tcl_AppendResult(interp, "can't make pipes non-blocking",
NULL);
return TCL_ERROR;
#endif
}
pipePtr->readCount = 0;
pipePtr->writeCount = 0;
if (strcmp(Tcl_GetString(objv[3]), "readable") == 0) {
Tcl_CreateFileHandler(GetFd(pipePtr->readFile), TCL_READABLE,
TestFileHandlerProc, pipePtr);
} else if (strcmp(Tcl_GetString(objv[3]), "off") == 0) {
Tcl_DeleteFileHandler(GetFd(pipePtr->readFile));
} else if (strcmp(Tcl_GetString(objv[3]), "disabled") == 0) {
Tcl_CreateFileHandler(GetFd(pipePtr->readFile), 0,
TestFileHandlerProc, pipePtr);
} else {
Tcl_AppendResult(interp, "bad read mode \"", Tcl_GetString(objv[3]), "\"", NULL);
return TCL_ERROR;
}
if (strcmp(Tcl_GetString(objv[4]), "writable") == 0) {
Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), TCL_WRITABLE,
TestFileHandlerProc, pipePtr);
} else if (strcmp(Tcl_GetString(objv[4]), "off") == 0) {
Tcl_DeleteFileHandler(GetFd(pipePtr->writeFile));
} else if (strcmp(Tcl_GetString(objv[4]), "disabled") == 0) {
Tcl_CreateFileHandler(GetFd(pipePtr->writeFile), 0,
TestFileHandlerProc, pipePtr);
} else {
Tcl_AppendResult(interp, "bad read mode \"", Tcl_GetString(objv[4]), "\"", NULL);
return TCL_ERROR;
}
} else if (strcmp(Tcl_GetString(objv[1]), "empty") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "index");
return TCL_ERROR;
}
while (read(GetFd(pipePtr->readFile), buffer, 4000) > 0) {
/* Empty loop body. */
}
} else if (strcmp(Tcl_GetString(objv[1]), "fill") == 0) {
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "index");
return TCL_ERROR;
}
memset(buffer, 'a', 4000);
while (write(GetFd(pipePtr->writeFile), buffer, 4000) > 0) {
/* Empty loop body. */
}
} else if (strcmp(Tcl_GetString(objv[1]), "fillpartial") == 0) {
char buf[TCL_INTEGER_SPACE];
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "index");
return TCL_ERROR;
}
memset(buffer, 'b', 10);
TclFormatInt(buf, write(GetFd(pipePtr->writeFile), buffer, 10));
Tcl_AppendResult(interp, buf, NULL);
} else if (strcmp(Tcl_GetString(objv[1]), "oneevent") == 0) {
Tcl_DoOneEvent(TCL_FILE_EVENTS|TCL_DONT_WAIT);
} else if (strcmp(Tcl_GetString(objv[1]), "wait") == 0) {
if (objc != 5) {
Tcl_WrongNumArgs(interp, 2, objv, "index readable|writable timeout");
return TCL_ERROR;
}
if (pipePtr->readFile == NULL) {
Tcl_AppendResult(interp, "pipe ", Tcl_GetString(objv[2]), " doesn't exist", NULL);
return TCL_ERROR;
}
if (strcmp(Tcl_GetString(objv[3]), "readable") == 0) {
mask = TCL_READABLE;
file = pipePtr->readFile;
} else {
mask = TCL_WRITABLE;
file = pipePtr->writeFile;
}
if (Tcl_GetIntFromObj(interp, objv[4], &timeout) != TCL_OK) {
return TCL_ERROR;
}
i = TclUnixWaitForFile(GetFd(file), mask, timeout);
if (i & TCL_READABLE) {
Tcl_AppendElement(interp, "readable");
}
if (i & TCL_WRITABLE) {
Tcl_AppendElement(interp, "writable");
}
} else if (strcmp(Tcl_GetString(objv[1]), "windowevent") == 0) {
Tcl_DoOneEvent(TCL_WINDOW_EVENTS|TCL_DONT_WAIT);
} else {
Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
"\": must be close, clear, counts, create, empty, fill, "
"fillpartial, oneevent, wait, or windowevent", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static void
TestFileHandlerProc(
ClientData clientData, /* Points to a Pipe structure. */
int mask) /* Indicates which events happened:
* TCL_READABLE or TCL_WRITABLE. */
{
Pipe *pipePtr = (Pipe *)clientData;
if (mask & TCL_READABLE) {
pipePtr->readCount++;
}
if (mask & TCL_WRITABLE) {
pipePtr->writeCount++;
}
|
| ︙ | ︙ | |||
356 357 358 359 360 361 362 | * None. * *---------------------------------------------------------------------- */ static int TestfilewaitCmd( | | | | | < | | | | | | | | 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 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestfilewaitCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
int mask, result, timeout;
Tcl_Channel channel;
int fd;
ClientData data;
if (objc != 4) {
Tcl_WrongNumArgs(interp, 2, objv, "file readable|writable|both timeout");
return TCL_ERROR;
}
channel = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
if (channel == NULL) {
return TCL_ERROR;
}
if (strcmp(Tcl_GetString(objv[2]), "readable") == 0) {
mask = TCL_READABLE;
} else if (strcmp(Tcl_GetString(objv[2]), "writable") == 0){
mask = TCL_WRITABLE;
} else if (strcmp(Tcl_GetString(objv[2]), "both") == 0){
mask = TCL_WRITABLE|TCL_READABLE;
} else {
Tcl_AppendResult(interp, "bad argument \"", Tcl_GetString(objv[2]),
"\": must be readable, writable, or both", NULL);
return TCL_ERROR;
}
if (Tcl_GetChannelHandle(channel,
(mask & TCL_READABLE) ? TCL_READABLE : TCL_WRITABLE,
(ClientData*) &data) != TCL_OK) {
Tcl_AppendResult(interp, "couldn't get channel file", NULL);
return TCL_ERROR;
}
fd = PTR2INT(data);
if (Tcl_GetIntFromObj(interp, objv[3], &timeout) != TCL_OK) {
return TCL_ERROR;
}
result = TclUnixWaitForFile(fd, mask, timeout);
if (result & TCL_READABLE) {
Tcl_AppendElement(interp, "readable");
}
if (result & TCL_WRITABLE) {
|
| ︙ | ︙ | |||
425 426 427 428 429 430 431 | * None. * *---------------------------------------------------------------------- */ static int TestfindexecutableCmd( | | | | | | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | 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 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestfindexecutableCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
Tcl_Obj *saveName;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "argv0");
return TCL_ERROR;
}
saveName = TclGetObjNameOfExecutable();
Tcl_IncrRefCount(saveName);
TclpFindExecutable(Tcl_GetString(objv[1]));
Tcl_SetObjResult(interp, TclGetObjNameOfExecutable());
TclSetObjNameOfExecutable(saveName, NULL);
Tcl_DecrRefCount(saveName);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestforkCmd --
*
* This function implements the "testfork" command. It is used to
* fork the Tcl process for specific test cases.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TestforkCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
pid_t pid;
if (objc != 1) {
|
| ︙ | ︙ | |||
573 574 575 576 577 578 579 |
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(pid));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | < < > | 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 |
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(pid));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TestalarmCmd --
*
* Test that EINTR is handled correctly by generating and handling a
* signal. This requires using the SA_RESTART flag when registering the
* signal handler.
*
* Results:
* None.
*
* Side Effects:
* Sets up an signal and async handlers.
*
*----------------------------------------------------------------------
*/
static int
TestalarmCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
#ifdef SA_RESTART
unsigned int sec = 1;
struct sigaction action;
if (objc > 1) {
Tcl_GetIntFromObj(interp, objv[1], (int *)&sec);
}
/*
* Setup the signal handling that automatically retries any interrupted
* I/O system calls.
*/
action.sa_handler = AlarmHandler;
memset((void *) &action.sa_mask, 0, sizeof(sigset_t));
action.sa_flags = SA_RESTART;
if (sigaction(SIGALRM, &action, NULL) < 0) {
Tcl_AppendResult(interp, "sigaction: ", Tcl_PosixError(interp), NULL);
return TCL_ERROR;
}
(void) alarm(sec);
return TCL_OK;
#else
Tcl_AppendResult(interp,
"warning: sigaction SA_RESTART not support on this platform",
NULL);
return TCL_ERROR;
#endif
}
|
| ︙ | ︙ | |||
679 680 681 682 683 684 685 | * Calls the Tcl Async handler. * *---------------------------------------------------------------------- */ static void AlarmHandler( | | | 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 |
* Calls the Tcl Async handler.
*
*----------------------------------------------------------------------
*/
static void
AlarmHandler(
TCL_UNUSED(int) /*signum*/)
{
gotsig = "1";
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
702 703 704 705 706 707 708 | * Resets the value of gotsig back to '0'. * *---------------------------------------------------------------------- */ static int TestgotsigCmd( | | | | | 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 |
* Resets the value of gotsig back to '0'.
*
*----------------------------------------------------------------------
*/
static int
TestgotsigCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
TCL_UNUSED(int) /*objc*/,
TCL_UNUSED(Tcl_Obj *const *))
{
Tcl_AppendResult(interp, gotsig, NULL);
gotsig = "0";
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
733 734 735 736 737 738 739 | * Changes permissions of specified files. * *--------------------------------------------------------------------------- */ static int TestchmodCmd( | | | 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 |
* Changes permissions of specified files.
*
*---------------------------------------------------------------------------
*/
static int
TestchmodCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
int i, mode;
if (objc < 2) {
|
| ︙ | ︙ |
Changes to unix/tclUnixThrd.c.
| ︙ | ︙ | |||
156 157 158 159 160 161 162 163 164 165 166 167 168 169 |
PMutex *pmutexPtr,
struct timespec *ptime)
{
pthread_cond_timedwait(pcondPtr, &pmutexPtr->mutex, ptime);
}
#endif /* HAVE_PTHREAD_MUTEX_RECURSIVE */
/*
* masterLock is used to serialize creation of mutexes, condition variables,
* and thread local storage. This is the only place that can count on the
* ability to statically initialize the mutex.
*/
static pthread_mutex_t masterLock = PTHREAD_MUTEX_INITIALIZER;
| > > > > > > > > | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 |
PMutex *pmutexPtr,
struct timespec *ptime)
{
pthread_cond_timedwait(pcondPtr, &pmutexPtr->mutex, ptime);
}
#endif /* HAVE_PTHREAD_MUTEX_RECURSIVE */
#ifndef TCL_NO_DEPRECATED
typedef struct {
char nabuf[16];
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#endif /* TCL_NO_DEPRECATED */
/*
* masterLock is used to serialize creation of mutexes, condition variables,
* and thread local storage. This is the only place that can count on the
* ability to statically initialize the mutex.
*/
static pthread_mutex_t masterLock = PTHREAD_MUTEX_INITIALIZER;
|
| ︙ | ︙ | |||
210 211 212 213 214 215 216 |
*/
int
TclpThreadCreate(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread */
ClientData clientData, /* The one argument to Main() */
| | | | 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 |
*/
int
TclpThreadCreate(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread */
ClientData clientData, /* The one argument to Main() */
int stackSize, /* Size of stack for the new thread */
int flags) /* Flags controlling behaviour of the new
* thread. */
{
#if TCL_THREADS
pthread_attr_t attr;
pthread_t theThread;
int result;
pthread_attr_init(&attr);
pthread_attr_setscope(&attr, PTHREAD_SCOPE_SYSTEM);
#ifdef HAVE_PTHREAD_ATTR_SETSTACKSIZE
if (stackSize != TCL_THREAD_STACK_DEFAULT) {
pthread_attr_setstacksize(&attr, (size_t) stackSize);
#ifdef TCL_THREAD_STACK_MIN
} else {
/*
* Certain systems define a thread stack size that by default is too
* small for many operations. The user has the option of defining
* TCL_THREAD_STACK_MIN to a value large enough to work for their
* needs. This would look like (for 128K min stack):
|
| ︙ | ︙ | |||
254 255 256 257 258 259 260 |
#endif /* HAVE_PTHREAD_ATTR_SETSTACKSIZE */
if (!(flags & TCL_THREAD_JOINABLE)) {
pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
}
if (pthread_create(&theThread, &attr,
| | | | 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 |
#endif /* HAVE_PTHREAD_ATTR_SETSTACKSIZE */
if (!(flags & TCL_THREAD_JOINABLE)) {
pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);
}
if (pthread_create(&theThread, &attr,
(void * (*)(void *))(void *)proc, (void *) clientData) &&
pthread_create(&theThread, NULL,
(void * (*)(void *))(void *)proc, (void *) clientData)) {
result = TCL_ERROR;
} else {
*idPtr = (Tcl_ThreadId) theThread;
result = TCL_OK;
}
pthread_attr_destroy(&attr);
return result;
|
| ︙ | ︙ | |||
565 566 567 568 569 570 571 |
if (*mutexPtr == NULL) {
pthread_mutex_lock(&masterLock);
if (*mutexPtr == NULL) {
/*
* Double inside master lock check to avoid a race condition.
*/
| | | 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 |
if (*mutexPtr == NULL) {
pthread_mutex_lock(&masterLock);
if (*mutexPtr == NULL) {
/*
* Double inside master lock check to avoid a race condition.
*/
pmutexPtr = (PMutex *)ckalloc(sizeof(PMutex));
PMutexInit(pmutexPtr);
*mutexPtr = (Tcl_Mutex) pmutexPtr;
TclRememberMutex(mutexPtr);
}
pthread_mutex_unlock(&masterLock);
}
pmutexPtr = *((PMutex **) mutexPtr);
|
| ︙ | ︙ | |||
629 630 631 632 633 634 635 |
TclpFinalizeMutex(
Tcl_Mutex *mutexPtr)
{
PMutex *pmutexPtr = *(PMutex **) mutexPtr;
if (pmutexPtr != NULL) {
PMutexDestroy(pmutexPtr);
| | | 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 |
TclpFinalizeMutex(
Tcl_Mutex *mutexPtr)
{
PMutex *pmutexPtr = *(PMutex **) mutexPtr;
if (pmutexPtr != NULL) {
PMutexDestroy(pmutexPtr);
ckfree(pmutexPtr);
*mutexPtr = NULL;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
675 676 677 678 679 680 681 |
/*
* Double check inside mutex to avoid race, then initialize condition
* variable if necessary.
*/
if (*condPtr == NULL) {
| | | 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 |
/*
* Double check inside mutex to avoid race, then initialize condition
* variable if necessary.
*/
if (*condPtr == NULL) {
pcondPtr = (pthread_cond_t *)ckalloc(sizeof(pthread_cond_t));
pthread_cond_init(pcondPtr, NULL);
*condPtr = (Tcl_Condition) pcondPtr;
TclRememberCondition(condPtr);
}
pthread_mutex_unlock(&masterLock);
}
pmutexPtr = *((PMutex **) mutexPtr);
|
| ︙ | ︙ | |||
763 764 765 766 767 768 769 |
TclpFinalizeCondition(
Tcl_Condition *condPtr)
{
pthread_cond_t *pcondPtr = *(pthread_cond_t **) condPtr;
if (pcondPtr != NULL) {
pthread_cond_destroy(pcondPtr);
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 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 |
TclpFinalizeCondition(
Tcl_Condition *condPtr)
{
pthread_cond_t *pcondPtr = *(pthread_cond_t **) condPtr;
if (pcondPtr != NULL) {
pthread_cond_destroy(pcondPtr);
ckfree(pcondPtr);
*condPtr = NULL;
}
}
#endif /* TCL_THREADS */
/*
*----------------------------------------------------------------------
*
* TclpReaddir, TclpInetNtoa --
*
* These procedures replace core C versions to be used in a threaded
* environment.
*
* Results:
* See documentation of C functions.
*
* Side effects:
* See documentation of C functions.
*
* Notes:
* TclpReaddir is no longer used by the core (see 1095909), but it
* appears in the internal stubs table (see #589526).
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
Tcl_DirEntry *
TclpReaddir(
TclDIR * dir)
{
return TclOSreaddir(dir);
}
#undef TclpInetNtoa
char *
TclpInetNtoa(
struct in_addr addr)
{
#if TCL_THREADS
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
unsigned char *b = (unsigned char*) &addr.s_addr;
sprintf(tsdPtr->nabuf, "%u.%u.%u.%u", b[0], b[1], b[2], b[3]);
return tsdPtr->nabuf;
#else
return inet_ntoa(addr);
#endif
}
#endif /* TCL_NO_DEPRECATED */
#if TCL_THREADS
/*
* Additions by AOL for specialized thread memory allocator.
*/
#ifdef USE_THREAD_ALLOC
static pthread_key_t key;
typedef struct {
Tcl_Mutex tlock;
PMutex plock;
} AllocMutex;
Tcl_Mutex *
TclpNewAllocMutex(void)
{
AllocMutex *lockPtr;
PMutex *plockPtr;
lockPtr = (AllocMutex *)malloc(sizeof(AllocMutex));
if (lockPtr == NULL) {
Tcl_Panic("could not allocate lock");
}
plockPtr = &lockPtr->plock;
lockPtr->tlock = (Tcl_Mutex) plockPtr;
PMutexInit(&lockPtr->plock);
return &lockPtr->tlock;
|
| ︙ | ︙ | |||
857 858 859 860 861 862 863 |
#endif /* USE_THREAD_ALLOC */
void *
TclpThreadCreateKey(void)
{
pthread_key_t *ptkeyPtr;
| | | | | | 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 |
#endif /* USE_THREAD_ALLOC */
void *
TclpThreadCreateKey(void)
{
pthread_key_t *ptkeyPtr;
ptkeyPtr = (pthread_key_t *)TclpSysAlloc(sizeof(pthread_key_t), 0);
if (NULL == ptkeyPtr) {
Tcl_Panic("unable to allocate thread key!");
}
if (pthread_key_create(ptkeyPtr, NULL)) {
Tcl_Panic("unable to create pthread key!");
}
return ptkeyPtr;
}
void
TclpThreadDeleteKey(
void *keyPtr)
{
pthread_key_t *ptkeyPtr = (pthread_key_t *)keyPtr;
if (pthread_key_delete(*ptkeyPtr)) {
Tcl_Panic("unable to delete key!");
}
TclpSysFree(keyPtr);
}
void
TclpThreadSetMasterTSD(
void *tsdKeyPtr,
void *ptr)
{
pthread_key_t *ptkeyPtr = (pthread_key_t *)tsdKeyPtr;
if (pthread_setspecific(*ptkeyPtr, ptr)) {
Tcl_Panic("unable to set master TSD value");
}
}
void *
TclpThreadGetMasterTSD(
void *tsdKeyPtr)
{
pthread_key_t *ptkeyPtr = (pthread_key_t*)tsdKeyPtr;
return pthread_getspecific(*ptkeyPtr);
}
#endif /* TCL_THREADS */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to unix/tclUnixTime.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclUnixTime.c -- * * Contains Unix specific versions of Tcl functions that obtain time * values from the operating system. * * Copyright (c) 1995 Sun Microsystems, Inc. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | 1 2 3 4 5 6 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 |
/*
* tclUnixTime.c --
*
* Contains Unix specific versions of Tcl functions that obtain time
* values from the operating system.
*
* Copyright (c) 1995 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#if defined(TCL_WIDE_CLICKS) && defined(MAC_OSX_TCL)
#include <mach/mach_time.h>
#endif
/*
* TclpGetDate is coded to return a pointer to a 'struct tm'. For thread
* safety, this structure must be in thread-specific data. The 'tmKey'
* variable is the key to this buffer.
*/
#ifndef TCL_NO_DEPRECATED
static Tcl_ThreadDataKey tmKey;
typedef struct {
struct tm gmtime_buf;
struct tm localtime_buf;
} ThreadSpecificData;
/*
* If we fall back on the thread-unsafe versions of gmtime and localtime, use
* this mutex to try to protect them.
*/
TCL_DECLARE_MUTEX(tmMutex)
static char *lastTZ = NULL; /* Holds the last setting of the TZ
* environment variable, or an empty string if
* the variable was not set. */
/*
* Static functions declared in this file.
*/
static void SetTZIfNecessary(void);
static void CleanupMemory(ClientData clientData);
#endif /* TCL_NO_DEPRECATED */
static void NativeScaleTime(Tcl_Time *timebuf,
ClientData clientData);
static void NativeGetTime(Tcl_Time *timebuf,
ClientData clientData);
/*
* TIP #233 (Virtualized Time): Data for the time hooks, if any.
*/
Tcl_GetTimeProc *tclGetTimeProcPtr = NativeGetTime;
Tcl_ScaleTimeProc *tclScaleTimeProcPtr = NativeScaleTime;
void *tclTimeClientData = NULL;
/*
*----------------------------------------------------------------------
*
* TclpGetSeconds --
*
* This procedure returns the number of seconds from the epoch. On most
* Unix systems the epoch is Midnight Jan 1, 1970 GMT.
*
* Results:
* Number of seconds from the epoch.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
unsigned long
TclpGetSeconds(void)
{
return time(NULL);
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
86 87 88 89 90 91 92 | *---------------------------------------------------------------------- * * TclpGetClicks -- * * This procedure returns a value that represents the highest resolution * clock available on the system. There are no garantees on what the * resolution will be. In Tcl we will call this value a "click". The | | | | | | | | | 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 |
*----------------------------------------------------------------------
*
* TclpGetClicks --
*
* This procedure returns a value that represents the highest resolution
* clock available on the system. There are no garantees on what the
* resolution will be. In Tcl we will call this value a "click". The
* start time is also system dependent.
*
* Results:
* Number of clicks from some start time.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
unsigned long
TclpGetClicks(void)
{
unsigned long now;
#ifdef NO_GETTOD
if (tclGetTimeProcPtr != NativeGetTime) {
Tcl_Time time;
tclGetTimeProcPtr(&time, tclTimeClientData);
now = time.sec*1000000 + time.usec;
} else {
/*
* A semi-NativeGetTime, specialized to clicks.
*/
struct tms dummy;
now = (unsigned long) times(&dummy);
}
#else
Tcl_Time time;
tclGetTimeProcPtr(&time, tclTimeClientData);
now = time.sec*1000000 + time.usec;
#endif
return now;
}
#ifdef TCL_WIDE_CLICKS
/*
*----------------------------------------------------------------------
*
* TclpGetWideClicks --
*
* This procedure returns a WideInt value that represents the highest
* resolution clock available on the system. There are no garantees on
* what the resolution will be. In Tcl we will call this value a "click".
* The start time is also system dependent.
*
* Results:
* Number of WideInt clicks from some start time.
*
* Side effects:
|
| ︙ | ︙ | |||
290 291 292 293 294 295 296 297 298 299 300 301 302 303 |
{
tclGetTimeProcPtr(timePtr, tclTimeClientData);
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetTimeProc --
*
* TIP #233 (Virtualized Time): Registers two handlers for the
* virtualization of Tcl's access to time information.
*
* Results:
* None.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
{
tclGetTimeProcPtr(timePtr, tclTimeClientData);
}
/*
*----------------------------------------------------------------------
*
* TclpGetDate --
*
* This function converts between seconds and struct tm. If useGMT is
* true, then the returned date will be in Greenwich Mean Time (GMT).
* Otherwise, it will be in the local time zone.
*
* Results:
* Returns a static tm structure.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
struct tm *
TclpGetDate(
const time_t *time,
int useGMT)
{
if (useGMT) {
return TclpGmtime(time);
} else {
return TclpLocaltime(time);
}
}
/*
*----------------------------------------------------------------------
*
* TclpGmtime --
*
* Wrapper around the 'gmtime' library function to make it thread safe.
*
* Results:
* Returns a pointer to a 'struct tm' in thread-specific data.
*
* Side effects:
* Invokes gmtime or gmtime_r as appropriate.
*
*----------------------------------------------------------------------
*/
struct tm *
TclpGmtime(
const time_t *timePtr) /* Pointer to the number of seconds since the
* local system's epoch */
{
/*
* Get a thread-local buffer to hold the returned time.
*/
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tmKey);
#ifdef HAVE_GMTIME_R
gmtime_r(timePtr, &tsdPtr->gmtime_buf);
#else
Tcl_MutexLock(&tmMutex);
memcpy(&tsdPtr->gmtime_buf, gmtime(timePtr), sizeof(struct tm));
Tcl_MutexUnlock(&tmMutex);
#endif
return &tsdPtr->gmtime_buf;
}
/*
*----------------------------------------------------------------------
*
* TclpLocaltime --
*
* Wrapper around the 'localtime' library function to make it thread
* safe.
*
* Results:
* Returns a pointer to a 'struct tm' in thread-specific data.
*
* Side effects:
* Invokes localtime or localtime_r as appropriate.
*
*----------------------------------------------------------------------
*/
struct tm *
TclpLocaltime(
const time_t *timePtr) /* Pointer to the number of seconds since the
* local system's epoch */
{
/*
* Get a thread-local buffer to hold the returned time.
*/
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tmKey);
SetTZIfNecessary();
#ifdef HAVE_LOCALTIME_R
localtime_r(timePtr, &tsdPtr->localtime_buf);
#else
Tcl_MutexLock(&tmMutex);
memcpy(&tsdPtr->localtime_buf, localtime(timePtr), sizeof(struct tm));
Tcl_MutexUnlock(&tmMutex);
#endif
return &tsdPtr->localtime_buf;
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_SetTimeProc --
*
* TIP #233 (Virtualized Time): Registers two handlers for the
* virtualization of Tcl's access to time information.
*
* Results:
* None.
|
| ︙ | ︙ | |||
367 368 369 370 371 372 373 | * See above. * *---------------------------------------------------------------------- */ static void NativeScaleTime( | | | | 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 |
* See above.
*
*----------------------------------------------------------------------
*/
static void
NativeScaleTime(
TCL_UNUSED(Tcl_Time *),
TCL_UNUSED(ClientData))
{
/* Native scale is 1:1. Nothing is done */
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
393 394 395 396 397 398 399 |
*
*----------------------------------------------------------------------
*/
static void
NativeGetTime(
Tcl_Time *timePtr,
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
*
*----------------------------------------------------------------------
*/
static void
NativeGetTime(
Tcl_Time *timePtr,
TCL_UNUSED(ClientData))
{
struct timeval tv;
(void) gettimeofday(&tv, NULL);
timePtr->sec = tv.tv_sec;
timePtr->usec = tv.tv_usec;
}
/*
*----------------------------------------------------------------------
*
* SetTZIfNecessary --
*
* Determines whether a call to 'tzset' is needed prior to the next call
* to 'localtime' or examination of the 'timezone' variable.
*
* Results:
* None.
*
* Side effects:
* If 'tzset' has never been called in the current process, or if the
* value of the environment variable TZ has changed since the last call
* to 'tzset', then 'tzset' is called again.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
static void
SetTZIfNecessary(void)
{
const char *newTZ = getenv("TZ");
Tcl_MutexLock(&tmMutex);
if (newTZ == NULL) {
newTZ = "";
}
if (lastTZ == NULL || strcmp(lastTZ, newTZ)) {
tzset();
if (lastTZ == NULL) {
Tcl_CreateExitHandler(CleanupMemory, NULL);
} else {
ckfree(lastTZ);
}
lastTZ = (char *)ckalloc(strlen(newTZ) + 1);
strcpy(lastTZ, newTZ);
}
Tcl_MutexUnlock(&tmMutex);
}
/*
*----------------------------------------------------------------------
*
* CleanupMemory --
*
* Releases the private copy of the TZ environment variable upon exit
* from Tcl.
*
* Results:
* None.
*
* Side effects:
* Frees allocated memory.
*
*----------------------------------------------------------------------
*/
static void
CleanupMemory(
TCL_UNUSED(ClientData))
{
ckfree(lastTZ);
}
#endif /* TCL_NO_DEPRECATED */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to unix/tclXtNotify.c.
| ︙ | ︙ | |||
228 229 230 231 232 233 234 | * Destroys the notifier window. * *---------------------------------------------------------------------- */ static void NotifierExitHandler( | | | 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 |
* Destroys the notifier window.
*
*----------------------------------------------------------------------
*/
static void
NotifierExitHandler(
TCL_UNUSED(ClientData))
{
if (notifier.currentTimeout != 0) {
XtRemoveTimeOut(notifier.currentTimeout);
}
for (; notifier.firstFileHandlerPtr != NULL; ) {
Tcl_DeleteFileHandler(notifier.firstFileHandlerPtr->fd);
}
|
| ︙ | ︙ | |||
264 265 266 267 268 269 270 |
*----------------------------------------------------------------------
*/
static void
SetTimer(
const Tcl_Time *timePtr) /* Timeout value, may be NULL. */
{
| | | | 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 |
*----------------------------------------------------------------------
*/
static void
SetTimer(
const Tcl_Time *timePtr) /* Timeout value, may be NULL. */
{
long timeout;
if (!initialized) {
InitNotifier();
}
TclSetAppContext(NULL);
if (notifier.currentTimeout != 0) {
XtRemoveTimeOut(notifier.currentTimeout);
}
if (timePtr) {
timeout = timePtr->sec * 1000 + timePtr->usec / 1000;
notifier.currentTimeout = XtAppAddTimeOut(notifier.appContext,
(unsigned long) timeout, TimerProc, NULL);
} else {
notifier.currentTimeout = 0;
}
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
301 302 303 304 305 306 307 | * Processes all queued events. * *---------------------------------------------------------------------- */ static void TimerProc( | | | 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 |
* Processes all queued events.
*
*----------------------------------------------------------------------
*/
static void
TimerProc(
TCL_UNUSED(XtPointer),
XtIntervalId *id)
{
if (*id != notifier.currentTimeout) {
return;
}
notifier.currentTimeout = 0;
|
| ︙ | ︙ | |||
355 356 357 358 359 360 361 |
for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
| | | 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 |
for (filePtr = notifier.firstFileHandlerPtr; filePtr != NULL;
filePtr = filePtr->nextPtr) {
if (filePtr->fd == fd) {
break;
}
}
if (filePtr == NULL) {
filePtr = (FileHandler *)ckalloc(sizeof(FileHandler));
filePtr->fd = fd;
filePtr->read = 0;
filePtr->write = 0;
filePtr->except = 0;
filePtr->readyMask = 0;
filePtr->mask = 0;
filePtr->nextPtr = notifier.firstFileHandlerPtr;
|
| ︙ | ︙ | |||
466 467 468 469 470 471 472 |
}
if (filePtr->mask & TCL_WRITABLE) {
XtRemoveInput(filePtr->write);
}
if (filePtr->mask & TCL_EXCEPTION) {
XtRemoveInput(filePtr->except);
}
| | | 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 |
}
if (filePtr->mask & TCL_WRITABLE) {
XtRemoveInput(filePtr->write);
}
if (filePtr->mask & TCL_EXCEPTION) {
XtRemoveInput(filePtr->except);
}
ckfree(filePtr);
}
/*
*----------------------------------------------------------------------
*
* FileProc --
*
|
| ︙ | ︙ | |||
521 522 523 524 525 526 527 |
}
/*
* This is an interesting event, so put it onto the event queue.
*/
filePtr->readyMask |= mask;
| | | 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 |
}
/*
* This is an interesting event, so put it onto the event queue.
*/
filePtr->readyMask |= mask;
fileEvPtr = (FileHandlerEvent *)ckalloc(sizeof(FileHandlerEvent));
fileEvPtr->header.proc = FileHandlerEventProc;
fileEvPtr->fd = filePtr->fd;
Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
/*
* Process events on the Tcl event queue before returning to Xt.
*/
|
| ︙ | ︙ |
Changes to unix/tclXtTest.c.
| ︙ | ︙ | |||
74 75 76 77 78 79 80 | * None. * *---------------------------------------------------------------------- */ static int TesteventloopCmd( | | | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TesteventloopCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static int *framePtr = NULL;/* Pointer to integer on stack frame of
* innermost invocation of the "wait"
* subcommand. */
|
| ︙ | ︙ |
Changes to win/Makefile.in.
| ︙ | ︙ | |||
19 20 21 22 23 24 25 26 27 28 29 30 31 32 | prefix = @prefix@ exec_prefix = @exec_prefix@ bindir = @bindir@ libdir = @libdir@ includedir = @includedir@ datarootdir = @datarootdir@ mandir = @mandir@ # The following definition can be set to non-null for special systems like AFS # with replication. It allows the pathnames used for installation to be # different than those used for actually reference files at run-time. # INSTALL_ROOT is prepended to $prefix and $exec_prefix when installing files. INSTALL_ROOT = | > | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | prefix = @prefix@ exec_prefix = @exec_prefix@ bindir = @bindir@ libdir = @libdir@ includedir = @includedir@ datarootdir = @datarootdir@ runstatedir = @runstatedir@ mandir = @mandir@ # The following definition can be set to non-null for special systems like AFS # with replication. It allows the pathnames used for installation to be # different than those used for actually reference files at run-time. # INSTALL_ROOT is prepended to $prefix and $exec_prefix when installing files. INSTALL_ROOT = |
| ︙ | ︙ | |||
44 45 46 47 48 49 50 51 52 53 54 55 56 57 | # Directory in which to install the .a or .so binary for the Tcl library: LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) # Path name to use when installing library scripts. SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Directory in which to (optionally) install the private tcl headers: PRIVATE_INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Top-level directory in which to install manual entries: | > > > | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 | # Directory in which to install the .a or .so binary for the Tcl library: LIB_INSTALL_DIR = $(INSTALL_ROOT)$(libdir) # Path name to use when installing library scripts. SCRIPT_INSTALL_DIR = $(INSTALL_ROOT)$(TCL_LIBRARY) # Path name to use when installing Tcl modules. MODULE_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)/../tcl8 # Directory in which to install the include file tcl.h: INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Directory in which to (optionally) install the private tcl headers: PRIVATE_INCLUDE_INSTALL_DIR = $(INSTALL_ROOT)$(includedir) # Top-level directory in which to install manual entries: |
| ︙ | ︙ | |||
77 78 79 80 81 82 83 | 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) | | | < > > < > > > | | | < < | 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 | 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 -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 # following lines. COMPILE_DEBUG_FLAGS = #COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG #COMPILE_DEBUG_FLAGS = -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS SRC_DIR = @srcdir@ ROOT_DIR = @srcdir@/.. TOP_DIR = $(shell cd @srcdir@/..; pwd -W 2>/dev/null || pwd -P) GENERIC_DIR = $(TOP_DIR)/generic WIN_DIR = $(TOP_DIR)/win COMPAT_DIR = $(TOP_DIR)/compat PKGS_DIR = $(TOP_DIR)/pkgs ZLIB_DIR = $(COMPAT_DIR)/zlib MINIZIP_DIR = $(ZLIB_DIR)/contrib/minizip TOMMATH_DIR = $(TOP_DIR)/libtommath # Converts a POSIX path to a Windows native path. CYGPATH = @CYGPATH@ libdir_native = $(shell $(CYGPATH) '$(libdir)') bindir_native = $(shell $(CYGPATH) '$(bindir)') includedir_native = $(shell $(CYGPATH) '$(includedir)') mandir_native = $(shell $(CYGPATH) '$(mandir)') TCL_LIBRARY_NATIVE = $(shell $(CYGPATH) '$(TCL_LIBRARY)') GENERIC_DIR_NATIVE = $(shell $(CYGPATH) '$(GENERIC_DIR)') WIN_DIR_NATIVE = $(shell $(CYGPATH) '$(WIN_DIR)') ROOT_DIR_NATIVE = $(shell $(CYGPATH) '$(ROOT_DIR)') SCRIPT_INSTALL_DIR_NATIVE = $(shell $(CYGPATH) '$(SCRIPT_INSTALL_DIR)') INCLUDE_INSTALL_DIR_NATIVE = $(shell $(CYGPATH) '$(INCLUDE_INSTALL_DIR)') MAN_INSTALL_DIR_NATIVE = $(shell $(CYGPATH) '$(MAN_INSTALL_DIR)') ROOT_DIR_WIN_NATIVE = $(shell cd '$(ROOT_DIR)' ; pwd -W 2>/dev/null || pwd -P) ZLIB_DIR_NATIVE = $(shell $(CYGPATH) '$(ZLIB_DIR)') MINIZIP_DIR_NATIVE = $(shell $(CYGPATH) '$(MINIZIP_DIR)') TOMMATH_DIR_NATIVE = $(shell $(CYGPATH) '$(TOMMATH_DIR)') # Fully qualify library path so that `make test` # does not depend on the current directory. LIBRARY_DIR1 = $(shell cd '$(ROOT_DIR_NATIVE)/library' ; pwd -P) LIBRARY_DIR = $(shell $(CYGPATH) '$(LIBRARY_DIR1)') DLLSUFFIX = @DLLSUFFIX@ LIBSUFFIX = @LIBSUFFIX@ |
| ︙ | ︙ | |||
150 151 152 153 154 155 156 |
DDE_LIB_FILE = @LIBPREFIX@tcldde$(DDEVER)${LIBSUFFIX}
REG_DLL_FILE = tclreg$(REGVER)${DLLSUFFIX}
REG_LIB_FILE = @LIBPREFIX@tclreg$(REGVER)${LIBSUFFIX}
TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX}
TEST_EXE_FILE = tcltest${EXESUFFIX}
TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${LIBSUFFIX}
TEST_LOAD_PRMS = lappend ::auto_path {$(ROOT_DIR_WIN_NATIVE)/tests};\
| | | > | | | | 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 |
DDE_LIB_FILE = @LIBPREFIX@tcldde$(DDEVER)${LIBSUFFIX}
REG_DLL_FILE = tclreg$(REGVER)${DLLSUFFIX}
REG_LIB_FILE = @LIBPREFIX@tclreg$(REGVER)${LIBSUFFIX}
TEST_DLL_FILE = tcltest$(VER)${DLLSUFFIX}
TEST_EXE_FILE = tcltest${EXESUFFIX}
TEST_LIB_FILE = @LIBPREFIX@tcltest$(VER)${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}] Tcltest];\
$(TEST_LOAD_PRMS)
ZLIB_DLL_FILE = zlib1.dll
TOMMATH_DLL_FILE = libtommath.dll
SHARED_LIBRARIES = $(TCL_DLL_FILE) @ZLIB_DLL_FILE@ @TOMMATH_DLL_FILE@
STATIC_LIBRARIES = $(TCL_LIB_FILE)
TCLSH = tclsh$(VER)${EXESUFFIX}
WINE = @WINE@
CAT32 = cat32$(EXEEXT)
MAN2TCL = man2tcl$(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@
@SET_MAKE@
# Setting the VPATH variable to a list of paths will cause the Makefile to
# look into these paths when resolving .c to .obj dependencies.
VPATH = $(GENERIC_DIR):$(WIN_DIR):$(COMPAT_DIR):$(ZLIB_DIR):$(TOMMATH_DIR)
AR = @AR@
RANLIB = @RANLIB@
CC = @CC@
RC = @RC@
RES = @RES@
AC_FLAGS = @EXTRA_CFLAGS@ @DEFS@
CPPFLAGS = @CPPFLAGS@
LDFLAGS_DEBUG = @LDFLAGS_DEBUG@
LDFLAGS_OPTIMIZE = @LDFLAGS_OPTIMIZE@
LDFLAGS = @LDFLAGS@ @LDFLAGS_DEFAULT@
LDFLAGS_CONSOLE = @LDFLAGS_CONSOLE@
LDFLAGS_WINDOW = @LDFLAGS_WINDOW@
EXEEXT = @EXEEXT@
OBJEXT = @OBJEXT@
STLIB_LD = @STLIB_LD@
SHLIB_LD = @SHLIB_LD@
SHLIB_LD_LIBS = @SHLIB_LD_LIBS@
SHLIB_CFLAGS = @SHLIB_CFLAGS@
SHLIB_SUFFIX = @SHLIB_SUFFIX@
LIBS = @LIBS@ $(shell $(CYGPATH) '@ZLIB_LIBS@') $(shell $(CYGPATH) '@TOMMATH_LIBS@')
RMDIR = rm -rf
MKDIR = mkdir -p
SHELL = @SHELL@
RM = rm -f
COPY = cp
LN = ln
|
| ︙ | ︙ | |||
245 246 247 248 249 250 251 |
uncompr.$(HOST_OBJEXT) \
zip.$(HOST_OBJEXT) \
zutil.$(HOST_OBJEXT) \
minizip.$(HOST_OBJEXT)
ZIP_INSTALL_OBJS = @ZIP_INSTALL_OBJS@
| | | | | | 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 |
uncompr.$(HOST_OBJEXT) \
zip.$(HOST_OBJEXT) \
zutil.$(HOST_OBJEXT) \
minizip.$(HOST_OBJEXT)
ZIP_INSTALL_OBJS = @ZIP_INSTALL_OBJS@
CC_SWITCHES = -I"${GENERIC_DIR_NATIVE}" -I"${TOMMATH_DIR_NATIVE}" \
-I"${ZLIB_DIR_NATIVE}" -I"${WIN_DIR_NATIVE}" \
${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} -DMP_PREC=4 \
${AC_FLAGS} ${COMPILE_DEBUG_FLAGS} ${NO_DEPRECATED_FLAGS}
CC_OBJNAME = @CC_OBJNAME@
CC_EXENAME = @CC_EXENAME@
STUB_CC_SWITCHES = ${CFLAGS} ${CFLAGS_WARNING} ${SHLIB_CFLAGS} \
-I"${GENERIC_DIR_NATIVE}" -I"${TOMMATH_DIR_NATIVE}" \
-I"${WIN_DIR_NATIVE}" ${AC_FLAGS} \
${COMPILE_DEBUG_FLAGS}
TCLTEST_OBJS = \
tclTest.$(OBJEXT) \
tclTestObj.$(OBJEXT) \
tclTestProcBodyObj.$(OBJEXT) \
|
| ︙ | ︙ | |||
312 313 314 315 316 317 318 | tclIORTrans.$(OBJEXT) \ tclIOSock.$(OBJEXT) \ tclIOUtil.$(OBJEXT) \ tclLink.$(OBJEXT) \ tclLiteral.$(OBJEXT) \ tclListObj.$(OBJEXT) \ tclLoad.$(OBJEXT) \ | | | | 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 | tclIORTrans.$(OBJEXT) \ tclIOSock.$(OBJEXT) \ tclIOUtil.$(OBJEXT) \ tclLink.$(OBJEXT) \ tclLiteral.$(OBJEXT) \ tclListObj.$(OBJEXT) \ tclLoad.$(OBJEXT) \ tclMainW.$(OBJEXT) \ tclMain.$(OBJEXT) \ tclNamesp.$(OBJEXT) \ tclNotify.$(OBJEXT) \ tclOO.$(OBJEXT) \ tclOOBasic.$(OBJEXT) \ tclOOCall.$(OBJEXT) \ tclOODefineCmds.$(OBJEXT) \ tclOOInfo.$(OBJEXT) \ |
| ︙ | ︙ | |||
356 357 358 359 360 361 362 | tclUtf.$(OBJEXT) \ tclUtil.$(OBJEXT) \ tclVar.$(OBJEXT) \ tclZipfs.$(OBJEXT) \ tclZlib.$(OBJEXT) TOMMATH_OBJS = \ | < < < < < < | | < > < | < | | < < | < | < < | > > > > > > | > > | 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 |
tclUtf.$(OBJEXT) \
tclUtil.$(OBJEXT) \
tclVar.$(OBJEXT) \
tclZipfs.$(OBJEXT) \
tclZlib.$(OBJEXT)
TOMMATH_OBJS = \
bn_mp_add.${OBJEXT} \
bn_mp_add_d.${OBJEXT} \
bn_mp_and.${OBJEXT} \
bn_mp_clamp.${OBJEXT} \
bn_mp_clear.${OBJEXT} \
bn_mp_clear_multi.${OBJEXT} \
bn_mp_cmp.${OBJEXT} \
bn_mp_cmp_d.${OBJEXT} \
bn_mp_cmp_mag.${OBJEXT} \
bn_mp_cnt_lsb.${OBJEXT} \
bn_mp_copy.${OBJEXT} \
bn_mp_count_bits.${OBJEXT} \
bn_mp_div.${OBJEXT} \
bn_mp_div_d.${OBJEXT} \
bn_mp_div_2.${OBJEXT} \
bn_mp_div_2d.${OBJEXT} \
bn_mp_div_3.${OBJEXT} \
bn_mp_exch.${OBJEXT} \
bn_mp_expt_u32.${OBJEXT} \
bn_mp_get_mag_u64.${OBJEXT} \
bn_mp_grow.${OBJEXT} \
bn_mp_init.${OBJEXT} \
bn_mp_init_copy.${OBJEXT} \
bn_mp_init_i64.${OBJEXT} \
bn_mp_init_multi.${OBJEXT} \
bn_mp_init_set.${OBJEXT} \
bn_mp_init_size.${OBJEXT} \
bn_mp_init_u64.${OBJEXT} \
bn_mp_lshd.${OBJEXT} \
bn_mp_mod.${OBJEXT} \
bn_mp_mod_2d.${OBJEXT} \
bn_mp_mul.${OBJEXT} \
bn_mp_mul_2.${OBJEXT} \
bn_mp_mul_2d.${OBJEXT} \
bn_mp_mul_d.${OBJEXT} \
bn_mp_neg.${OBJEXT} \
bn_mp_or.${OBJEXT} \
bn_mp_radix_size.${OBJEXT} \
bn_mp_radix_smap.${OBJEXT} \
bn_mp_read_radix.${OBJEXT} \
bn_mp_rshd.${OBJEXT} \
bn_mp_set_i64.${OBJEXT} \
bn_mp_set_u64.${OBJEXT} \
bn_mp_shrink.${OBJEXT} \
bn_mp_sqr.${OBJEXT} \
bn_mp_sqrt.${OBJEXT} \
bn_mp_sub.${OBJEXT} \
bn_mp_sub_d.${OBJEXT} \
bn_mp_signed_rsh.${OBJEXT} \
bn_mp_to_ubin.${OBJEXT} \
bn_mp_to_radix.${OBJEXT} \
bn_mp_ubin_size.${OBJEXT} \
bn_mp_xor.${OBJEXT} \
bn_mp_zero.${OBJEXT} \
bn_s_mp_add.${OBJEXT} \
bn_s_mp_balance_mul.$(OBJEXT) \
bn_s_mp_karatsuba_mul.${OBJEXT} \
bn_s_mp_karatsuba_sqr.$(OBJEXT) \
bn_s_mp_mul_digs.${OBJEXT} \
bn_s_mp_mul_digs_fast.${OBJEXT} \
bn_s_mp_reverse.${OBJEXT} \
bn_s_mp_sqr_fast.${OBJEXT} \
bn_s_mp_sqr.${OBJEXT} \
bn_s_mp_sub.${OBJEXT} \
bn_s_mp_toom_mul.${OBJEXT} \
bn_s_mp_toom_sqr.${OBJEXT}
WIN_OBJS = \
tclWin32Dll.$(OBJEXT) \
tclWinChan.$(OBJEXT) \
tclWinConsole.$(OBJEXT) \
tclWinSerial.$(OBJEXT) \
|
| ︙ | ︙ | |||
470 471 472 473 474 475 476 | inffast.$(OBJEXT) \ inflate.$(OBJEXT) \ inftrees.$(OBJEXT) \ trees.$(OBJEXT) \ uncompr.$(OBJEXT) \ zutil.$(OBJEXT) | | | | | | | | > > | | 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 |
inffast.$(OBJEXT) \
inflate.$(OBJEXT) \
inftrees.$(OBJEXT) \
trees.$(OBJEXT) \
uncompr.$(OBJEXT) \
zutil.$(OBJEXT)
TCL_OBJS = ${GENERIC_OBJS} ${WIN_OBJS} @ZLIB_OBJS@ @TOMMATH_OBJS@
TCL_DOCS = "$(ROOT_DIR_NATIVE)"/doc/*.[13n]
all: binaries libraries doc packages
# Test-suite helper (can be used to test Tcl from build directory with all expected modules).
# To start from windows shell use:
# > tcltest.cmd -verbose bps -file fileName.test
# or from mingw/msys shell:
# $ ./tcltest -verbose bps -file fileName.test
tcltest.cmd: Makefile
@echo 'Create tcltest.cmd helpers';
@(\
echo '@echo off'; \
echo 'rem set LANG=en_US'; \
echo 'set BDP=%~dp0'; \
echo 'set OWD=%CD%'; \
echo 'cd /d %TEMP%'; \
echo 'rem "%BDP%\$(TCLSH)" "$(ROOT_DIR_WIN_NATIVE)/tests/all.tcl" %TESTFLAGS% -load "$(TEST_LOAD_FACILITIES)" %*'; \
echo '"%BDP%\$(TEST_EXE_FILE)" "$(ROOT_DIR_WIN_NATIVE)/tests/all.tcl" %TESTFLAGS% -load "$(TEST_LOAD_PRMS)" %*'; \
echo 'cd /d %OWD%'; \
) > tcltest.cmd;
@(\
echo '#!/bin/sh'; \
echo '#LANG=en_US'; \
echo 'BDP=$$(dirname $$(readlink -f %0))'; \
echo 'cd /tmp'; \
echo '#"$$BDP/$(TCLSH)" "$(ROOT_DIR_WIN_NATIVE)/tests/all.tcl" $$TESTFLAGS -load "$(TEST_LOAD_FACILITIES)" "$$@"'; \
echo '"$$BDP/$(TEST_EXE_FILE)" "$(ROOT_DIR_WIN_NATIVE)/tests/all.tcl" $$TESTFLAGS -load "$(TEST_LOAD_PRMS)" "$$@"'; \
) > tcltest.sh;
tcltest.sh: tcltest.cmd
tcltest: binaries $(TEST_EXE_FILE) $(TEST_DLL_FILE) $(CAT32) tcltest.cmd
binaries: $(TCL_STUB_LIB_FILE) @LIBRARIES@ winextensions ${TCL_ZIP_FILE} $(TCLSH)
winextensions: ${DDE_DLL_FILE} ${REG_DLL_FILE}
libraries:
|
| ︙ | ︙ | |||
544 545 546 547 548 549 550 551 552 553 |
$$zip ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH} >/dev/null && \
echo "${TCL_ZIP_FILE} successful created with $$zip" && \
cd ..)
$(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES)
$(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
@VC_MANIFEST_EMBED_EXE@
cat32.$(OBJEXT): cat.c
| > | | > > > > > > > > > > > > > | > > > > > > | | | | | | | | | | | | | | | | | 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 |
$$zip ${ZIP_PROG_OPTIONS} ../${TCL_ZIP_FILE} ${ZIP_PROG_VFSSEARCH} >/dev/null && \
echo "${TCL_ZIP_FILE} successful created with $$zip" && \
cd ..)
$(TCLSH): $(TCLSH_OBJS) @LIBRARIES@ $(TCL_STUB_LIB_FILE) tclsh.$(RES)
$(CC) $(CFLAGS) $(TCLSH_OBJS) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
$(COPY) tclsh.exe.manifest $(TCLSH).manifest
@VC_MANIFEST_EMBED_EXE@
cat32.$(OBJEXT): cat.c
$(CC) -c $(CC_SWITCHES) -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME)
$(CAT32): cat32.$(OBJEXT)
$(CC) $(CFLAGS) cat32.$(OBJEXT) $(CC_EXENAME) $(LIBS) $(LDFLAGS_CONSOLE)
# The following targets are configured by autoconf to generate either a shared
# library or static library
${TCL_STUB_LIB_FILE}: ${STUB_OBJS}
@$(RM) ${TCL_STUB_LIB_FILE}
@MAKE_STUB_LIB@ ${STUB_OBJS}
@POST_MAKE_LIB@
${TCL_DLL_FILE}: ${TCL_OBJS} tcl.$(RES) @ZLIB_DLL_FILE@ @TOMMATH_DLL_FILE@ ${TCL_ZIP_FILE}
@$(RM) ${TCL_DLL_FILE} $(TCL_LIB_FILE)
@MAKE_DLL@ ${TCL_OBJS} tcl.$(RES) $(SHLIB_LD_LIBS)
$(COPY) tclsh.exe.manifest ${TCL_DLL_FILE}.manifest
@VC_MANIFEST_EMBED_DLL@
@if test "${ZIPFS_BUILD}" = "1" ; then \
cat ${TCL_ZIP_FILE} >> ${TCL_DLL_FILE}; \
${NATIVE_ZIP} -A ${TCL_DLL_FILE} \
|| echo 'ignore zip-error by adjust sfx process (not executable?)'; \
fi
${TCL_LIB_FILE}: ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS}
@$(RM) ${TCL_LIB_FILE}
@MAKE_LIB@ ${TCL_OBJS} ${DDE_OBJS} ${REG_OBJS}
@POST_MAKE_LIB@
${DDE_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${DDE_OBJS}
@MAKE_DLL@ ${DDE_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
$(COPY) tclsh.exe.manifest ${DDE_DLL_FILE}.manifest
${REG_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${REG_OBJS}
@MAKE_DLL@ ${REG_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
$(COPY) tclsh.exe.manifest ${REG_DLL_FILE}.manifest
${TEST_DLL_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS}
@$(RM) ${TEST_DLL_FILE} ${TEST_LIB_FILE}
@MAKE_DLL@ ${TCLTEST_OBJS} $(TCL_STUB_LIB_FILE) $(SHLIB_LD_LIBS)
$(COPY) tclsh.exe.manifest ${TEST_DLL_FILE}.manifest
${TEST_EXE_FILE}: ${TCL_STUB_LIB_FILE} ${TCLTEST_OBJS} tclTestMain.${OBJEXT}
@$(RM) ${TEST_EXE_FILE}
$(CC) $(CFLAGS) $(TCLTEST_OBJS) tclTestMain.$(OBJEXT) $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE) $(LIBS) \
tclsh.$(RES) $(CC_EXENAME) $(LDFLAGS_CONSOLE)
$(COPY) tclsh.exe.manifest ${TEST_EXE_FILE}.manifest
# use pre-built zlib1.dll
${ZLIB_DLL_FILE}: ${TCL_STUB_LIB_FILE}
@if test "@ZLIB_LIBS@set" != "${ZLIB_DIR_NATIVE}/win32/zdll.libset" ; then \
$(COPY) $(ZLIB_DIR)/win64/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \
else \
$(COPY) $(ZLIB_DIR)/win32/${ZLIB_DLL_FILE} ${ZLIB_DLL_FILE}; \
fi;
# use pre-built libtommath.dll
${TOMMATH_DLL_FILE}: ${TCL_STUB_LIB_FILE}
@if test "@TOMMATH_LIBS@set" != "${TOMMATH_DIR_NATIVE}/win32/tommath.libset" ; then \
$(COPY) $(TOMMATH_DIR)/win64/${TOMMATH_DLL_FILE} ${TOMMATH_DLL_FILE}; \
else \
$(COPY) $(TOMMATH_DIR)/win32/${TOMMATH_DLL_FILE} ${TOMMATH_DLL_FILE}; \
fi;
# Add the object extension to the implicit rules. By default .obj is not
# automatically added.
.SUFFIXES: .${OBJEXT}
.SUFFIXES: .$(RES)
.SUFFIXES: .rc
# Special case object targets
tclTestMain.${OBJEXT}: tclAppInit.c
$(CC) -c $(CC_SWITCHES) -DTCL_TEST -DUNICODE -D_UNICODE $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
tclWinInit.${OBJEXT}: tclWinInit.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
tclWinPipe.${OBJEXT}: tclWinPipe.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
tclWinReg.${OBJEXT}: tclWinReg.c
$(CC) -c $(CC_SWITCHES) $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
tclWinDde.${OBJEXT}: tclWinDde.c
$(CC) -c $(CC_SWITCHES) $(EXTFLAGS) @DEPARG@ $(CC_OBJNAME)
tclAppInit.${OBJEXT}: tclAppInit.c
$(CC) -c $(CC_SWITCHES) $(EXTFLAGS) -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME)
tclMainW.${OBJEXT}: tclMain.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl -DUNICODE -D_UNICODE @DEPARG@ $(CC_OBJNAME)
# TIP #430, ZipFS Support
tclZipfs.${OBJEXT}: $(GENERIC_DIR)/tclZipfs.c
$(CC) -c $(CC_SWITCHES) -DBUILD_tcl \
-DCFG_RUNTIME_PATH="\"$(bindir_native)\"" \
-DCFG_RUNTIME_DLLFILE="\"$(TCL_DLL_FILE)\"" \
-DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \
-DCFG_RUNTIME_LIBDIR="\"$(bindir_native)\"" \
-DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY_NATIVE)\"" \
$(ZLIB_INCLUDE) -I$(MINIZIP_DIR_NATIVE) @DEPARG@ $(CC_OBJNAME)
# TIP #59, embedding of configuration information into the binary library.
#
# Part of Tcl's configuration information are the paths where it was installed
# and where it will look for its libraries (which can be different). We derive
# this information from the variables which can be overridden by the user. As
# every path can be configured separately we do not remember one general
# prefix/exec_prefix but all the different paths individually.
tclPkgConfig.${OBJEXT}: tclPkgConfig.c
$(CC) -c $(CC_SWITCHES) \
-DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR_NATIVE)\"" \
-DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR_NATIVE)\"" \
-DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR_NATIVE)\"" \
-DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR_NATIVE)\"" \
-DCFG_INSTALL_DOCDIR="\"$(MAN_INSTALL_DIR_NATIVE)\"" \
\
-DCFG_RUNTIME_LIBDIR="\"$(libdir_native)\"" \
-DCFG_RUNTIME_BINDIR="\"$(bindir_native)\"" \
-DCFG_RUNTIME_SCRDIR="\"$(TCL_LIBRARY_NATIVE)\"" \
-DCFG_RUNTIME_INCDIR="\"$(includedir_native)\"" \
-DCFG_RUNTIME_DOCDIR="\"$(mandir_native)\"" \
-DCFG_RUNTIME_DLLFILE="\"$(TCL_DLL_FILE)\"" \
-DCFG_RUNTIME_ZIPFILE="\"$(TCL_ZIP_FILE)\"" \
-DBUILD_tcl \
@DEPARG@ $(CC_OBJNAME)
# The following objects are part of the stub library and should not be built
# as DLL objects but none of the symbols should be exported
|
| ︙ | ︙ | |||
700 701 702 703 704 705 706 | crc32.$(HOST_OBJEXT): $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/crc32.c deflate.$(HOST_OBJEXT): $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/deflate.c ioapi.$(HOST_OBJEXT): | | | 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 | crc32.$(HOST_OBJEXT): $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/crc32.c deflate.$(HOST_OBJEXT): $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/deflate.c ioapi.$(HOST_OBJEXT): $(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/ioapi.c iowin32.$(HOST_OBJEXT): $(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/iowin32.c infback.$(HOST_OBJEXT): $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/infback.c |
| ︙ | ︙ | |||
730 731 732 733 734 735 736 | zip.$(HOST_OBJEXT): $(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/zip.c zutil.$(HOST_OBJEXT): $(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/zutil.c minizip.$(HOST_OBJEXT): | | < < < < < < < < | | | | | | | | | | | | | | | | | | > > > > > > > > | | | | > > > > > | | | | | | | | | | | | | | > | 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 |
zip.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/zip.c
zutil.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -c $(ZLIB_DIR)/zutil.c
minizip.$(HOST_OBJEXT):
$(HOST_CC) -o $@ -I$(ZLIB_DIR) -I$(ZLIB_DIR)/contrib/minizip -c $(ZLIB_DIR)/contrib/minizip/minizip.c
minizip${HOST_EXEEXT}: $(MINIZIP_OBJS)
$(HOST_CC) -o $@ $(MINIZIP_OBJS)
# The following target generates the file generic/tclDate.c from the yacc
# grammar found in generic/tclGetDate.y. This is only run by hand as yacc is
# not available in all environments. The name of the .c file is different than
# the name of the .y file so that make doesn't try to automatically regenerate
# the .c file.
gendate:
bison --output-file=$(GENERIC_DIR)/tclDate.c \
--name-prefix=TclDate \
--no-lines \
$(GENERIC_DIR)/tclGetDate.y
INSTALL_BASE_TARGETS = install-binaries $(INSTALL_LIBRARIES) $(INSTALL_MSGS) $(INSTALL_TZDATA)
INSTALL_DOC_TARGETS = install-doc
INSTALL_PACKAGE_TARGETS = install-packages
INSTALL_DEV_TARGETS = install-headers
INSTALL_EXTRA_TARGETS =
INSTALL_TARGETS = $(INSTALL_BASE_TARGETS) $(INSTALL_DOC_TARGETS) $(INSTALL_DEV_TARGETS) \
$(INSTALL_PACKAGE_TARGETS) $(INSTALL_EXTRA_TARGETS)
install: $(INSTALL_TARGETS)
install-binaries: binaries
@for i in "$(LIB_INSTALL_DIR)" "$(BIN_INSTALL_DIR)"; \
do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(MKDIR) "$$i"; \
chmod 755 "$$i"; \
else true; \
fi; \
done;
@for i in dde${DDEDOTVER} reg${REGDOTVER}; \
do \
if [ ! -d "$(LIB_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(LIB_INSTALL_DIR)/$$i"; \
$(MKDIR) "$(LIB_INSTALL_DIR)/$$i"; \
else true; \
fi; \
done;
@for i in $(TCL_DLL_FILE) $(ZLIB_DLL_FILE) $(TOMMATH_DLL_FILE) $(TCLSH); \
do \
if [ -f $$i ]; then \
echo "Installing $$i to $(BIN_INSTALL_DIR)/"; \
$(COPY) $$i "$(BIN_INSTALL_DIR)"; \
fi; \
done
@for i in tclConfig.sh tclooConfig.sh $(TCL_LIB_FILE) $(TCL_STUB_LIB_FILE); \
do \
if [ -f $$i ]; then \
echo "Installing $$i to $(LIB_INSTALL_DIR)/"; \
$(COPY) $$i "$(LIB_INSTALL_DIR)"; \
fi; \
done
@if [ -f $(DDE_DLL_FILE) ]; then \
echo Installing $(DDE_DLL_FILE); \
$(COPY) $(DDE_DLL_FILE) "$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \
$(COPY) $(ROOT_DIR)/library/dde/pkgIndex.tcl \
"$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \
fi
@if [ -f $(DDE_LIB_FILE) ]; then \
echo Installing $(DDE_LIB_FILE); \
$(COPY) $(DDE_LIB_FILE) "$(LIB_INSTALL_DIR)/dde${DDEDOTVER}"; \
fi
@if [ -f $(REG_DLL_FILE) ]; then \
echo Installing $(REG_DLL_FILE); \
$(COPY) $(REG_DLL_FILE) "$(LIB_INSTALL_DIR)/reg${REGDOTVER}"; \
$(COPY) $(ROOT_DIR)/library/reg/pkgIndex.tcl \
"$(LIB_INSTALL_DIR)/reg${REGDOTVER}"; \
fi
@if [ -f $(REG_LIB_FILE) ]; then \
echo Installing $(REG_LIB_FILE); \
$(COPY) $(REG_LIB_FILE) "$(LIB_INSTALL_DIR)/reg${REGDOTVER}"; \
fi
install-libraries-zipfs-shared: libraries
install-libraries-zipfs-static: install-libraries-zipfs-shared
$(COPY) ${TCL_ZIP_FILE} "$(LIB_INSTALL_DIR)"
install-libraries: libraries install-tzdata install-msgs
@for i in "$(prefix)/lib" "$(INCLUDE_INSTALL_DIR)" \
"$(SCRIPT_INSTALL_DIR)" "$(MODULE_INSTALL_DIR)"; \
do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(MKDIR) "$$i"; \
else true; \
fi; \
done;
@for i in opt0.4 cookiejar0.2 encoding; \
do \
if [ ! -d "$(SCRIPT_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
$(MKDIR) "$(SCRIPT_INSTALL_DIR)/$$i"; \
else true; \
fi; \
done;
@for i in 8.4 8.4/platform 8.5 8.6 8.7; \
do \
if [ ! -d "$(MODULE_INSTALL_DIR)/$$i" ] ; then \
echo "Making directory $(MODULE_INSTALL_DIR)/$$i"; \
$(MKDIR) "$(MODULE_INSTALL_DIR)/$$i"; \
else true; \
fi; \
done;
@echo "Installing library files to $(SCRIPT_INSTALL_DIR)";
@for i in $(ROOT_DIR)/library/*.tcl $(ROOT_DIR)/library/tclIndex; \
do \
$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \
done;
@echo "Installing package cookiejar 0.2"
@for j in $(ROOT_DIR)/library/cookiejar/*.{tcl,txt.gz}; \
do \
$(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/cookiejar0.2"; \
done;
@echo "Installing package http 2.9.2 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/http/http.tcl "$(MODULE_INSTALL_DIR)/8.6/http-2.9.2.tm";
@echo "Installing package opt 0.4.7";
@for j in $(ROOT_DIR)/library/opt/*.tcl; \
do \
$(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
done;
@echo "Installing package msgcat 1.7.1 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl "$(MODULE_INSTALL_DIR)/8.7/msgcat-1.7.1.tm";
@echo "Installing package tcltest 2.5.3 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl "$(MODULE_INSTALL_DIR)/8.5/tcltest-2.5.3.tm";
@echo "Installing package platform 1.0.14 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/platform/platform.tcl "$(MODULE_INSTALL_DIR)/8.4/platform-1.0.14.tm";
@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/platform/shell.tcl "$(MODULE_INSTALL_DIR)/8.4/platform/shell-1.1.4.tm";
@echo "Installing encodings";
@for i in $(ROOT_DIR)/library/encoding/*.enc; do \
$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)/encoding"; \
done;
install-tzdata:
@echo "Installing time zone data"
@$(TCL_EXE) "$(ROOT_DIR)/tools/installData.tcl" \
"$(ROOT_DIR)/library/tzdata" "$(SCRIPT_INSTALL_DIR_NATIVE)/tzdata"
install-msgs:
@echo "Installing message catalogs"
$(TCL_EXE) "$(ROOT_DIR)/tools/installData.tcl" \
"$(ROOT_DIR)/library/msgs" "$(SCRIPT_INSTALL_DIR_NATIVE)/msgs"
install-doc: doc
install-headers:
@for i in "$(INCLUDE_INSTALL_DIR)"; \
do \
if [ ! -d "$$i" ] ; then \
echo "Making directory $$i"; \
$(MKDIR) "$$i"; \
chmod 755 "$$i"; \
else true; \
fi; \
done;
@echo "Installing header files to $(INCLUDE_INSTALL_DIR)/";
@for i in $(GENERIC_DIR)/tcl.h $(GENERIC_DIR)/tclDecls.h \
$(GENERIC_DIR)/tclOO.h $(GENERIC_DIR)/tclOODecls.h \
$(GENERIC_DIR)/tclPlatDecls.h \
$(GENERIC_DIR)/tclTomMath.h \
$(GENERIC_DIR)/tclTomMathDecls.h \
$(TOMMATH_DIR)/tommath.h ; \
do \
$(COPY) $$i "$(INCLUDE_INSTALL_DIR)"; \
done;
# Optional target to install private headers
install-private-headers: libraries
@for i in $(PRIVATE_INCLUDE_INSTALL_DIR); \
|
| ︙ | ︙ | |||
923 924 925 926 927 928 929 | # Specifying TESTFLAGS on the command line is the standard way to pass args to # tcltest, i.e.: # % make test TESTFLAGS="-verbose bps -file fileName.test" test: test-tcl test-packages | | | | | 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 | # Specifying TESTFLAGS on the command line is the standard way to pass args to # tcltest, i.e.: # % make test TESTFLAGS="-verbose bps -file fileName.test" test: test-tcl test-packages test-tcl: tcltest TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ $(WINE) ./$(TCLSH) "$(ROOT_DIR_NATIVE)/tests/all.tcl" $(TESTFLAGS) \ -load "$(TEST_LOAD_FACILITIES)" # Useful target to launch a built tclsh with the proper path,... runtest: tcltest @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ $(WINE) ./$(TCLSH) $(TESTFLAGS) -load "$(TEST_LOAD_FACILITIES)" $(SCRIPT) # This target can be used to run tclsh from the build directory via # `make shell SCRIPT=foo.tcl` shell: binaries @TCL_LIBRARY="$(LIBRARY_DIR)"; export TCL_LIBRARY; \ |
| ︙ | ︙ | |||
955 956 957 958 959 960 961 |
./config.status
cleanhelp:
$(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe
clean: cleanhelp clean-packages
$(RM) *.lib *.a *.exp *.dll *.$(RES) *.${OBJEXT} *~ \#* TAGS a.out
| | | 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 |
./config.status
cleanhelp:
$(RM) *.hlp *.cnt *.GID *.rtf man2tcl.exe
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 \
|
| ︙ | ︙ | |||
1066 1067 1068 1069 1070 1071 1072 | $(TCL_EXE) "$(ROOT_DIR_NATIVE)/tools/genStubs.tcl" \ "$(GENERIC_DIR_NATIVE)" \ "$(GENERIC_DIR_NATIVE)/tclOO.decls" # # This target creates the HTML folder for Tcl & Tk and places it in # DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool | | | 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 | $(TCL_EXE) "$(ROOT_DIR_NATIVE)/tools/genStubs.tcl" \ "$(GENERIC_DIR_NATIVE)" \ "$(GENERIC_DIR_NATIVE)/tclOO.decls" # # This target creates the HTML folder for Tcl & Tk and places it in # DISTDIR/html. It uses the tcltk-man2html.tcl tool from the Tcl group's tool # workspace. It depends on the Tcl & Tk being in directories called tcl8.* & # tk8.* up two directories from the TOOL_DIR. # TOOL_DIR=$(ROOT_DIR)/tools HTML_INSTALL_DIR=$(ROOT_DIR)/html html: $(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS)" |
| ︙ | ︙ |
Changes to win/README.
|
| | | | 1 2 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 8.7 for Windows 1. Introduction --------------- This is the directory where you configure and compile the Windows version of Tcl. This directory also contains source files for Tcl that are specific to Microsoft Windows. The information in this file is maintained on the web at: http://www.tcl.tk/doc/howto/compile.html#win 2. Compiling Tcl ---------------- In order to compile Tcl for Windows, you need the following: Tcl 8.7 Source Distribution (plus any patches) and Visual C++ 6 or newer or |
| ︙ | ︙ | |||
75 76 77 78 79 80 81 | and Msys, you can download a suitable win32 or win64 compiler from [https://sourceforge.net/projects/mingw-w64/files/] Use the Makefile "install" target to install Tcl. It will install it according to the prefix options you provided in the correct directory structure. | | | | | 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 | and Msys, you can download a suitable win32 or win64 compiler from [https://sourceforge.net/projects/mingw-w64/files/] Use the Makefile "install" target to install Tcl. It will install it according to the prefix options you provided in the correct directory structure. Note that in order to run tclsh87.exe, you must ensure that tcl87.dll is on your path, in the system directory, or in the directory containing tclsh87.exe. Note: Tcl no longer provides support for Win32s. 3. Test suite ------------- This distribution contains an extensive test suite for Tcl. Some of the tests are timing dependent and will fail from time to time. If a test is failing consistently, please send us a bug report with as much detail as you can manage to our tracker: https://core.tcl-lang.org/tcl/reportlist In order to run the test suite, you build the "test" target using the appropriate makefile for your compiler. |
Changes to win/cat.c.
| ︙ | ︙ | |||
24 25 26 27 28 29 30 |
_tmain(void)
{
char buf[1024];
int n;
const char *err;
while (1) {
| | | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 |
_tmain(void)
{
char buf[1024];
int n;
const char *err;
while (1) {
n = _read(0, buf, sizeof(buf));
if (n <= 0) {
break;
}
_write(1, buf, n);
}
err = (sizeof(int) == 2) ? "stderr16" : "stderr32";
_write(2, err, (unsigned int)strlen(err));
return 0;
}
|
Changes to win/configure.
| ︙ | ︙ | |||
706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 | ZIP_INSTALL_OBJS ZIP_PROG_VFSSEARCH ZIP_PROG_OPTIONS ZIP_PROG TCLSH_PROG EXEEXT_FOR_BUILD CC_FOR_BUILD ZLIB_OBJS ZLIB_LIBS ZLIB_DLL_FILE CFLAGS_WARNING CFLAGS_OPTIMIZE CFLAGS_DEBUG DL_LIBS WINE CYGPATH | > > > | 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 | ZIP_INSTALL_OBJS ZIP_PROG_VFSSEARCH ZIP_PROG_OPTIONS ZIP_PROG TCLSH_PROG EXEEXT_FOR_BUILD CC_FOR_BUILD TOMMATH_OBJS ZLIB_OBJS TOMMATH_LIBS ZLIB_LIBS TOMMATH_DLL_FILE ZLIB_DLL_FILE CFLAGS_WARNING CFLAGS_OPTIMIZE CFLAGS_DEBUG DL_LIBS WINE CYGPATH |
| ︙ | ︙ | |||
774 775 776 777 778 779 780 781 782 783 784 785 786 787 |
SHELL
OBJEXT_FOR_BUILD'
ac_subst_files=''
ac_user_opts='
enable_option_checking
with_encoding
enable_shared
enable_64bit
enable_zipfs
enable_symbols
enable_embedded_manifest
'
ac_precious_vars='build_alias
host_alias
| > | 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 |
SHELL
OBJEXT_FOR_BUILD'
ac_subst_files=''
ac_user_opts='
enable_option_checking
with_encoding
enable_shared
enable_time64bit
enable_64bit
enable_zipfs
enable_symbols
enable_embedded_manifest
'
ac_precious_vars='build_alias
host_alias
|
| ︙ | ︙ | |||
1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 |
cat <<\_ACEOF
Optional Features:
--disable-option-checking ignore unrecognized --enable/--with options
--disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no)
--enable-FEATURE[=ARG] include FEATURE [ARG=yes]
--enable-shared build and link with shared libraries (default: on)
--enable-64bit enable 64bit support (where applicable)
--enable-zipfs build with Zipfs support (default: on)
--enable-symbols build with debugging symbols (default: off)
--enable-embedded-manifest
embed manifest if possible (default: yes)
Optional Packages:
| > | 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 |
cat <<\_ACEOF
Optional Features:
--disable-option-checking ignore unrecognized --enable/--with options
--disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no)
--enable-FEATURE[=ARG] include FEATURE [ARG=yes]
--enable-shared build and link with shared libraries (default: on)
--enable-time64bit force 64-bit time_t for 32-bit build (default: off)
--enable-64bit enable 64bit support (where applicable)
--enable-zipfs build with Zipfs support (default: on)
--enable-symbols build with debugging symbols (default: off)
--enable-embedded-manifest
embed manifest if possible (default: yes)
Optional Packages:
|
| ︙ | ︙ | |||
1614 1615 1616 1617 1618 1619 1620 |
fi
rm -rf conftest.dSYM conftest_ipa8_conftest.oo
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
as_fn_set_status $ac_retval
} # ac_fn_c_try_run
| | | | > | > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > | | < < < < < < < < < < < < < < < < < < < | < < < < > | | 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 |
fi
rm -rf conftest.dSYM conftest_ipa8_conftest.oo
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
as_fn_set_status $ac_retval
} # ac_fn_c_try_run
# ac_fn_c_check_header_mongrel LINENO HEADER VAR INCLUDES
# -------------------------------------------------------
# Tests whether HEADER exists, giving a warning if it cannot be compiled using
# the include files in INCLUDES and setting the cache variable VAR
# accordingly.
ac_fn_c_check_header_mongrel ()
{
as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack
if eval \${$3+:} false; then :
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
$as_echo_n "checking for $2... " >&6; }
if eval \${$3+:} false; then :
$as_echo_n "(cached) " >&6
fi
eval ac_res=\$$3
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
$as_echo "$ac_res" >&6; }
else
# Is the header compilable?
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 usability" >&5
$as_echo_n "checking $2 usability... " >&6; }
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
$4
#include <$2>
_ACEOF
if ac_fn_c_try_compile "$LINENO"; then :
ac_header_compiler=yes
else
ac_header_compiler=no
fi
rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_compiler" >&5
$as_echo "$ac_header_compiler" >&6; }
# Is the header present?
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking $2 presence" >&5
$as_echo_n "checking $2 presence... " >&6; }
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
/* end confdefs.h. */
#include <$2>
_ACEOF
if ac_fn_c_try_cpp "$LINENO"; then :
ac_header_preproc=yes
else
ac_header_preproc=no
fi
rm -f conftest.err conftest.i conftest.$ac_ext
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_preproc" >&5
$as_echo "$ac_header_preproc" >&6; }
# So? What about this header?
case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in #((
yes:no: )
{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&5
$as_echo "$as_me: WARNING: $2: accepted by the compiler, rejected by the preprocessor!" >&2;}
{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5
$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;}
;;
no:yes:* )
{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: present but cannot be compiled" >&5
$as_echo "$as_me: WARNING: $2: present but cannot be compiled" >&2;}
{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: check for missing prerequisite headers?" >&5
$as_echo "$as_me: WARNING: $2: check for missing prerequisite headers?" >&2;}
{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: see the Autoconf documentation" >&5
$as_echo "$as_me: WARNING: $2: see the Autoconf documentation" >&2;}
{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&5
$as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;}
{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5
$as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;}
;;
esac
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5
$as_echo_n "checking for $2... " >&6; }
if eval \${$3+:} false; then :
$as_echo_n "(cached) " >&6
else
eval "$3=\$ac_header_compiler"
fi
eval ac_res=\$$3
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5
$as_echo "$ac_res" >&6; }
fi
eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno
} # ac_fn_c_check_header_mongrel
# ac_fn_c_check_header_compile LINENO HEADER VAR INCLUDES
# -------------------------------------------------------
# Tests whether HEADER exists and can be compiled using the include files in
# INCLUDES, setting the cache variable VAR accordingly.
ac_fn_c_check_header_compile ()
{
|
| ︙ | ︙ | |||
2103 2104 2105 2106 2107 2108 2109 | # The following define is needed when building with Cygwin since newer # versions of autoconf incorrectly set SHELL to /bin/bash instead of # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh | | | | | | 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 | # The following define is needed when building with Cygwin since newer # versions of autoconf incorrectly set SHELL to /bin/bash instead of # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh TCL_VERSION=8.7 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=7 TCL_PATCH_LEVEL="a4" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 TCL_DDE_MAJOR_VERSION=1 TCL_DDE_MINOR_VERSION=4 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION |
| ︙ | ︙ | |||
3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 |
SHARED_BUILD=0
$as_echo "#define STATIC_BUILD 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# The statements below define a collection of compile flags. This
# macro depends on the value of SHARED_BUILD, and should be called
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------
| > > > > > > > > > > > > > > > > > > > | 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 |
SHARED_BUILD=0
$as_echo "#define STATIC_BUILD 1" >>confdefs.h
fi
#--------------------------------------------------------------------
# Check whether --enable-time64bit was given.
#--------------------------------------------------------------------
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking force of 64-bit time_t" >&5
$as_echo_n "checking force of 64-bit time_t... " >&6; }
# Check whether --enable-time64bit was given.
if test "${enable_time64bit+set}" = set; then :
enableval=$enable_time64bit; tcl_ok=$enableval
else
tcl_ok=no
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: \"$tcl_ok\"" >&5
$as_echo "\"$tcl_ok\"" >&6; }
if test "$tcl_ok" = "yes"; then
CFLAGS="${CFLAGS} -D_USE_64BIT_TIME_T"
fi
#--------------------------------------------------------------------
# The statements below define a collection of compile flags. This
# macro depends on the value of SHARED_BUILD, and should be called
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------
|
| ︙ | ︙ | |||
3907 3908 3909 3910 3911 3912 3913 |
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cross" >&5
$as_echo "$ac_cv_cross" >&6; }
if test "$ac_cv_cross" = "yes"; then
case "$do64bit" in
amd64|x64|yes)
| | | | 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 |
fi
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_cross" >&5
$as_echo "$ac_cv_cross" >&6; }
if test "$ac_cv_cross" = "yes"; then
case "$do64bit" in
amd64|x64|yes)
CC="x86_64-w64-mingw32-${CC}"
LD="x86_64-w64-mingw32-ld"
AR="x86_64-w64-mingw32-ar"
RANLIB="x86_64-w64-mingw32-ranlib"
RC="x86_64-w64-mingw32-windres"
;;
*)
CC="i686-w64-mingw32-${CC}"
LD="i686-w64-mingw32-ld"
AR="i686-w64-mingw32-ar"
RANLIB="i686-w64-mingw32-ranlib"
RC="i686-w64-mingw32-windres"
;;
esac
fi
|
| ︙ | ︙ | |||
4148 4149 4150 4151 4152 4153 4154 |
LIBFLAGSUFFIX="\${DBGX}"
SHLIB_SUFFIX=.dll
EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
| | > > > > > > > > > | 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 4223 4224 4225 4226 4227 4228 4229 4230 4231 4232 4233 4234 4235 4236 4237 4238 |
LIBFLAGSUFFIX="\${DBGX}"
SHLIB_SUFFIX=.dll
EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
CFLAGS_WARNING="-Wall -Wextra -Wwrite-strings -Wpointer-arith"
LDFLAGS_DEBUG=
LDFLAGS_OPTIMIZE=
case "${CC}" in
*++)
CFLAGS_WARNING="${CFLAGS_WARNING} -Wno-format"
;;
*)
CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -Wdeclaration-after-statement"
;;
esac
# Specify the CC output file names based on the target name
CC_OBJNAME="-o \$@"
CC_EXENAME="-o \$@"
# Specify linker flags depending on the type of app being
# built -- Console vs. Window.
|
| ︙ | ︙ | |||
4246 4247 4248 4249 4250 4251 4252 |
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\$@"
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX="\${DBGX}.dll"
LIBSUFFIX="\${DBGX}.lib"
LIBFLAGSUFFIX="\${DBGX}"
| < < < < < < < < < < < < < < < < < < < < < | < < < < < < < | | | 4320 4321 4322 4323 4324 4325 4326 4327 4328 4329 4330 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 4346 4347 4348 4349 4350 4351 4352 4353 4354 4355 4356 4357 4358 4359 4360 4361 4362 4363 |
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\$@"
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX="\${DBGX}.dll"
LIBSUFFIX="\${DBGX}.lib"
LIBFLAGSUFFIX="\${DBGX}"
if test "$do64bit" != "no" ; then
case "$do64bit" in
amd64|x64|yes)
MACHINE="AMD64" ; # assume AMD64 as default 64-bit build
;;
ia64)
MACHINE="IA64"
;;
esac
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: Using 64-bit $MACHINE mode" >&5
$as_echo " Using 64-bit $MACHINE mode" >&6; }
fi
LIBS="netapi32.lib kernel32.lib user32.lib advapi32.lib userenv.lib ws2_32.lib"
case "x`echo \${VisualStudioVersion}`" in
x1[4-9]*)
LIBS="$LIBS ucrt.lib"
;;
*)
;;
esac
if test "$do64bit" != "no" ; then
RC="rc"
CFLAGS_DEBUG="-nologo -Zi -Od ${runtime}d"
# Do not use -O2 for Win64 - this has proved buggy in code gen.
CFLAGS_OPTIMIZE="-nologo -O1 ${runtime}"
lflags="${lflags} -nologo -MACHINE:${MACHINE}"
LINKBIN="link"
# Avoid 'unresolved external symbol __security_cookie' errors.
# c.f. http://support.microsoft.com/?id=894573
LIBS="$LIBS bufferoverflowU.lib"
else
RC="rc"
# -Od - no optimization
# -WX - warnings as errors
|
| ︙ | ︙ | |||
4498 4499 4500 4501 4502 4503 4504 4505 4506 4507 4508 4509 4510 4511 |
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_winnt_ignore_void" >&5
$as_echo "$tcl_cv_winnt_ignore_void" >&6; }
if test "$tcl_cv_winnt_ignore_void" = "yes" ; then
$as_echo "#define HAVE_WINNT_IGNORE_VOID 1" >>confdefs.h
fi
# See if the compiler supports casting to a union type.
# This is used to stop gcc from printing a compiler
# warning when initializing a union member.
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for cast to union support" >&5
$as_echo_n "checking for cast to union support... " >&6; }
| > > > > > > > > > | 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 |
{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $tcl_cv_winnt_ignore_void" >&5
$as_echo "$tcl_cv_winnt_ignore_void" >&6; }
if test "$tcl_cv_winnt_ignore_void" = "yes" ; then
$as_echo "#define HAVE_WINNT_IGNORE_VOID 1" >>confdefs.h
fi
ac_fn_c_check_header_mongrel "$LINENO" "stdbool.h" "ac_cv_header_stdbool_h" "$ac_includes_default"
if test "x$ac_cv_header_stdbool_h" = xyes; then :
$as_echo "#define HAVE_STDBOOL_H 1" >>confdefs.h
fi
# See if the compiler supports casting to a union type.
# This is used to stop gcc from printing a compiler
# warning when initializing a union member.
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for cast to union support" >&5
$as_echo_n "checking for cast to union support... " >&6; }
|
| ︙ | ︙ | |||
4557 4558 4559 4560 4561 4562 4563 |
;;
*)
TCL_EXE="TCL_LIBRARY=\"\${LIBRARY_DIR}\"; export TCL_LIBRARY; ./\${TCLSH}"
;;
esac
#------------------------------------------------------------------------
| | | > > > > > > > > > > > > > > > > > | 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 4644 4645 4646 4647 4648 4649 4650 4651 4652 4653 4654 4655 4656 4657 4658 4659 4660 4661 4662 4663 4664 4665 4666 4667 4668 4669 4670 4671 4672 4673 4674 4675 4676 4677 4678 4679 4680 4681 4682 4683 4684 |
;;
*)
TCL_EXE="TCL_LIBRARY=\"\${LIBRARY_DIR}\"; export TCL_LIBRARY; ./\${TCLSH}"
;;
esac
#------------------------------------------------------------------------
# Add stuff for zlib/libtommath; note that this is mostly done in the
# makefile now as we just assume that the platform hasn't got usable
# z.lib/tommath.lib
#------------------------------------------------------------------------
if test "${enable_shared+set}" = "set"; then :
enableval="$enable_shared"
tcl_ok=$enableval
else
tcl_ok=yes
fi
if test "$tcl_ok" = "yes"; then :
ZLIB_DLL_FILE=\${ZLIB_DLL_FILE}
TOMMATH_DLL_FILE=\${TOMMATH_DLL_FILE}
$as_echo "#define TCL_WITH_EXTERNAL_TOMMATH 1" >>confdefs.h
if test "$do64bit" != "no"; then :
$as_echo "#define MP_64BIT 1" >>confdefs.h
if test "$GCC" == "yes"; then :
ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/libz.dll.a
TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64/libtommath.dll.a
else
ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win64/zdll.lib
TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win64/tommath.lib
fi
else
ZLIB_LIBS=\${ZLIB_DIR_NATIVE}/win32/zdll.lib
TOMMATH_LIBS=\${TOMMATH_DIR_NATIVE}/win32/tommath.lib
fi
else
ZLIB_OBJS=\${ZLIB_OBJS}
TOMMATH_OBJS=\${TOMMATH_OBJS}
fi
$as_echo "#define HAVE_ZLIB 1" >>confdefs.h
|
| ︙ | ︙ | |||
5273 5274 5275 5276 5277 5278 5279 | # The statements below define the symbol TCL_PACKAGE_PATH, which # gives a list of directories that may contain packages. The list # consists of one directory for machine-dependent binaries and # another for platform-independent scripts. #-------------------------------------------------------------------- if test "$prefix/lib" != "$libdir"; then | | | | 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 |
# The statements below define the symbol TCL_PACKAGE_PATH, which
# gives a list of directories that may contain packages. The list
# consists of one directory for machine-dependent binaries and
# another for platform-independent scripts.
#--------------------------------------------------------------------
if test "$prefix/lib" != "$libdir"; then
TCL_PACKAGE_PATH="{${libdir}} {${prefix}/lib}"
else
TCL_PACKAGE_PATH="{${prefix}/lib}"
fi
# The tclsh.exe.manifest requires these
# TCL_WIN_VERSION is the 4 dotted pair Windows version format which needs
# the release level, and must account for interim release versioning
case "$TCL_PATCH_LEVEL" in
*a*) TCL_RELEASE_LEVEL=0 ;;
|
| ︙ | ︙ |
Changes to win/configure.ac.
1 2 3 4 5 6 7 8 9 10 11 12 13 | #! /bin/bash -norc # This file is an input file used by the GNU "autoconf" program to # generate the file "configure", which is run during Tcl installation # to configure the system for the local environment. AC_INIT(../generic/tcl.h) AC_PREREQ(2.69) # The following define is needed when building with Cygwin since newer # versions of autoconf incorrectly set SHELL to /bin/bash instead of # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | #! /bin/bash -norc # This file is an input file used by the GNU "autoconf" program to # generate the file "configure", which is run during Tcl installation # to configure the system for the local environment. AC_INIT(../generic/tcl.h) AC_PREREQ(2.69) # The following define is needed when building with Cygwin since newer # versions of autoconf incorrectly set SHELL to /bin/bash instead of # /bin/sh. The bash shell seems to suffer from some strange failures. SHELL=/bin/sh TCL_VERSION=8.7 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=7 TCL_PATCH_LEVEL="a4" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.4 TCL_DDE_MAJOR_VERSION=1 TCL_DDE_MINOR_VERSION=4 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION |
| ︙ | ︙ | |||
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 |
#--------------------------------------------------------------------
# The statements below define a collection of symbols related to
# building libtcl as a shared library instead of a static library.
#--------------------------------------------------------------------
SC_ENABLE_SHARED
#--------------------------------------------------------------------
# The statements below define a collection of compile flags. This
# macro depends on the value of SHARED_BUILD, and should be called
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------
SC_CONFIG_CFLAGS
# Cross-compiling
case ${host_alias} in
*mingw32*)
TCL_EXE="tclsh"
;;
*)
TCL_EXE="TCL_LIBRARY=\"\${LIBRARY_DIR}\"; export TCL_LIBRARY; ./\${TCLSH}"
;;
esac
#------------------------------------------------------------------------
| > > > > > > > > > > > > > > | | > > > > > > > > | 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 |
#--------------------------------------------------------------------
# The statements below define a collection of symbols related to
# building libtcl as a shared library instead of a static library.
#--------------------------------------------------------------------
SC_ENABLE_SHARED
#--------------------------------------------------------------------
# Check whether --enable-time64bit was given.
#--------------------------------------------------------------------
AC_MSG_CHECKING([force of 64-bit time_t])
AC_ARG_ENABLE(time64bit,
AC_HELP_STRING([--enable-time64bit],
[force 64-bit time_t for 32-bit build (default: off)]),
[tcl_ok=$enableval], [tcl_ok=no])
AC_MSG_RESULT("$tcl_ok")
if test "$tcl_ok" = "yes"; then
CFLAGS="${CFLAGS} -D_USE_64BIT_TIME_T"
fi
#--------------------------------------------------------------------
# The statements below define a collection of compile flags. This
# macro depends on the value of SHARED_BUILD, and should be called
# after SC_ENABLE_SHARED checks the configure switches.
#--------------------------------------------------------------------
SC_CONFIG_CFLAGS
# Cross-compiling
case ${host_alias} in
*mingw32*)
TCL_EXE="tclsh"
;;
*)
TCL_EXE="TCL_LIBRARY=\"\${LIBRARY_DIR}\"; export TCL_LIBRARY; ./\${TCLSH}"
;;
esac
#------------------------------------------------------------------------
# Add stuff for zlib/libtommath; note that this is mostly done in the
# makefile now as we just assume that the platform hasn't got usable
# z.lib/tommath.lib
#------------------------------------------------------------------------
AS_IF([test "${enable_shared+set}" = "set"], [
enableval="$enable_shared"
tcl_ok=$enableval
], [
tcl_ok=yes
])
AS_IF([test "$tcl_ok" = "yes"], [
AC_SUBST(ZLIB_DLL_FILE,[\${ZLIB_DLL_FILE}])
AC_SUBST(TOMMATH_DLL_FILE,[\${TOMMATH_DLL_FILE}])
AC_DEFINE(TCL_WITH_EXTERNAL_TOMMATH, 1, [Tcl with external libtommath])
AS_IF([test "$do64bit" != "no"], [
AC_DEFINE(MP_64BIT, 1, [Using libtommath.dll in 64-bit mode])
AS_IF([test "$GCC" == "yes"],[
AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/libz.dll.a])
AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64/libtommath.dll.a])
], [
AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win64/zdll.lib])
AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win64/tommath.lib])
])
], [
AC_SUBST(ZLIB_LIBS,[\${ZLIB_DIR_NATIVE}/win32/zdll.lib])
AC_SUBST(TOMMATH_LIBS,[\${TOMMATH_DIR_NATIVE}/win32/tommath.lib])
])
], [
AC_SUBST(ZLIB_OBJS,[\${ZLIB_OBJS}])
AC_SUBST(TOMMATH_OBJS,[\${TOMMATH_OBJS}])
])
AC_DEFINE(HAVE_ZLIB, 1, [Is there an installed zlib?])
AC_CHECK_TYPE([intptr_t], [
AC_DEFINE([HAVE_INTPTR_T], 1, [Do we have the intptr_t type?])], [
AC_CACHE_CHECK([for pointer-size signed integer type], tcl_cv_intptr_t, [
for tcl_cv_intptr_t in "int" "long" "long long" none; do
|
| ︙ | ︙ | |||
383 384 385 386 387 388 389 | # The statements below define the symbol TCL_PACKAGE_PATH, which # gives a list of directories that may contain packages. The list # consists of one directory for machine-dependent binaries and # another for platform-independent scripts. #-------------------------------------------------------------------- if test "$prefix/lib" != "$libdir"; then | | | | 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 |
# The statements below define the symbol TCL_PACKAGE_PATH, which
# gives a list of directories that may contain packages. The list
# consists of one directory for machine-dependent binaries and
# another for platform-independent scripts.
#--------------------------------------------------------------------
if test "$prefix/lib" != "$libdir"; then
TCL_PACKAGE_PATH="{${libdir}} {${prefix}/lib}"
else
TCL_PACKAGE_PATH="{${prefix}/lib}"
fi
# The tclsh.exe.manifest requires these
# TCL_WIN_VERSION is the 4 dotted pair Windows version format which needs
# the release level, and must account for interim release versioning
case "$TCL_PATCH_LEVEL" in
*a*) TCL_RELEASE_LEVEL=0 ;;
|
| ︙ | ︙ |
Changes to win/makefile.vc.
| ︙ | ︙ | |||
12 13 14 15 16 17 18 | # Copyright (c) 2003-2008 Pat Thoyts. # Copyright (c) 2017 Ashok P. Nadkarni #------------------------------------------------------------------------------ # General usage: # nmake [-nologo] -f makefile.vc [TARGET|MACRODEF [TARGET|MACRODEF] [...]] # | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # Copyright (c) 2003-2008 Pat Thoyts. # Copyright (c) 2017 Ashok P. Nadkarni #------------------------------------------------------------------------------ # General usage: # nmake [-nologo] -f makefile.vc [TARGET|MACRODEF [TARGET|MACRODEF] [...]] # # For MACRODEF, see TIP 477 (https://core.tcl-lang.org/tips/doc/trunk/tip/477.md) # or examine Sections 6-8 in rules.vc. # # Possible values of TARGET are: # release -- Builds the core, the shell and the dlls. (default) # dlls -- Just builds the windows extensions # shell -- Just builds the shell and the core. # core -- Only builds the core [tclXX.(dll|lib)]. |
| ︙ | ︙ | |||
46 47 48 49 50 51 52 53 54 55 56 57 58 59 | # to start a command shell using one of the short cuts installed by # Visual Studio/Windows SDK for the appropriate target architecture. # # NOTE: For older (Visual C++ 6 or the 2003 SDK), to use the Platform # SDK (not expressly needed), run setenv.bat after # vcvars32.bat according to the instructions for it. This can also # turn on the 64-bit compiler, if your SDK has it. # # 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 | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # to start a command shell using one of the short cuts installed by # Visual Studio/Windows SDK for the appropriate target architecture. # # NOTE: For older (Visual C++ 6 or the 2003 SDK), to use the Platform # SDK (not expressly needed), run setenv.bat after # vcvars32.bat according to the instructions for it. This can also # turn on the 64-bit compiler, if your SDK has it. # # Basic macros and options usable on the commandline (see rules.vc for more info): # OPTS=msvcrt,nothreads,pdbs,profile,static,staticpkg,symbols,thrdalloc,time64bit,unchecked,utfmax,none # Sets special options for the core. The default is for none. # Any combination of the above may be used (comma separated). # 'none' will over-ride everything to nothing. # # msvcrt = Affects the static option only to switch it from # using libcmt(d) as the C runtime [by default] to # msvcrt(d). This is useful for static embedding # support. # nothreads = Turns off full multithreading support (default on). # pbds = Produce separate debug symbol files. # profile = Adds profiling hooks. Map file is assumed. # static = Builds a static library of the core instead of a # dll. The shell will be static (and large), as well. # staticpkg = Affects the static option only to switch # tclshXX.exe to have the dde and reg extension linked # inside it. # symbols = Adds symbols for step debugging. # thrdalloc = Use the thread allocator (shared global free pool). # time64bit = Forces a build using 64-bit time_t for 32-bit build # (CRT library should support this). # unchecked = Allows a symbols build to not use the debug # enabled runtime (msvcrt.dll not msvcrtd.dll # or libcmt.lib not libcmtd.lib). # utfmax = Forces a build allowing 4-byte UTF-8 sequences # internally. # # STATS=compdbg,memdbg,none # Sets optional memory and bytecode compiler debugging code added # to the core. The default is for none. Any combination of the # above may be used (comma separated). 'none' will over-ride # everything to nothing. # # compdbg = Enables byte compilation logging. # memdbg = Enables the debugging memory allocator. # # CHECKS=64bit,fullwarn,nodep,none # Sets special macros for checking compatibility. # # 64bit = Enable 64bit portability warnings (if available) # fullwarn = Builds with full compiler and link warnings enabled. # Very verbose. # nodep = Turns off compatibility macros to ensure the core # isn't being built with deprecated functions. # # MACHINE=(ALPHA|AMD64|IA64|IX86) # Set the machine type used for the compiler, linker, and # resource compiler. This hook is needed to tell the tools # when alternate platforms are requested. IX86 is the default # when not specified. If the CPU environment variable has been # set (ie: recent Platform SDK) then MACHINE is set from CPU. # # TMP_DIR=<path> # OUT_DIR=<path> # Hooks to allow the intermediate and output directories to be # 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. # # CFG_ENCODING=encoding # name of encoding for configuration information. Defaults # to cp1252 # # 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 |
| ︙ | ︙ | |||
85 86 87 88 89 90 91 92 93 94 95 96 97 98 | # We need versions of various core packages to generate appropriate # file names during installation. !if [echo REM = This file is generated from makefile.vc > versions.vc] !endif !if [echo PKG_HTTP_VER = \>> versions.vc] \ && [nmakehlp -V ..\library\http\pkgIndex.tcl http >> versions.vc] !endif !if [echo PKG_TCLTEST_VER = \>> versions.vc] \ && [nmakehlp -V ..\library\tcltest\pkgIndex.tcl tcltest >> versions.vc] !endif !if [echo PKG_MSGCAT_VER = \>> versions.vc] \ && [nmakehlp -V ..\library\msgcat\pkgIndex.tcl msgcat >> versions.vc] !endif !if [echo PKG_PLATFORM_VER = \>> versions.vc] \ | > > > > > > | 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 | # We need versions of various core packages to generate appropriate # file names during installation. !if [echo REM = This file is generated from makefile.vc > versions.vc] !endif !if [echo PKG_HTTP_VER = \>> versions.vc] \ && [nmakehlp -V ..\library\http\pkgIndex.tcl http >> versions.vc] !endif !if [echo PKG_OPT_VER = \>> versions.vc] \ && [nmakehlp -V ..\library\opt\pkgIndex.tcl opt >> versions.vc] !endif !if [echo PKG_COOKIEJAR_VER = \>> versions.vc] \ && [nmakehlp -V ..\library\cookiejar\pkgIndex.tcl cookiejar >> versions.vc] !endif !if [echo PKG_TCLTEST_VER = \>> versions.vc] \ && [nmakehlp -V ..\library\tcltest\pkgIndex.tcl tcltest >> versions.vc] !endif !if [echo PKG_MSGCAT_VER = \>> versions.vc] \ && [nmakehlp -V ..\library\msgcat\pkgIndex.tcl msgcat >> versions.vc] !endif !if [echo PKG_PLATFORM_VER = \>> versions.vc] \ |
| ︙ | ︙ | |||
141 142 143 144 145 146 147 148 149 150 151 152 153 154 | $(TMP_DIR)\tclThreadTest.obj \ $(TMP_DIR)\tclWinTest.obj \ !if !$(STATIC_BUILD) !if $(TCL_USE_STATIC_PACKAGES) $(TMP_DIR)\tclWinReg.obj \ $(TMP_DIR)\tclWinDde.obj \ !endif !endif $(TMP_DIR)\testMain.obj COREOBJS = \ $(TMP_DIR)\regcomp.obj \ $(TMP_DIR)\regerror.obj \ $(TMP_DIR)\regexec.obj \ | > | 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 | $(TMP_DIR)\tclThreadTest.obj \ $(TMP_DIR)\tclWinTest.obj \ !if !$(STATIC_BUILD) !if $(TCL_USE_STATIC_PACKAGES) $(TMP_DIR)\tclWinReg.obj \ $(TMP_DIR)\tclWinDde.obj \ !endif $(OUT_DIR)\tommath.lib \ !endif $(TMP_DIR)\testMain.obj COREOBJS = \ $(TMP_DIR)\regcomp.obj \ $(TMP_DIR)\regerror.obj \ $(TMP_DIR)\regexec.obj \ |
| ︙ | ︙ | |||
191 192 193 194 195 196 197 | $(TMP_DIR)\tclIOUtil.obj \ $(TMP_DIR)\tclIORChan.obj \ $(TMP_DIR)\tclIORTrans.obj \ $(TMP_DIR)\tclLink.obj \ $(TMP_DIR)\tclListObj.obj \ $(TMP_DIR)\tclLiteral.obj \ $(TMP_DIR)\tclLoad.obj \ | | | | 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 | $(TMP_DIR)\tclIOUtil.obj \ $(TMP_DIR)\tclIORChan.obj \ $(TMP_DIR)\tclIORTrans.obj \ $(TMP_DIR)\tclLink.obj \ $(TMP_DIR)\tclListObj.obj \ $(TMP_DIR)\tclLiteral.obj \ $(TMP_DIR)\tclLoad.obj \ $(TMP_DIR)\tclMainW.obj \ $(TMP_DIR)\tclMain.obj \ $(TMP_DIR)\tclNamesp.obj \ $(TMP_DIR)\tclNotify.obj \ $(TMP_DIR)\tclOO.obj \ $(TMP_DIR)\tclOOBasic.obj \ $(TMP_DIR)\tclOOCall.obj \ $(TMP_DIR)\tclOODefineCmds.obj \ $(TMP_DIR)\tclOOInfo.obj \ |
| ︙ | ︙ | |||
234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 | $(TMP_DIR)\tclTrace.obj \ $(TMP_DIR)\tclUtf.obj \ $(TMP_DIR)\tclUtil.obj \ $(TMP_DIR)\tclVar.obj \ $(TMP_DIR)\tclZipfs.obj \ $(TMP_DIR)\tclZlib.obj ZLIBOBJS = \ $(TMP_DIR)\adler32.obj \ $(TMP_DIR)\compress.obj \ $(TMP_DIR)\crc32.obj \ $(TMP_DIR)\deflate.obj \ $(TMP_DIR)\infback.obj \ $(TMP_DIR)\inffast.obj \ $(TMP_DIR)\inflate.obj \ $(TMP_DIR)\inftrees.obj \ $(TMP_DIR)\trees.obj \ $(TMP_DIR)\uncompr.obj \ $(TMP_DIR)\zutil.obj TOMMATHOBJS = \ | > > > > > < < < | < < | < < | | | | < | < < | | < | | < < > > > > > > | > > > > > | 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 | $(TMP_DIR)\tclTrace.obj \ $(TMP_DIR)\tclUtf.obj \ $(TMP_DIR)\tclUtil.obj \ $(TMP_DIR)\tclVar.obj \ $(TMP_DIR)\tclZipfs.obj \ $(TMP_DIR)\tclZlib.obj !if $(STATIC_BUILD) ZLIBOBJS = \ $(TMP_DIR)\adler32.obj \ $(TMP_DIR)\compress.obj \ $(TMP_DIR)\crc32.obj \ $(TMP_DIR)\deflate.obj \ $(TMP_DIR)\infback.obj \ $(TMP_DIR)\inffast.obj \ $(TMP_DIR)\inflate.obj \ $(TMP_DIR)\inftrees.obj \ $(TMP_DIR)\trees.obj \ $(TMP_DIR)\uncompr.obj \ $(TMP_DIR)\zutil.obj !else ZLIBOBJS = $(OUT_DIR)\zdll.lib !endif !if $(STATIC_BUILD) TOMMATHOBJS = \ $(TMP_DIR)\bn_mp_add.obj \ $(TMP_DIR)\bn_mp_add_d.obj \ $(TMP_DIR)\bn_mp_and.obj \ $(TMP_DIR)\bn_mp_clamp.obj \ $(TMP_DIR)\bn_mp_clear.obj \ $(TMP_DIR)\bn_mp_clear_multi.obj \ $(TMP_DIR)\bn_mp_cmp.obj \ $(TMP_DIR)\bn_mp_cmp_d.obj \ $(TMP_DIR)\bn_mp_cmp_mag.obj \ $(TMP_DIR)\bn_mp_cnt_lsb.obj \ $(TMP_DIR)\bn_mp_copy.obj \ $(TMP_DIR)\bn_mp_count_bits.obj \ $(TMP_DIR)\bn_mp_div.obj \ $(TMP_DIR)\bn_mp_div_d.obj \ $(TMP_DIR)\bn_mp_div_2.obj \ $(TMP_DIR)\bn_mp_div_2d.obj \ $(TMP_DIR)\bn_mp_div_3.obj \ $(TMP_DIR)\bn_mp_exch.obj \ $(TMP_DIR)\bn_mp_expt_u32.obj \ $(TMP_DIR)\bn_mp_get_mag_u64.obj \ $(TMP_DIR)\bn_mp_grow.obj \ $(TMP_DIR)\bn_mp_init.obj \ $(TMP_DIR)\bn_mp_init_copy.obj \ $(TMP_DIR)\bn_mp_init_i64.obj \ $(TMP_DIR)\bn_mp_init_multi.obj \ $(TMP_DIR)\bn_mp_init_set.obj \ $(TMP_DIR)\bn_mp_init_size.obj \ $(TMP_DIR)\bn_mp_init_u64.obj \ $(TMP_DIR)\bn_mp_lshd.obj \ $(TMP_DIR)\bn_mp_mod.obj \ $(TMP_DIR)\bn_mp_mod_2d.obj \ $(TMP_DIR)\bn_mp_mul.obj \ $(TMP_DIR)\bn_mp_mul_2.obj \ $(TMP_DIR)\bn_mp_mul_2d.obj \ $(TMP_DIR)\bn_mp_mul_d.obj \ $(TMP_DIR)\bn_mp_neg.obj \ $(TMP_DIR)\bn_mp_or.obj \ $(TMP_DIR)\bn_mp_radix_size.obj \ $(TMP_DIR)\bn_mp_radix_smap.obj \ $(TMP_DIR)\bn_mp_read_radix.obj \ $(TMP_DIR)\bn_mp_rshd.obj \ $(TMP_DIR)\bn_mp_set_i64.obj \ $(TMP_DIR)\bn_mp_set_u64.obj \ $(TMP_DIR)\bn_mp_shrink.obj \ $(TMP_DIR)\bn_mp_sqr.obj \ $(TMP_DIR)\bn_mp_sqrt.obj \ $(TMP_DIR)\bn_mp_sub.obj \ $(TMP_DIR)\bn_mp_sub_d.obj \ $(TMP_DIR)\bn_mp_signed_rsh.obj \ $(TMP_DIR)\bn_mp_to_ubin.obj \ $(TMP_DIR)\bn_mp_to_radix.obj \ $(TMP_DIR)\bn_mp_ubin_size.obj \ $(TMP_DIR)\bn_mp_xor.obj \ $(TMP_DIR)\bn_mp_zero.obj \ $(TMP_DIR)\bn_s_mp_add.obj \ $(TMP_DIR)\bn_s_mp_balance_mul.obj \ $(TMP_DIR)\bn_s_mp_karatsuba_mul.obj \ $(TMP_DIR)\bn_s_mp_karatsuba_sqr.obj \ $(TMP_DIR)\bn_s_mp_mul_digs.obj \ $(TMP_DIR)\bn_s_mp_mul_digs_fast.obj \ $(TMP_DIR)\bn_s_mp_reverse.obj \ $(TMP_DIR)\bn_s_mp_sqr.obj \ $(TMP_DIR)\bn_s_mp_sqr_fast.obj \ $(TMP_DIR)\bn_s_mp_sub.obj \ $(TMP_DIR)\bn_s_mp_toom_sqr.obj \ $(TMP_DIR)\bn_s_mp_toom_mul.obj !else TOMMATHOBJS = $(OUT_DIR)\tommath.lib !endif PLATFORMOBJS = \ $(TMP_DIR)\tclWin32Dll.obj \ $(TMP_DIR)\tclWinChan.obj \ $(TMP_DIR)\tclWinConsole.obj \ $(TMP_DIR)\tclWinError.obj \ $(TMP_DIR)\tclWinFCmd.obj \ |
| ︙ | ︙ | |||
358 359 360 361 362 363 364 | ### the left side of implicit rules. TOMMATHDIR = $(ROOT)\libtommath PKGSDIR = $(ROOT)\pkgs # Additional include and C macro definitions for the implicit rules # defined in rules.vc PRJ_INCLUDES = -I"$(TOMMATHDIR)" | | | | | | 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 | ### the left side of implicit rules. TOMMATHDIR = $(ROOT)\libtommath PKGSDIR = $(ROOT)\pkgs # Additional include and C macro definitions for the implicit rules # defined in rules.vc PRJ_INCLUDES = -I"$(TOMMATHDIR)" PRJ_DEFINES = /DTCL_TOMMATH /DMP_PREC=4 /Dinline=__inline /DHAVE_ZLIB=1 /D_CRT_SECURE_NO_DEPRECATE /D_CRT_NONSTDC_NO_DEPRECATE /DMP_FIXED_CUTOFFS # Additional Link libraries needed beyond those in rules.vc PRJ_LIBS = netapi32.lib user32.lib userenv.lib ws2_32.lib #--------------------------------------------------------------------- # TclTest flags #--------------------------------------------------------------------- !if "$(TESTPAT)" != "" TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT) !endif #--------------------------------------------------------------------- # Project specific targets #--------------------------------------------------------------------- release: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs core: setup $(TCLLIB) $(TCLSTUBLIB) shell: setup $(TCLSH) dlls: setup $(TCLREGLIB) $(TCLDDELIB) $(OUT_DIR)\zlib1.dll $(OUT_DIR)\libtommath.dll all: setup $(TCLSH) $(TCLSTUBLIB) dlls pkgs tcltest: setup $(TCLTEST) dlls install: install-binaries install-libraries install-docs install-pkgs !if $(SYMBOLS) install: install-pdbs !endif setup: default-setup test: test-core test-pkgs test-core: setup $(TCLTEST) dlls set TCL_LIBRARY=$(ROOT:\=/)/library $(DEBUGGER) $(TCLTEST) "$(ROOT:\=/)/tests/all.tcl" $(TESTFLAGS) -loadfile << package ifneeded dde 1.4.3 [list load "$(TCLDDELIB:\=/)" 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 |
| ︙ | ︙ | |||
451 452 453 454 455 456 457 458 459 460 461 462 463 464 | $(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(LIBCMD) $** !else $(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(TCLSTUBLIB) $(DLLCMD) $** $(_VC_MANIFEST_EMBED_DLL) !endif pkgs: @for /d %d in ($(PKGSDIR)\*) do \ @if exist "%~fd\win\makefile.vc" ( \ pushd "%~fd\win" & \ $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) &\ popd \ | > > > > > > > > > > > > > > > > > > > > > | 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 | $(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(LIBCMD) $** !else $(TCLREGLIB): $(TMP_DIR)\tclWinReg.obj $(TCLSTUBLIB) $(DLLCMD) $** $(_VC_MANIFEST_EMBED_DLL) !endif !if "$(MACHINE)" == "AMD64" $(OUT_DIR)\zlib1.dll: $(COMPATDIR)\zlib\win64\zlib1.dll $(COPY) $(COMPATDIR)\zlib\win64\zlib1.dll $(OUT_DIR)\zlib1.dll $(OUT_DIR)\zdll.lib: $(COMPATDIR)\zlib\win64\zdll.lib $(COPY) $(COMPATDIR)\zlib\win64\zdll.lib $(OUT_DIR)\zdll.lib $(OUT_DIR)\libtommath.dll: $(TOMMATHDIR)\win64\libtommath.dll $(COPY) $(TOMMATHDIR)\win64\libtommath.dll $(OUT_DIR)\libtommath.dll $(OUT_DIR)\tommath.lib: $(TOMMATHDIR)\win64\tommath.lib $(COPY) $(TOMMATHDIR)\win64\tommath.lib $(OUT_DIR)\tommath.lib !else $(OUT_DIR)\zlib1.dll: $(COMPATDIR)\zlib\win32\zlib1.dll $(COPY) $(COMPATDIR)\zlib\win32\zlib1.dll $(OUT_DIR)\zlib1.dll $(OUT_DIR)\zdll.lib: $(COMPATDIR)\zlib\win32\zdll.lib $(COPY) $(COMPATDIR)\zlib\win32\zdll.lib $(OUT_DIR)\zdll.lib $(OUT_DIR)\libtommath.dll: $(TOMMATHDIR)\win32\libtommath.dll $(COPY) $(TOMMATHDIR)\win32\libtommath.dll $(OUT_DIR)\libtommath.dll $(OUT_DIR)\tommath.lib: $(TOMMATHDIR)\win32\tommath.lib $(COPY) $(TOMMATHDIR)\win32\tommath.lib $(OUT_DIR)\tommath.lib !endif pkgs: @for /d %d in ($(PKGSDIR)\*) do \ @if exist "%~fd\win\makefile.vc" ( \ pushd "%~fd\win" & \ $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) &\ popd \ |
| ︙ | ︙ | |||
500 501 502 503 504 505 506 | $(GENERICDIR:\=/)/tcl.decls $(GENERICDIR:\=/)/tclInt.decls \ $(GENERICDIR:\=/)/tclTomMath.decls $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \ $(GENERICDIR:\=/)/tclOO.decls !endif | < < < < < < < < < < < < < < < | 598 599 600 601 602 603 604 605 606 607 608 609 610 611 | $(GENERICDIR:\=/)/tcl.decls $(GENERICDIR:\=/)/tclInt.decls \ $(GENERICDIR:\=/)/tclTomMath.decls $(TCLSH) $(TOOLSDIR:\=/)/genStubs.tcl $(GENERICDIR:\=/) \ $(GENERICDIR:\=/)/tclOO.decls !endif #--------------------------------------------------------------------- # Build the Windows HTML help file. #--------------------------------------------------------------------- # NOTE: you can define HHC on the command-line to override this. # nmake does not set macro values if already set on the command line. !if defined(PROCESSOR_ARCHITECTURE) && "$(PROCESSOR_ARCHITECTURE)" == "AMD64" |
| ︙ | ︙ | |||
578 579 580 581 582 583 584 | #--------------------------------------------------------------------- tcl-nmake: $(OUT_DIR)\tcl.nmake $(OUT_DIR)\tcl.nmake: @type << >$@ CORE_MACHINE = $(MACHINE) CORE_DEBUG = $(DEBUG) CORE_USE_THREAD_ALLOC = $(USE_THREAD_ALLOC) | < | | 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 |
#---------------------------------------------------------------------
tcl-nmake: $(OUT_DIR)\tcl.nmake
$(OUT_DIR)\tcl.nmake:
@type << >$@
CORE_MACHINE = $(MACHINE)
CORE_DEBUG = $(DEBUG)
CORE_USE_THREAD_ALLOC = $(USE_THREAD_ALLOC)
<<
#---------------------------------------------------------------------
# Build tclConfig.sh for the TEA build system.
#---------------------------------------------------------------------
tclConfig: $(OUT_DIR)\tclConfig.sh
# TBD - is this tclConfig.sh file ever used? The values are incorrect!
$(OUT_DIR)\tclConfig.sh: $(WIN_DIR)\tclConfig.sh.in
@echo Creating tclConfig.sh
@nmakehlp -s << $** >$@
@TCL_DLL_FILE@ $(TCLLIBNAME)
@TCL_VERSION@ $(DOTVERSION)
@TCL_MAJOR_VERSION@ $(TCL_MAJOR_VERSION)
@TCL_MINOR_VERSION@ $(TCL_MINOR_VERSION)
@TCL_PATCH_LEVEL@ $(TCL_PATCH_LEVEL)
|
| ︙ | ︙ | |||
663 664 665 666 667 668 669 | --name-prefix=TclDate \ $(GENERICDIR)/tclGetDate.y #--------------------------------------------------------------------- # Special case object file targets #--------------------------------------------------------------------- | | | | | | | | | | | | | | | | | | | | | | | < < < | < | < < < | < | | | | | 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 | --name-prefix=TclDate \ $(GENERICDIR)/tclGetDate.y #--------------------------------------------------------------------- # Special case object file targets #--------------------------------------------------------------------- $(TMP_DIR)\testMain.obj: $(WIN_DIR)\tclAppInit.c $(cc32) $(appcflags) /DTCL_TEST /DUNICODE /D_UNICODE \ /DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \ -Fo$@ $? $(TMP_DIR)\tclMainW.obj: $(GENERICDIR)\tclMain.c $(cc32) $(pkgcflags) /DUNICODE /D_UNICODE \ -Fo$@ $? $(TMP_DIR)\tclTest.obj: $(GENERICDIR)\tclTest.c $(cc32) $(appcflags) -Fo$@ $? $(TMP_DIR)\tclTestObj.obj: $(GENERICDIR)\tclTestObj.c $(cc32) $(appcflags) -Fo$@ $? $(TMP_DIR)\tclWinTest.obj: $(WIN_DIR)\tclWinTest.c $(CCAPPCMD) $? $(TMP_DIR)\tclZipfs.obj: $(GENERICDIR)\tclZipfs.c $(cc32) $(pkgcflags) -I$(COMPATDIR)\zlib -I$(COMPATDIR)\zlib\contrib\minizip -Fo$@ $? $(TMP_DIR)\tclZlib.obj: $(GENERICDIR)\tclZlib.c $(cc32) $(pkgcflags) -I$(COMPATDIR)\zlib -Fo$@ $? $(TMP_DIR)\tclPkgConfig.obj: $(GENERICDIR)\tclPkgConfig.c $(cc32) $(pkgcflags) \ /DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ /DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ /DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ /DCFG_INSTALL_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ /DCFG_INSTALL_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ /DCFG_RUNTIME_LIBDIR="\"$(LIB_INSTALL_DIR:\=\\)\"" \ /DCFG_RUNTIME_BINDIR="\"$(BIN_INSTALL_DIR:\=\\)\"" \ /DCFG_RUNTIME_SCRDIR="\"$(SCRIPT_INSTALL_DIR:\=\\)\"" \ /DCFG_RUNTIME_INCDIR="\"$(INCLUDE_INSTALL_DIR:\=\\)\"" \ /DCFG_RUNTIME_DOCDIR="\"$(DOC_INSTALL_DIR:\=\\)\"" \ /DCFG_RUNTIME_DLLFILE="\"$(CFG_RUNTIME_DLLFILE:\=\\)\"" \ /DCFG_RUNTIME_ZIPFILE="\"$(CFG_RUNTIME_ZIPFILE:\=\\)\"" \ -Fo$@ $? $(TMP_DIR)\tclAppInit.obj: $(WIN_DIR)\tclAppInit.c $(cc32) $(appcflags) /DUNICODE /D_UNICODE \ /DTCL_USE_STATIC_PACKAGES=$(TCL_USE_STATIC_PACKAGES) \ -Fo$@ $? ### The following objects should be built using the stub interfaces $(TMP_DIR)\tclWinReg.obj: $(WIN_DIR)\tclWinReg.c $(cc32) $(appcflags) /DUSE_TCL_STUBS -Fo$@ $? $(TMP_DIR)\tclWinDde.obj: $(WIN_DIR)\tclWinDde.c $(cc32) $(appcflags) /DUSE_TCL_STUBS -Fo$@ $? ### The following objects are part of the stub library and should not ### be built as DLL objects. -Zl is used to avoid a dependency on any ### specific C run-time. $(TMP_DIR)\tclStubLib.obj: $(GENERICDIR)\tclStubLib.c $(cc32) $(stubscflags) -Fo$@ $? $(TMP_DIR)\tclTomMathStubLib.obj: $(GENERICDIR)\tclTomMathStubLib.c $(cc32) $(stubscflags) -Fo$@ $? $(TMP_DIR)\tclOOStubLib.obj: $(GENERICDIR)\tclOOStubLib.c $(cc32) $(stubscflags) -Fo$@ $? $(TMP_DIR)\tclWinPanic.obj: $(WIN_DIR)\tclWinPanic.c $(cc32) $(stubscflags) -Fo$@ $? $(TMP_DIR)\tclsh.exe.manifest: $(WIN_DIR)\tclsh.exe.manifest.in @nmakehlp -s << $** >$@ @MACHINE@ $(MACHINE:IX86=X86) @TCL_WIN_VERSION@ $(DOTVERSION).0.0 << #--------------------------------------------------------------------- # Generate the source dependencies. Having dependency rules will # improve incremental build accuracy without having to resort to a # full rebuild just because some non-global header file like # tclCompile.h was changed. These rules aren't needed when building # from scratch. #--------------------------------------------------------------------- depend: !if !exist($(TCLSH)) @echo Build tclsh first! !else $(TCLSH) $(TOOLSDIR:\=/)/mkdepend.tcl -vc32 -out:"$(OUT_DIR)\depend.mk" \ -passthru:"/DBUILD_tcl $(TCL_INCLUDES) $(PRJ_INCLUDES)" $(GENERICDIR),$$(GENERICDIR) \ $(COMPATDIR),$$(COMPATDIR) $(TOMMATHDIR),$$(TOMMATHDIR) $(WIN_DIR),$$(WIN_DIR) @<< $(TCLOBJS) << !endif #--------------------------------------------------------------------- # Dependency rules #--------------------------------------------------------------------- |
| ︙ | ︙ | |||
799 800 801 802 803 804 805 |
<<
{$(COMPATDIR)\zlib}.c{$(TMP_DIR)}.obj::
$(cc32) $(pkgcflags) -Fo$(TMP_DIR)\ @<<
$<
<<
| | > > | | | | | > > | > > > > > > > > > > | < | | | | > > > > > | | | | | | | 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 |
<<
{$(COMPATDIR)\zlib}.c{$(TMP_DIR)}.obj::
$(cc32) $(pkgcflags) -Fo$(TMP_DIR)\ @<<
$<
<<
$(TMP_DIR)\tclsh.res: $(TMP_DIR)\tclsh.exe.manifest $(WIN_DIR)\tclsh.rc
#---------------------------------------------------------------------
# Installation.
#---------------------------------------------------------------------
install-binaries:
@echo Installing to '$(_INSTALLDIR)'
@echo Installing $(TCLLIBNAME)
!if "$(TCLLIB)" != "$(TCLIMPLIB)"
@$(CPY) "$(TCLLIB)" "$(BIN_INSTALL_DIR)\"
!endif
@$(CPY) "$(TCLIMPLIB)" "$(LIB_INSTALL_DIR)\"
@$(CPY) "$(OUT_DIR)\zlib1.dll" "$(BIN_INSTALL_DIR)\"
@$(CPY) "$(OUT_DIR)\libtommath.dll" "$(BIN_INSTALL_DIR)\"
!if exist($(TCLSH))
@echo Installing $(TCLSHNAME)
@$(CPY) "$(TCLSH)" "$(BIN_INSTALL_DIR)\"
!endif
@echo Installing $(TCLSTUBLIBNAME)
@$(CPY) "$(TCLSTUBLIB)" "$(LIB_INSTALL_DIR)\"
install-libraries: tclConfig tcl-nmake install-msgs install-tzdata
@if not exist "$(SCRIPT_INSTALL_DIR)" \
$(MKDIR) "$(SCRIPT_INSTALL_DIR)"
@if not exist "$(SCRIPT_INSTALL_DIR)\opt0.4" \
$(MKDIR) "$(SCRIPT_INSTALL_DIR)\opt0.4"
@if not exist "$(SCRIPT_INSTALL_DIR)\cookiejar0.2" \
$(MKDIR) "$(SCRIPT_INSTALL_DIR)\cookiejar0.2"
@if not exist "$(MODULE_INSTALL_DIR)" \
$(MKDIR) "$(MODULE_INSTALL_DIR)"
@if not exist "$(MODULE_INSTALL_DIR)\8.4" \
$(MKDIR) "$(MODULE_INSTALL_DIR)\8.4"
@if not exist "$(MODULE_INSTALL_DIR)\8.4\platform" \
$(MKDIR) "$(MODULE_INSTALL_DIR)\8.4\platform"
@if not exist "$(MODULE_INSTALL_DIR)\8.5" \
$(MKDIR) "$(MODULE_INSTALL_DIR)\8.5"
@if not exist "$(MODULE_INSTALL_DIR)\8.6" \
$(MKDIR) "$(MODULE_INSTALL_DIR)\8.6"
@if not exist "$(MODULE_INSTALL_DIR)\8.7" \
$(MKDIR) "$(MODULE_INSTALL_DIR)\8.7"
@if not exist "$(LIB_INSTALL_DIR)\nmake" \
$(MKDIR) "$(LIB_INSTALL_DIR)\nmake"
@echo Installing header files
@$(CPY) "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)\"
@$(CPY) "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)\"
@$(CPY) "$(GENERICDIR)\tclOO.h" "$(INCLUDE_INSTALL_DIR)\"
@$(CPY) "$(GENERICDIR)\tclOODecls.h" "$(INCLUDE_INSTALL_DIR)\"
@$(CPY) "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)\"
@$(CPY) "$(GENERICDIR)\tclTomMath.h" "$(INCLUDE_INSTALL_DIR)\"
@$(CPY) "$(GENERICDIR)\tclTomMathDecls.h" "$(INCLUDE_INSTALL_DIR)\"
@$(CPY) "$(TOMMATHDIR)\tommath.h" "$(INCLUDE_INSTALL_DIR)\"
@echo Installing library files to $(SCRIPT_INSTALL_DIR)
@$(CPY) "$(ROOT)\library\history.tcl" "$(SCRIPT_INSTALL_DIR)\"
@$(CPY) "$(ROOT)\library\init.tcl" "$(SCRIPT_INSTALL_DIR)\"
@$(CPY) "$(ROOT)\library\clock.tcl" "$(SCRIPT_INSTALL_DIR)\"
@$(CPY) "$(ROOT)\library\tm.tcl" "$(SCRIPT_INSTALL_DIR)\"
@$(CPY) "$(ROOT)\library\parray.tcl" "$(SCRIPT_INSTALL_DIR)\"
@$(CPY) "$(ROOT)\library\safe.tcl" "$(SCRIPT_INSTALL_DIR)\"
@$(CPY) "$(ROOT)\library\tclIndex" "$(SCRIPT_INSTALL_DIR)\"
@$(CPY) "$(ROOT)\library\package.tcl" "$(SCRIPT_INSTALL_DIR)\"
@$(CPY) "$(ROOT)\library\word.tcl" "$(SCRIPT_INSTALL_DIR)\"
@$(CPY) "$(ROOT)\library\auto.tcl" "$(SCRIPT_INSTALL_DIR)\"
@$(CPY) "$(OUT_DIR)\tclConfig.sh" "$(LIB_INSTALL_DIR)\"
@$(CPY) "$(WIN_DIR)\tclooConfig.sh" "$(LIB_INSTALL_DIR)\"
@$(CPY) "$(WIN_DIR)\rules.vc" "$(LIB_INSTALL_DIR)\nmake\"
@$(CPY) "$(WIN_DIR)\targets.vc" "$(LIB_INSTALL_DIR)\nmake\"
@$(CPY) "$(WIN_DIR)\nmakehlp.c" "$(LIB_INSTALL_DIR)\nmake\"
@$(CPY) "$(OUT_DIR)\tcl.nmake" "$(LIB_INSTALL_DIR)\nmake\"
@echo Installing package cookiejar $(PKG_COOKIEJAR_VER)
@$(CPY) "$(ROOT)\library\cookiejar\*.tcl" \
"$(SCRIPT_INSTALL_DIR)\cookiejar0.2\"
@$(CPY) "$(ROOT)\library\cookiejar\*.gz" \
"$(SCRIPT_INSTALL_DIR)\cookiejar0.2\"
@echo Installing package opt $(PKG_OPT_VER)
@$(CPY) "$(ROOT)\library\opt\*.tcl" \
"$(SCRIPT_INSTALL_DIR)\opt0.4\"
@echo Installing package http $(PKG_HTTP_VER) as a Tcl Module
@$(COPY) "$(ROOT)\library\http\http.tcl" \
"$(MODULE_INSTALL_DIR)\8.6\http-$(PKG_HTTP_VER).tm"
@echo Installing package msgcat $(PKG_MSGCAT_VER) as a Tcl Module
@$(COPY) "$(ROOT)\library\msgcat\msgcat.tcl" \
"$(MODULE_INSTALL_DIR)\8.7\msgcat-$(PKG_MSGCAT_VER).tm"
@echo Installing package tcltest $(PKG_TCLTEST_VER) as a Tcl Module
@$(COPY) "$(ROOT)\library\tcltest\tcltest.tcl" \
"$(MODULE_INSTALL_DIR)\8.5\tcltest-$(PKG_TCLTEST_VER).tm"
@echo Installing package platform $(PKG_PLATFORM_VER) as a Tcl Module
@$(COPY) "$(ROOT)\library\platform\platform.tcl" \
"$(MODULE_INSTALL_DIR)\8.4\platform-$(PKG_PLATFORM_VER).tm"
@echo Installing package platform::shell $(PKG_SHELL_VER) as a Tcl Module
@$(COPY) "$(ROOT)\library\platform\shell.tcl" \
"$(MODULE_INSTALL_DIR)\8.4\platform\shell-$(PKG_SHELL_VER).tm"
@echo Installing $(TCLDDELIBNAME)
!if $(STATIC_BUILD)
!if !$(TCL_USE_STATIC_PACKAGES)
@$(CPY) "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\"
!endif
!else
@$(CPY) "$(TCLDDELIB)" "$(LIB_INSTALL_DIR)\dde$(DDEDOTVERSION)\"
|
| ︙ | ︙ |
Changes to win/nmakehlp.c.
| ︙ | ︙ | |||
639 640 641 642 643 644 645 | *ke = 0, *ve = 0; list_insert(&substPtr, (char*)ks, (char*)vs); } fclose(sp); } /* debug: dump the list */ | | | 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 |
*ke = 0, *ve = 0;
list_insert(&substPtr, (char*)ks, (char*)vs);
}
fclose(sp);
}
/* debug: dump the list */
#ifndef NDEBUG
{
int n = 0;
list_item_t *p = NULL;
for (p = substPtr; p != NULL; p = p->nextPtr, ++n) {
fprintf(stderr, "% 3d '%s' => '%s'\n", n, p->key, p->value);
}
}
|
| ︙ | ︙ |
Changes to win/rules.vc.
1 2 3 4 5 6 7 8 | #------------------------------------------------------------- -*- makefile -*- # rules.vc -- # # Part of the nmake based build system for Tcl and its extensions. # This file does all the hard work in terms of parsing build options, # compiler switches, defining common targets and macros. The Tcl makefile # directly includes this. Extensions include it via "rules-ext.vc". # | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | #------------------------------------------------------------- -*- makefile -*- # rules.vc -- # # Part of the nmake based build system for Tcl and its extensions. # This file does all the hard work in terms of parsing build options, # compiler switches, defining common targets and macros. The Tcl makefile # directly includes this. Extensions include it via "rules-ext.vc". # # See TIP 477 (https://core.tcl-lang.org/tips/doc/trunk/tip/477.md) for # detailed documentation. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # Copyright (c) 2001-2003 David Gravereaux. # Copyright (c) 2003-2008 Patrick Thoyts # Copyright (c) 2017 Ashok P. Nadkarni #------------------------------------------------------------------------------ !ifndef _RULES_VC _RULES_VC = 1 # The following macros define the version of the rules.vc nmake build system # For modifications that are not backward-compatible, you *must* change # the major version. RULES_VERSION_MAJOR = 1 RULES_VERSION_MINOR = 6 # The PROJECT macro must be defined by parent makefile. !if "$(PROJECT)" == "" !error *** Error: Macro PROJECT not defined! Please define it before including rules.vc !endif !if "$(PRJ_PACKAGE_TCLNAME)" == "" |
| ︙ | ︙ | |||
158 159 160 161 162 163 164 | # some Tcl interfaces that are not publicly exposed. # # The fragment will set the following macros: # ROOT - root of this module sources # COMPATDIR - source directory that holds compatibility sources # DOCDIR - source directory containing documentation files # GENERICDIR - platform-independent source directory | | | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 | # some Tcl interfaces that are not publicly exposed. # # The fragment will set the following macros: # ROOT - root of this module sources # COMPATDIR - source directory that holds compatibility sources # DOCDIR - source directory containing documentation files # GENERICDIR - platform-independent source directory # WIN_DIR - Windows-specific source directory # TESTDIR - directory containing test files # TOOLSDIR - directory containing build tools # _TCLDIR - root of the Tcl installation OR the Tcl sources. Not set # when building Tcl itself. # _INSTALLDIR - native form of the installation path. For Tcl # this will be the root of the Tcl installation. For extensions # this will be the lib directory under the root. |
| ︙ | ︙ | |||
211 212 213 214 215 216 217 |
!ifndef DEMODIR
!if exist("$(LIBDIR)\demos")
DEMODIR = $(LIBDIR)\demos
!else
DEMODIR = $(ROOT)\demos
!endif
!endif # ifndef DEMODIR
| | | < < | | | | | 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 |
!ifndef DEMODIR
!if exist("$(LIBDIR)\demos")
DEMODIR = $(LIBDIR)\demos
!else
DEMODIR = $(ROOT)\demos
!endif
!endif # ifndef DEMODIR
# Do NOT use WINDIR because it is Windows internal environment
# variable to point to c:\windows!
WIN_DIR = $(ROOT)\win
!ifndef RCDIR
!if exist("$(WIN_DIR)\rc")
RCDIR = $(WIN_DIR)\rc
!else
RCDIR = $(WIN_DIR)
!endif
!endif
RCDIR = $(RCDIR:/=\)
# The target directory where the built packages and binaries will be installed.
# INSTALLDIR is the (optional) path specified by the user.
# _INSTALLDIR is INSTALLDIR using the backslash separator syntax
|
| ︙ | ︙ | |||
300 301 302 303 304 305 306 | TCLINSTALL = 1 TCLDIR = $(_INSTALLDIR)\.. # NOTE: we will be resetting _INSTALLDIR to _INSTALLDIR/lib for extensions # later so the \.. accounts for the /lib _TCLDIR = $(_INSTALLDIR)\.. _TCL_H = $(_TCLDIR)\include\tcl.h | | | | 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 | TCLINSTALL = 1 TCLDIR = $(_INSTALLDIR)\.. # NOTE: we will be resetting _INSTALLDIR to _INSTALLDIR/lib for extensions # later so the \.. accounts for the /lib _TCLDIR = $(_INSTALLDIR)\.. _TCL_H = $(_TCLDIR)\include\tcl.h !else # exist(...) && !$(NEED_TCL_SOURCE) !if [echo _TCLDIR = \> nmakehlp.out] \ || [nmakehlp -L generic\tcl.h >> nmakehlp.out] !error *** Could not locate Tcl source directory. !endif !include nmakehlp.out TCLINSTALL = 0 TCLDIR = $(_TCLDIR) _TCL_H = $(_TCLDIR)\generic\tcl.h !endif # exist(...) && !$(NEED_TCL_SOURCE) !endif # TCLDIR !ifndef _TCL_H MSG =^ Failed to find tcl.h. The TCLDIR macro is set incorrectly or is not set and default path does not contain tcl.h. !error $(MSG) |
| ︙ | ︙ | |||
535 536 537 538 539 540 541 |
NMAKEHLPC = nmakehlp.c
!if !$(DOING_TCL)
!if $(TCLINSTALL)
!if exist("$(_TCLDIR)\lib\nmake\nmakehlp.c")
NMAKEHLPC = $(_TCLDIR)\lib\nmake\nmakehlp.c
!endif
| | | 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 |
NMAKEHLPC = nmakehlp.c
!if !$(DOING_TCL)
!if $(TCLINSTALL)
!if exist("$(_TCLDIR)\lib\nmake\nmakehlp.c")
NMAKEHLPC = $(_TCLDIR)\lib\nmake\nmakehlp.c
!endif
!else # !$(TCLINSTALL)
!if exist("$(_TCLDIR)\win\nmakehlp.c")
NMAKEHLPC = $(_TCLDIR)\win\nmakehlp.c
!endif
!endif # $(TCLINSTALL)
!endif # !$(DOING_TCL)
!endif # NMAKEHLPC
|
| ︙ | ︙ | |||
682 683 684 685 686 687 688 689 690 691 692 693 694 695 | # USE_THREAD_ALLOC - 1 -> Use a shared global free pool for allocation. # 0 -> Use the non-thread allocator. # UNCHECKED - 1 -> when doing a debug build with symbols, use the release # C runtime, 0 -> use the debug C runtime. # USE_STUBS - 1 -> compile to use stubs interfaces, 0 -> direct linking # CONFIG_CHECK - 1 -> check current build configuration against Tcl # configuration (ignored for Tcl itself) # Further, LINKERFLAGS are modified based on above. # Default values for all the above STATIC_BUILD = 0 TCL_THREADS = 1 DEBUG = 0 SYMBOLS = 0 | > > > > | 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 | # USE_THREAD_ALLOC - 1 -> Use a shared global free pool for allocation. # 0 -> Use the non-thread allocator. # UNCHECKED - 1 -> when doing a debug build with symbols, use the release # C runtime, 0 -> use the debug C runtime. # USE_STUBS - 1 -> compile to use stubs interfaces, 0 -> direct linking # CONFIG_CHECK - 1 -> check current build configuration against Tcl # configuration (ignored for Tcl itself) # _USE_64BIT_TIME_T - forces a build using 64-bit time_t for 32-bit build # (CRT library should support this, not needed for Tcl 9.x) # TCL_UTF_MAX=4 - forces a build allowing 4-byte UTF-8 sequences internally. # (Not needed for Tcl 9.x) # Further, LINKERFLAGS are modified based on above. # Default values for all the above STATIC_BUILD = 0 TCL_THREADS = 1 DEBUG = 0 SYMBOLS = 0 |
| ︙ | ︙ | |||
724 725 726 727 728 729 730 | !if [nmakehlp -f $(OPTS) "nomsvcrt"] !message *** Doing nomsvcrt MSVCRT = 0 !else !if [nmakehlp -f $(OPTS) "msvcrt"] !message *** Doing msvcrt | < | < < | | > > > > > > > > > > > > > > > > | 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 | !if [nmakehlp -f $(OPTS) "nomsvcrt"] !message *** Doing nomsvcrt MSVCRT = 0 !else !if [nmakehlp -f $(OPTS) "msvcrt"] !message *** Doing msvcrt !else !if $(STATIC_BUILD) MSVCRT = 0 !endif !endif !endif # [nmakehlp -f $(OPTS) "nomsvcrt"] !if [nmakehlp -f $(OPTS) "staticpkg"] && $(STATIC_BUILD) !message *** Doing staticpkg TCL_USE_STATIC_PACKAGES = 1 !endif !if [nmakehlp -f $(OPTS) "nothreads"] !message *** Compile explicitly for non-threaded tcl TCL_THREADS = 0 USE_THREAD_ALLOC= 0 !endif !if "$(TCL_MAJOR_VERSION)" == "8" !if [nmakehlp -f $(OPTS) "time64bit"] !message *** Force 64-bit time_t _USE_64BIT_TIME_T = 1 !endif !if [nmakehlp -f $(OPTS) "utfmax"] !message *** Force allowing 4-byte UTF-8 sequences internally TCL_UTF_MAX = 4 !endif !endif # Yes, it's weird that the "symbols" option controls DEBUG and # the "pdbs" option controls SYMBOLS. That's historical. !if [nmakehlp -f $(OPTS) "symbols"] !message *** Doing symbols DEBUG = 1 |
| ︙ | ︙ | |||
777 778 779 780 781 782 783 784 785 786 787 788 789 790 | !else PGO = 0 !endif !if [nmakehlp -f $(OPTS) "loimpact"] !message *** Warning: ignoring option "loimpact" - deprecated on modern Windows. !endif !if [nmakehlp -f $(OPTS) "tclalloc"] USE_THREAD_ALLOC = 0 !endif !if [nmakehlp -f $(OPTS) "unchecked"] !message *** Doing unchecked | > > > > > > | 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 | !else PGO = 0 !endif !if [nmakehlp -f $(OPTS) "loimpact"] !message *** Warning: ignoring option "loimpact" - deprecated on modern Windows. !endif # TBD - should get rid of this option !if [nmakehlp -f $(OPTS) "thrdalloc"] !message *** Doing thrdalloc USE_THREAD_ALLOC = 1 !endif !if [nmakehlp -f $(OPTS) "tclalloc"] USE_THREAD_ALLOC = 0 !endif !if [nmakehlp -f $(OPTS) "unchecked"] !message *** Doing unchecked |
| ︙ | ︙ | |||
960 961 962 963 964 965 966 967 968 969 970 971 972 973 | !endif !endif !include versions.vc !endif # DOTVERSION VERSION = $(DOTVERSION:.=) !endif # $(DOING_TCL) ... etc. ################################################################ # 10. Construct output directory and file paths # Figure-out how to name our intermediate and output directories. # In order to avoid inadvertent mixing of object files built using # different compilers, build configurations etc., # | > > > > > > > > > > > > > | 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 |
!endif
!endif
!include versions.vc
!endif # DOTVERSION
VERSION = $(DOTVERSION:.=)
!endif # $(DOING_TCL) ... etc.
# Windows RC files have 3 version components. Ensure this irrespective
# of how many components the package has specified. Basically, ensure
# minimum 4 components by appending 4 0's and then pick out the first 4.
# Also take care of the fact that DOTVERSION may have "a" or "b" instead
# of "." separating the version components.
DOTSEPARATED=$(DOTVERSION:a=.)
DOTSEPARATED=$(DOTSEPARATED:b=.)
!if [echo RCCOMMAVERSION = \> versions.vc] \
|| [for /f "tokens=1,2,3,4,5* delims=." %a in ("$(DOTSEPARATED).0.0.0.0") do echo %a,%b,%c,%d >> versions.vc]
!error *** Could not generate RCCOMMAVERSION ***
!endif
!include versions.vc
################################################################
# 10. Construct output directory and file paths
# Figure-out how to name our intermediate and output directories.
# In order to avoid inadvertent mixing of object files built using
# different compilers, build configurations etc.,
#
|
| ︙ | ︙ | |||
1067 1068 1069 1070 1071 1072 1073 | TCLSH = $(OUT_DIR)\$(TCLSHNAME) TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) | | | | 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 | TCLSH = $(OUT_DIR)\$(TCLSHNAME) TCLIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib TCLLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) TCLLIB = $(OUT_DIR)\$(TCLLIBNAME) TCLSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib TCLSTUBLIB = $(OUT_DIR)\$(TCLSTUBLIBNAME) TCL_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" !else # !$(DOING_TCL) !if $(TCLINSTALL) # Building against an installed Tcl # When building extensions, we need to locate tclsh. Depending on version # of Tcl we are building against, this may or may not have a "t" suffix. # Try various possibilities in turn. TCLSH = $(_TCLDIR)\bin\tclsh$(TCL_VERSION)$(SUFX:t=).exe |
| ︙ | ︙ | |||
1142 1143 1144 1145 1146 1147 1148 | TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX).lib !if $(DOING_TK) WISH = $(OUT_DIR)\$(WISHNAME) TKSTUBLIB = $(OUT_DIR)\$(TKSTUBLIBNAME) TKIMPLIB = $(OUT_DIR)\$(TKIMPLIBNAME) TKLIB = $(OUT_DIR)\$(TKLIBNAME) | | | 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 | TKIMPLIBNAME = tk$(TK_VERSION)$(SUFX).lib !if $(DOING_TK) WISH = $(OUT_DIR)\$(WISHNAME) TKSTUBLIB = $(OUT_DIR)\$(TKSTUBLIBNAME) TKIMPLIB = $(OUT_DIR)\$(TKIMPLIBNAME) TKLIB = $(OUT_DIR)\$(TKLIBNAME) TK_INCLUDES = -I"$(WIN_DIR)" -I"$(GENERICDIR)" !else # effectively NEED_TK !if $(TKINSTALL) # Building against installed Tk WISH = $(_TKDIR)\bin\$(WISHNAME) TKSTUBLIB = $(_TKDIR)\lib\$(TKSTUBLIBNAME) TKIMPLIB = $(_TKDIR)\lib\$(TKIMPLIBNAME) |
| ︙ | ︙ | |||
1175 1176 1177 1178 1179 1180 1181 | !endif # TKINSTALL tklibs = "$(TKSTUBLIB)" "$(TKIMPLIB)" !endif # $(DOING_TK) !endif # $(DOING_TK) || $(NEED_TK) # Various output paths | | | | 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 | !endif # TKINSTALL tklibs = "$(TKSTUBLIB)" "$(TKIMPLIB)" !endif # $(DOING_TK) !endif # $(DOING_TK) || $(NEED_TK) # Various output paths PRJIMPLIB = $(OUT_DIR)\$(PROJECT)$(VERSION)$(SUFX).lib PRJLIBNAME = $(PROJECT)$(VERSION)$(SUFX).$(EXT) PRJLIB = $(OUT_DIR)\$(PRJLIBNAME) PRJSTUBLIBNAME = $(STUBPREFIX)$(VERSION).lib PRJSTUBLIB = $(OUT_DIR)\$(PRJSTUBLIBNAME) # If extension parent makefile has not defined a resource definition file, # we will generate one from standard template. |
| ︙ | ︙ | |||
1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 | !if $(DOING_TCL) || $(DOING_TK) LIB_INSTALL_DIR = $(_INSTALLDIR)\lib BIN_INSTALL_DIR = $(_INSTALLDIR)\bin DOC_INSTALL_DIR = $(_INSTALLDIR)\doc !if $(DOING_TCL) SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) !else # DOING_TK SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TK_MAJOR_VERSION).$(TK_MINOR_VERSION) !endif DEMO_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)\demos INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include !else # extension other than Tk | > | 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 | !if $(DOING_TCL) || $(DOING_TK) LIB_INSTALL_DIR = $(_INSTALLDIR)\lib BIN_INSTALL_DIR = $(_INSTALLDIR)\bin DOC_INSTALL_DIR = $(_INSTALLDIR)\doc !if $(DOING_TCL) SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TCL_MAJOR_VERSION).$(TCL_MINOR_VERSION) MODULE_INSTALL_DIR = $(_INSTALLDIR)\lib\tcl$(TCL_MAJOR_VERSION) !else # DOING_TK SCRIPT_INSTALL_DIR = $(_INSTALLDIR)\lib\$(PROJECT)$(TK_MAJOR_VERSION).$(TK_MINOR_VERSION) !endif DEMO_INSTALL_DIR = $(SCRIPT_INSTALL_DIR)\demos INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\include !else # extension other than Tk |
| ︙ | ︙ | |||
1253 1254 1255 1256 1257 1258 1259 | # 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 | | > > > > > > > > | | | | | | | > > > > > | | | | | | | | | > > > > > > > > < < < < < < < < < < < < < < < < | | | | | 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 |
# 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 = /DTCL_CFGVAL_ENCODING=$(CFG_ENCODING) /DSTDC_HEADERS
!if $(VCVERSION) >= 1600
OPTDEFINES = $(OPTDEFINES) /DHAVE_STDINT_H=1
!else
OPTDEFINES = $(OPTDEFINES) /DMP_NO_STDINT=1
!endif
!if $(VCVERSION) >= 1800
OPTDEFINES = $(OPTDEFINES) /DHAVE_INTTYPES_H=1 /DHAVE_STDBOOL_H=1
!endif
!if $(TCL_MEM_DEBUG)
OPTDEFINES = $(OPTDEFINES) /DTCL_MEM_DEBUG
!endif
!if $(TCL_COMPILE_DEBUG)
OPTDEFINES = $(OPTDEFINES) /DTCL_COMPILE_DEBUG /DTCL_COMPILE_STATS
!endif
!if $(TCL_THREADS) && $(TCL_VERSION) < 87
OPTDEFINES = $(OPTDEFINES) /DTCL_THREADS=1
!if $(USE_THREAD_ALLOC) && $(TCL_VERSION) < 87
OPTDEFINES = $(OPTDEFINES) /DUSE_THREAD_ALLOC=1
!endif
!endif
!if $(STATIC_BUILD)
OPTDEFINES = $(OPTDEFINES) /DSTATIC_BUILD
!elseif $(TCL_VERSION) > 86
OPTDEFINES = $(OPTDEFINES) /DTCL_WITH_EXTERNAL_TOMMATH
!if "$(MACHINE)" == "AMD64"
OPTDEFINES = $(OPTDEFINES) /DMP_64BIT
!endif
!endif
!if $(TCL_NO_DEPRECATED)
OPTDEFINES = $(OPTDEFINES) /DTCL_NO_DEPRECATED
!endif
!if $(USE_STUBS)
# Note we do not define USE_TCL_STUBS even when building tk since some
# test targets in tk do not use stubs
!if !$(DOING_TCL)
USE_STUBS_DEFS = /DUSE_TCL_STUBS /DUSE_TCLOO_STUBS
!if $(NEED_TK)
USE_STUBS_DEFS = $(USE_STUBS_DEFS) /DUSE_TK_STUBS
!endif
!endif
!endif # USE_STUBS
!if !$(DEBUG)
OPTDEFINES = $(OPTDEFINES) /DNDEBUG
!if $(OPTIMIZING)
OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_OPTIMIZED
!endif
!endif
!if $(PROFILE)
OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_PROFILED
!endif
!if "$(MACHINE)" == "AMD64"
OPTDEFINES = $(OPTDEFINES) /DTCL_CFG_DO64BIT
!endif
!if $(VCVERSION) < 1300
OPTDEFINES = $(OPTDEFINES) /DNO_STRTOI64=1
!endif
!if "$(TCL_MAJOR_VERSION)" == "8"
!if "$(_USE_64BIT_TIME_T)" == "1"
OPTDEFINES = $(OPTDEFINES) /D_USE_64BIT_TIME_T=1
!endif
!if "$(TCL_UTF_MAX)" == "4"
OPTDEFINES = $(OPTDEFINES) /DTCL_UTF_MAX=4
!endif
# _ATL_XP_TARGETING - Newer SDK's need this to build for XP
COMPILERFLAGS = /D_ATL_XP_TARGETING
!endif
# Like the TEA system only set this non empty for non-Tk extensions
# Note: some extensions use PACKAGE_NAME and others use PACKAGE_TCLNAME
# so we pass both
!if !$(DOING_TCL) && !$(DOING_TK)
PKGNAMEFLAGS = /DPACKAGE_NAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \
/DPACKAGE_TCLNAME="\"$(PRJ_PACKAGE_TCLNAME)\"" \
/DPACKAGE_VERSION="\"$(DOTVERSION)\"" \
/DMODULE_SCOPE=extern
!endif
# crt picks the C run time based on selected OPTS
!if $(MSVCRT)
!if $(DEBUG) && !$(UNCHECKED)
crt = -MDd
!else
|
| ︙ | ︙ | |||
1375 1376 1377 1378 1379 1380 1381 | # output increasing chance of a real warning getting lost. So disable them. # Eventually some day, Tcl will be 64-bit clean. cwarn = $(cwarn) -wd4311 -wd4312 !endif ### Common compiler options that are architecture specific !if "$(MACHINE)" == "ARM" | | | < > | | | | | 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 | # output increasing chance of a real warning getting lost. So disable them. # Eventually some day, Tcl will be 64-bit clean. cwarn = $(cwarn) -wd4311 -wd4312 !endif ### Common compiler options that are architecture specific !if "$(MACHINE)" == "ARM" carch = /D_ARM_WINAPI_PARTITION_DESKTOP_SDK_AVAILABLE !else carch = !endif !if $(DEBUG) # Turn warnings into errors cwarn = $(cwarn) -WX !endif INCLUDES = $(TCL_INCLUDES) $(TK_INCLUDES) $(PRJ_INCLUDES) !if !$(DOING_TCL) && !$(DOING_TK) INCLUDES = $(INCLUDES) -I"$(GENERICDIR)" -I"$(WIN_DIR)" -I"$(COMPATDIR)" !endif # These flags are defined roughly in the order of the pre-reform # rules.vc/makefile.vc to help visually compare that the pre- and # post-reform build logs # cflags contains generic flags used for building practically all object files cflags = -nologo -c $(COMPILERFLAGS) $(carch) $(cwarn) -Fp$(TMP_DIR)^\ $(cdebug) # appcflags contains $(cflags) and flags for building the application # object files (e.g. tclsh, or wish) pkgcflags contains $(cflags) plus # flags used for building shared object files The two differ in the # BUILD_$(PROJECT) macro which should be defined only for the shared # library *implementation* and not for its caller interface appcflags_nostubs = $(cflags) $(crt) $(INCLUDES) $(TCL_DEFINES) $(PRJ_DEFINES) $(OPTDEFINES) appcflags = $(appcflags_nostubs) $(USE_STUBS_DEFS) pkgcflags = $(appcflags) $(PKGNAMEFLAGS) /DBUILD_$(PROJECT) pkgcflags_nostubs = $(appcflags_nostubs) $(PKGNAMEFLAGS) /DBUILD_$(PROJECT) # stubscflags contains $(cflags) plus flags used for building a stubs # library for the package. Note: /DSTATIC_BUILD is defined in # $(OPTDEFINES) only if the OPTS configuration indicates a static # library. However the stubs library is ALWAYS static hence included # here irrespective of the OPTS setting. # # TBD - tclvfs has a comment that stubs libs should not be compiled with -GL # without stating why. Tcl itself compiled stubs libs with this flag. # so we do not remove it from cflags. -GL may prevent extensions # compiled with one VC version to fail to link against stubs library # compiled with another VC version. Check for this and fix accordingly. stubscflags = $(cflags) $(PKGNAMEFLAGS) $(PRJ_DEFINES) $(OPTDEFINES) -Zl /DSTATIC_BUILD $(INCLUDES) $(USE_STUBS_DEFS) # Link flags !if $(DEBUG) ldebug = -debug -debugtype:cv !else ldebug = -release -opt:ref -opt:icf,3 |
| ︙ | ︙ | |||
1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 | ### Declarations common to all linker versions lflags = -nologo -machine:$(MACHINE) $(LINKERFLAGS) $(ldebug) !if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900 lflags = $(lflags) -nodefaultlib:libucrt.lib !endif dlllflags = $(lflags) -dll conlflags = $(lflags) -subsystem:console guilflags = $(lflags) -subsystem:windows # Libraries that are required for every image. # Extensions should define any additional libraries with $(PRJ_LIBS) | > > > > > > > > > > > > | 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 | ### Declarations common to all linker versions lflags = -nologo -machine:$(MACHINE) $(LINKERFLAGS) $(ldebug) !if $(MSVCRT) && !($(DEBUG) && !$(UNCHECKED)) && $(VCVERSION) >= 1900 lflags = $(lflags) -nodefaultlib:libucrt.lib !endif # Old linkers (Visual C++ 6 in particular) will link for fast loading # on Win98. Since we do not support Win98 any more, we specify nowin98 # as recommended for NT and later. However, this is only required by # IX86 on older compilers and only needed if we are not doing a static build. !if "$(MACHINE)" == "IX86" && !$(STATIC_BUILD) !if [nmakehlp -l -opt:nowin98 $(LINKER_TESTFLAGS)] # Align sections for PE size savings. lflags = $(lflags) -opt:nowin98 !endif !endif dlllflags = $(lflags) -dll conlflags = $(lflags) -subsystem:console guilflags = $(lflags) -subsystem:windows # Libraries that are required for every image. # Extensions should define any additional libraries with $(PRJ_LIBS) |
| ︙ | ︙ | |||
1484 1485 1486 1487 1488 1489 1490 | LIBCMD = $(lib32) -nologo $(LINKERFLAGS) -out:$@ DLLCMD = $(link32) $(dlllflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) CONEXECMD = $(link32) $(conlflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) GUIEXECMD = $(link32) $(guilflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) RESCMD = $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \ $(TCL_INCLUDES) \ | | | | | | | | | 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 | LIBCMD = $(lib32) -nologo $(LINKERFLAGS) -out:$@ DLLCMD = $(link32) $(dlllflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) CONEXECMD = $(link32) $(conlflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) GUIEXECMD = $(link32) $(guilflags) -out:$@ $(baselibs) $(tcllibs) $(tklibs) RESCMD = $(rc32) -fo $@ -r -i "$(GENERICDIR)" -i "$(TMP_DIR)" \ $(TCL_INCLUDES) \ /DDEBUG=$(DEBUG) -d UNCHECKED=$(UNCHECKED) \ /DCOMMAVERSION=$(RCCOMMAVERSION) \ /DDOTVERSION=\"$(DOTVERSION)\" \ /DVERSION=\"$(VERSION)\" \ /DSUFX=\"$(SUFX)\" \ /DPROJECT=\"$(PROJECT)\" \ /DPRJLIBNAME=\"$(PRJLIBNAME)\" !ifndef DEFAULT_BUILD_TARGET DEFAULT_BUILD_TARGET = $(PROJECT) !endif default-target: $(DEFAULT_BUILD_TARGET) |
| ︙ | ︙ | |||
1569 1570 1571 1572 1573 1574 1575 | @echo Installing demos to '$(DEMO_INSTALL_DIR)' @if not exist "$(DEMO_INSTALL_DIR)" mkdir "$(DEMO_INSTALL_DIR)" @if exist $(DEMODIR) $(CPYDIR) "$(DEMODIR)" "$(DEMO_INSTALL_DIR)" default-clean: @echo Cleaning $(TMP_DIR)\* ... @if exist $(TMP_DIR)\nul $(RMDIR) $(TMP_DIR) | | | | | | | | | | | | | | | | 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 | @echo Installing demos to '$(DEMO_INSTALL_DIR)' @if not exist "$(DEMO_INSTALL_DIR)" mkdir "$(DEMO_INSTALL_DIR)" @if exist $(DEMODIR) $(CPYDIR) "$(DEMODIR)" "$(DEMO_INSTALL_DIR)" default-clean: @echo Cleaning $(TMP_DIR)\* ... @if exist $(TMP_DIR)\nul $(RMDIR) $(TMP_DIR) @echo Cleaning $(WIN_DIR)\nmakehlp.obj, nmakehlp.exe ... @if exist $(WIN_DIR)\nmakehlp.obj del $(WIN_DIR)\nmakehlp.obj @if exist $(WIN_DIR)\nmakehlp.exe del $(WIN_DIR)\nmakehlp.exe @if exist $(WIN_DIR)\nmakehlp.out del $(WIN_DIR)\nmakehlp.out @echo Cleaning $(WIN_DIR)\nmhlp-out.txt ... @if exist $(WIN_DIR)\nmhlp-out.txt del $(WIN_DIR)\nmhlp-out.txt @echo Cleaning $(WIN_DIR)\_junk.pch ... @if exist $(WIN_DIR)\_junk.pch del $(WIN_DIR)\_junk.pch @echo Cleaning $(WIN_DIR)\vercl.x, vercl.i ... @if exist $(WIN_DIR)\vercl.x del $(WIN_DIR)\vercl.x @if exist $(WIN_DIR)\vercl.i del $(WIN_DIR)\vercl.i @echo Cleaning $(WIN_DIR)\versions.vc, version.vc ... @if exist $(WIN_DIR)\versions.vc del $(WIN_DIR)\versions.vc @if exist $(WIN_DIR)\version.vc del $(WIN_DIR)\version.vc default-hose: default-clean @echo Hosing $(OUT_DIR)\* ... @if exist $(OUT_DIR)\nul $(RMDIR) $(OUT_DIR) # Only for backward compatibility default-distclean: default-hose |
| ︙ | ︙ | |||
1674 1675 1676 1677 1678 1679 1680 |
# main application, the master makefile should define explicit rules.
{$(ROOT)}.c{$(TMP_DIR)}.obj::
$(CCPKGCMD) @<<
$<
<<
| | | | | > > > | | 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 |
# main application, the master makefile should define explicit rules.
{$(ROOT)}.c{$(TMP_DIR)}.obj::
$(CCPKGCMD) @<<
$<
<<
{$(WIN_DIR)}.c{$(TMP_DIR)}.obj::
$(CCPKGCMD) @<<
$<
<<
{$(GENERICDIR)}.c{$(TMP_DIR)}.obj::
$(CCPKGCMD) @<<
$<
<<
{$(COMPATDIR)}.c{$(TMP_DIR)}.obj::
$(CCPKGCMD) @<<
$<
<<
{$(RCDIR)}.rc{$(TMP_DIR)}.res:
$(RESCMD) $<
{$(WIN_DIR)}.rc{$(TMP_DIR)}.res:
$(RESCMD) $<
{$(TMP_DIR)}.rc{$(TMP_DIR)}.res:
$(RESCMD) $<
.SUFFIXES:
.SUFFIXES:.c .rc
!endif
################################################################
# 14. Sanity check selected options against Tcl build options
# When building an extension, certain configuration options should
# match the ones used when Tcl was built. Here we check and
# warn on a mismatch.
!if !$(DOING_TCL)
!if $(TCLINSTALL) # Building against an installed Tcl
!if exist("$(_TCLDIR)\lib\nmake\tcl.nmake")
TCLNMAKECONFIG = "$(_TCLDIR)\lib\nmake\tcl.nmake"
!endif
!else # !$(TCLINSTALL) - building against Tcl source
!if exist("$(OUT_DIR)\tcl.nmake")
TCLNMAKECONFIG = "$(OUT_DIR)\tcl.nmake"
!endif
!endif # TCLINSTALL
!if $(CONFIG_CHECK)
!ifdef TCLNMAKECONFIG
!include $(TCLNMAKECONFIG)
!if defined(CORE_MACHINE) && "$(CORE_MACHINE)" != "$(MACHINE)"
!error ERROR: Build target ($(MACHINE)) does not match the Tcl library architecture ($(CORE_MACHINE)).
!endif
!if $(TCL_VERSION) < 87 && defined(CORE_USE_THREAD_ALLOC) && $(CORE_USE_THREAD_ALLOC) != $(USE_THREAD_ALLOC)
!message WARNING: Value of USE_THREAD_ALLOC ($(USE_THREAD_ALLOC)) does not match its Tcl core value ($(CORE_USE_THREAD_ALLOC)).
!endif
!if defined(CORE_DEBUG) && $(CORE_DEBUG) != $(DEBUG)
!message WARNING: Value of DEBUG ($(DEBUG)) does not match its Tcl library configuration ($(DEBUG)).
!endif
!endif
!endif # TCLNMAKECONFIG
!endif # !$(DOING_TCL)
#----------------------------------------------------------
# Display stats being used.
#----------------------------------------------------------
!if !$(DOING_TCL)
|
| ︙ | ︙ |
Changes to win/targets.vc.
1 2 3 4 5 6 | #------------------------------------------------------------- -*- makefile -*- # targets.vc -- # # Part of the nmake based build system for Tcl and its extensions. # This file defines some standard targets for the convenience of extensions # and can be optionally included by the extension makefile. | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | #------------------------------------------------------------- -*- makefile -*- # targets.vc -- # # Part of the nmake based build system for Tcl and its extensions. # This file defines some standard targets for the convenience of extensions # and can be optionally included by the extension makefile. # See TIP 477 (https://core.tcl-lang.org/tips/doc/trunk/tip/477.md) for docs. $(PROJECT): setup pkgindex $(PRJLIB) !ifdef PRJ_STUBOBJS $(PROJECT): $(PRJSTUBLIB) $(PRJSTUBLIB): $(PRJ_STUBOBJS) $(LIBCMD) $** |
| ︙ | ︙ |
Changes to win/tcl.dsp.
| ︙ | ︙ | |||
32 33 34 35 36 37 38 | # PROP BASE Use_MFC 0 # PROP BASE Use_Debug_Libraries 0 # PROP BASE Output_Dir "Release" # PROP BASE Intermediate_Dir "Release\tcl_Dynamic" # PROP BASE Cmd_Line "nmake -nologo -f makefile.vc OPTS=none MSVCDIR=IDE" # PROP BASE Rebuild_Opt "-a" | | | | | | | | | | 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 | # PROP BASE Use_MFC 0 # PROP BASE Use_Debug_Libraries 0 # PROP BASE Output_Dir "Release" # PROP BASE Intermediate_Dir "Release\tcl_Dynamic" # PROP BASE Cmd_Line "nmake -nologo -f makefile.vc OPTS=none MSVCDIR=IDE" # PROP BASE Rebuild_Opt "-a" # PROP BASE Target_File "Release\tclsh87.exe" # PROP BASE Bsc_Name "" # PROP BASE Target_Dir "" # PROP Use_MFC 0 # PROP Use_Debug_Libraries 0 # PROP Output_Dir "Release" # PROP Intermediate_Dir "Release\tcl_Dynamic" # PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=threads MSVCDIR=IDE" # PROP Rebuild_Opt "clean release" # PROP Target_File "Release\tclsh87t.exe" # PROP Bsc_Name "" # PROP Target_Dir "" !ELSEIF "$(CFG)" == "tcl - Win32 Debug" # PROP BASE Use_MFC 0 # PROP BASE Use_Debug_Libraries 1 # PROP BASE Output_Dir "Debug" # PROP BASE Intermediate_Dir "Debug\tcl_Dynamic" # PROP BASE Cmd_Line "nmake -nologo -f makefile.vc OPTS=symbols MSVCDIR=IDE" # PROP BASE Rebuild_Opt "-a" # PROP BASE Target_File "Debug\tclsh87g.exe" # PROP BASE Bsc_Name "" # PROP BASE Target_Dir "" # PROP Use_MFC 0 # PROP Use_Debug_Libraries 1 # PROP Output_Dir "Debug" # PROP Intermediate_Dir "Debug\tcl_Dynamic" # PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=threads,symbols MSVCDIR=IDE" # PROP Rebuild_Opt "clean release" # PROP Target_File "Debug\tclsh87tg.exe" # PROP Bsc_Name "" # PROP Target_Dir "" !ELSEIF "$(CFG)" == "tcl - Win32 Debug Static" # PROP BASE Use_MFC 0 # PROP BASE Use_Debug_Libraries 1 # PROP BASE Output_Dir "Debug" # PROP BASE Intermediate_Dir "Debug\tcl_Static" # PROP BASE Cmd_Line "nmake -nologo -f makefile.vc OPTS=symbols,static MSVCDIR=IDE" # PROP BASE Rebuild_Opt "-a" # PROP BASE Target_File "Debug\tclsh87sg.exe" # PROP BASE Bsc_Name "" # PROP BASE Target_Dir "" # PROP Use_MFC 0 # PROP Use_Debug_Libraries 1 # PROP Output_Dir "Debug" # PROP Intermediate_Dir "Debug\tcl_Static" # PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=symbols,static MSVCDIR=IDE" # PROP Rebuild_Opt "-a" # PROP Target_File "Debug\tclsh87sg.exe" # PROP Bsc_Name "" # PROP Target_Dir "" !ELSEIF "$(CFG)" == "tcl - Win32 Release Static" # PROP BASE Use_MFC 0 # PROP BASE Use_Debug_Libraries 0 # PROP BASE Output_Dir "Release" # PROP BASE Intermediate_Dir "Release\tcl_Static" # PROP BASE Cmd_Line "nmake -nologo -f makefile.vc OPTS=static MSVCDIR=IDE" # PROP BASE Rebuild_Opt "-a" # PROP BASE Target_File "Release\tclsh87s.exe" # PROP BASE Bsc_Name "" # PROP BASE Target_Dir "" # PROP Use_MFC 0 # PROP Use_Debug_Libraries 0 # PROP Output_Dir "Release" # PROP Intermediate_Dir "Release\tcl_Static" # PROP Cmd_Line "nmake -nologo -f makefile.vc OPTS=static MSVCDIR=IDE" # PROP Rebuild_Opt "-a" # PROP Target_File "Release\tclsh87s.exe" # PROP Bsc_Name "" # PROP Target_Dir "" !ENDIF # Begin Target |
| ︙ | ︙ | |||
144 145 146 147 148 149 150 | # End Source File # Begin Source File SOURCE=..\compat\dlfcn.h # End Source File # Begin Source File | < < < < | 144 145 146 147 148 149 150 151 152 153 154 155 156 157 | # End Source File # Begin Source File SOURCE=..\compat\dlfcn.h # End Source File # Begin Source File SOURCE=..\compat\gettod.c # End Source File # Begin Source File SOURCE=..\compat\limits.h # End Source File # Begin Source File |
| ︙ | ︙ | |||
182 183 184 185 186 187 188 | SOURCE=..\compat\strncasecmp.c # End Source File # Begin Source File SOURCE=..\compat\strstr.c # End Source File | < < < < | 178 179 180 181 182 183 184 185 186 187 188 189 190 191 | SOURCE=..\compat\strncasecmp.c # End Source File # Begin Source File SOURCE=..\compat\strstr.c # End Source File # Begin Source File SOURCE=..\compat\strtol.c # End Source File # Begin Source File SOURCE=..\compat\strtoul.c |
| ︙ | ︙ |
Changes to win/tcl.hpj.in.
1 2 3 4 5 6 7 | ; This file is maintained by HCW. Do not modify this file directly. [OPTIONS] HCW=0 LCID=0x409 0x0 0x0 ;English (United States) REPORT=Yes TITLE=Tcl/Tk Reference Manual | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | ; This file is maintained by HCW. Do not modify this file directly. [OPTIONS] HCW=0 LCID=0x409 0x0 0x0 ;English (United States) REPORT=Yes TITLE=Tcl/Tk Reference Manual CNT=tcl87.cnt COPYRIGHT=Copyright © 2000 Ajuba Solutions HLP=tcl87.hlp [FILES] tcl.rtf [WINDOWS] main="Tcl/Tk Reference Manual",,0 |
| ︙ | ︙ |
Changes to win/tcl.m4.
| ︙ | ︙ | |||
537 538 539 540 541 542 543 |
ac_cv_cross=no,
ac_cv_cross=yes)
)
if test "$ac_cv_cross" = "yes"; then
case "$do64bit" in
amd64|x64|yes)
| | | | 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 |
ac_cv_cross=no,
ac_cv_cross=yes)
)
if test "$ac_cv_cross" = "yes"; then
case "$do64bit" in
amd64|x64|yes)
CC="x86_64-w64-mingw32-${CC}"
LD="x86_64-w64-mingw32-ld"
AR="x86_64-w64-mingw32-ar"
RANLIB="x86_64-w64-mingw32-ranlib"
RC="x86_64-w64-mingw32-windres"
;;
*)
CC="i686-w64-mingw32-${CC}"
LD="i686-w64-mingw32-ld"
AR="i686-w64-mingw32-ar"
RANLIB="i686-w64-mingw32-ranlib"
RC="i686-w64-mingw32-windres"
;;
esac
fi
|
| ︙ | ︙ | |||
681 682 683 684 685 686 687 |
LIBFLAGSUFFIX="\${DBGX}"
SHLIB_SUFFIX=.dll
EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
| | > > > > > > > > > | 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 |
LIBFLAGSUFFIX="\${DBGX}"
SHLIB_SUFFIX=.dll
EXTRA_CFLAGS="${extra_cflags}"
CFLAGS_DEBUG=-g
CFLAGS_OPTIMIZE="-O2 -fomit-frame-pointer"
CFLAGS_WARNING="-Wall -Wextra -Wwrite-strings -Wpointer-arith"
LDFLAGS_DEBUG=
LDFLAGS_OPTIMIZE=
case "${CC}" in
*++)
CFLAGS_WARNING="${CFLAGS_WARNING} -Wno-format"
;;
*)
CFLAGS_WARNING="${CFLAGS_WARNING} -Wc++-compat -Wdeclaration-after-statement"
;;
esac
# Specify the CC output file names based on the target name
CC_OBJNAME="-o \[$]@"
CC_EXENAME="-o \[$]@"
# Specify linker flags depending on the type of app being
# built -- Console vs. Window.
|
| ︙ | ︙ | |||
760 761 762 763 764 765 766 |
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\[$]@"
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX="\${DBGX}.dll"
LIBSUFFIX="\${DBGX}.lib"
LIBFLAGSUFFIX="\${DBGX}"
| < < < < < < < < < < < < < < < < < < < < < < | | | | 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 |
MAKE_DLL="\${SHLIB_LD} \$(LDFLAGS) -out:\[$]@"
# DLLSUFFIX is separate because it is the building block for
# users of tclConfig.sh that may build shared or static.
DLLSUFFIX="\${DBGX}.dll"
LIBSUFFIX="\${DBGX}.lib"
LIBFLAGSUFFIX="\${DBGX}"
if test "$do64bit" != "no" ; then
case "$do64bit" in
amd64|x64|yes)
MACHINE="AMD64" ; # assume AMD64 as default 64-bit build
;;
ia64)
MACHINE="IA64"
;;
esac
AC_MSG_RESULT([ Using 64-bit $MACHINE mode])
fi
LIBS="netapi32.lib kernel32.lib user32.lib advapi32.lib userenv.lib ws2_32.lib"
case "x`echo \${VisualStudioVersion}`" in
x1[[4-9]]*)
LIBS="$LIBS ucrt.lib"
;;
*)
;;
esac
if test "$do64bit" != "no" ; then
RC="rc"
CFLAGS_DEBUG="-nologo -Zi -Od ${runtime}d"
# Do not use -O2 for Win64 - this has proved buggy in code gen.
CFLAGS_OPTIMIZE="-nologo -O1 ${runtime}"
lflags="${lflags} -nologo -MACHINE:${MACHINE}"
LINKBIN="link"
# Avoid 'unresolved external symbol __security_cookie' errors.
# c.f. http://support.microsoft.com/?id=894573
LIBS="$LIBS bufferoverflowU.lib"
else
RC="rc"
# -Od - no optimization
# -WX - warnings as errors
|
| ︙ | ︙ | |||
944 945 946 947 948 949 950 951 952 953 954 955 956 957 |
tcl_cv_winnt_ignore_void=no)
)
if test "$tcl_cv_winnt_ignore_void" = "yes" ; then
AC_DEFINE(HAVE_WINNT_IGNORE_VOID, 1,
[Defined when cygwin/mingw ignores VOID define in winnt.h])
fi
# See if the compiler supports casting to a union type.
# This is used to stop gcc from printing a compiler
# warning when initializing a union member.
AC_CACHE_CHECK(for cast to union support,
tcl_cv_cast_to_union,
AC_TRY_COMPILE([],
| > > | 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 |
tcl_cv_winnt_ignore_void=no)
)
if test "$tcl_cv_winnt_ignore_void" = "yes" ; then
AC_DEFINE(HAVE_WINNT_IGNORE_VOID, 1,
[Defined when cygwin/mingw ignores VOID define in winnt.h])
fi
AC_CHECK_HEADER(stdbool.h, [AC_DEFINE(HAVE_STDBOOL_H, 1, [Do we have <stdbool.h>?])],)
# See if the compiler supports casting to a union type.
# This is used to stop gcc from printing a compiler
# warning when initializing a union member.
AC_CACHE_CHECK(for cast to union support,
tcl_cv_cast_to_union,
AC_TRY_COMPILE([],
|
| ︙ | ︙ | |||
989 990 991 992 993 994 995 | # --with-tcl=... # # Defines the following vars: # TCL_BIN_DIR Full path to the tcl build dir. #------------------------------------------------------------------------ AC_DEFUN([SC_WITH_TCL], [ | | | | | | 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 |
# --with-tcl=...
#
# Defines the following vars:
# TCL_BIN_DIR Full path to the tcl build dir.
#------------------------------------------------------------------------
AC_DEFUN([SC_WITH_TCL], [
if test -d ../../tcl8.7$1/win; then
TCL_BIN_DEFAULT=../../tcl8.7$1/win
else
TCL_BIN_DEFAULT=../../tcl8.7/win
fi
AC_ARG_WITH(tcl, [ --with-tcl=DIR use Tcl 8.7 binaries from DIR],
TCL_BIN_DIR=$withval, TCL_BIN_DIR=`cd $TCL_BIN_DEFAULT; pwd`)
if test ! -d $TCL_BIN_DIR; then
AC_MSG_ERROR(Tcl directory $TCL_BIN_DIR does not exist)
fi
if test ! -f $TCL_BIN_DIR/Makefile; then
AC_MSG_ERROR(There is no Makefile in $TCL_BIN_DIR: perhaps you did not specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?)
else
|
| ︙ | ︙ |
Changes to win/tclAppInit.c.
| ︙ | ︙ | |||
83 84 85 86 87 88 89 |
*----------------------------------------------------------------------
*/
#ifdef TCL_BROKEN_MAINARGS
int
main(
int argc, /* Number of command-line arguments. */
| | > < > > | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 |
*----------------------------------------------------------------------
*/
#ifdef TCL_BROKEN_MAINARGS
int
main(
int argc, /* Number of command-line arguments. */
char **argv1)
{
TCHAR **argv;
TCHAR *p;
#else
int
_tmain(
int argc, /* Number of command-line arguments. */
TCHAR *argv[]) /* Values of command-line arguments. */
{
TCHAR *p;
#endif
/*
* Set up the default locale to be standard "C" locale so parsing is
* performed correctly.
*/
setlocale(LC_ALL, "C");
#ifdef TCL_BROKEN_MAINARGS
/*
* Get our args from the c-runtime. Ignore command line.
*/
(void)argv1;
setargv(&argc, &argv);
#endif
/*
* Forward slashes substituted for backslashes.
*/
|
| ︙ | ︙ | |||
263 264 265 266 267 268 269 |
}
if (*p == '\0') {
break;
}
}
}
| | > | | 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 |
}
if (*p == '\0') {
break;
}
}
}
/* Make sure we don't call ckalloc through the (not yet initialized) stub table */
# undef Tcl_Alloc
# undef Tcl_DbCkalloc
argSpace = (TCHAR *)ckalloc(size * sizeof(char *)
+ (_tcslen(cmdLine) * sizeof(TCHAR)) + sizeof(TCHAR));
argv = (TCHAR **) argSpace;
argSpace += size * (sizeof(char *)/sizeof(TCHAR));
size--;
p = cmdLine;
for (argc = 0; argc < size; argc++) {
|
| ︙ | ︙ |
Changes to win/tclWin32Dll.c.
| ︙ | ︙ | |||
86 87 88 89 90 91 92 |
*----------------------------------------------------------------------
*/
BOOL APIENTRY
DllEntryPoint(
HINSTANCE hInst, /* Library instance handle. */
DWORD reason, /* Reason this function is being called. */
| | | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 |
*----------------------------------------------------------------------
*/
BOOL APIENTRY
DllEntryPoint(
HINSTANCE hInst, /* Library instance handle. */
DWORD reason, /* Reason this function is being called. */
LPVOID reserved)
{
return DllMain(hInst, reason, reserved);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
113 114 115 116 117 118 119 |
*----------------------------------------------------------------------
*/
BOOL APIENTRY
DllMain(
HINSTANCE hInst, /* Library instance handle. */
DWORD reason, /* Reason this function is being called. */
| | | 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
*----------------------------------------------------------------------
*/
BOOL APIENTRY
DllMain(
HINSTANCE hInst, /* Library instance handle. */
DWORD reason, /* Reason this function is being called. */
TCL_UNUSED(LPVOID))
{
switch (reason) {
case DLL_PROCESS_ATTACH:
DisableThreadLibraryCalls(hInst);
TclWinInit(hInst);
return TRUE;
|
| ︙ | ︙ | |||
251 252 253 254 255 256 257 |
* Clean up the mount point map.
*/
Tcl_MutexLock(&mountPointMap);
dlIter = driveLetterLookup;
while (dlIter != NULL) {
dlIter2 = dlIter->nextPtr;
| | | | 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 |
* Clean up the mount point map.
*/
Tcl_MutexLock(&mountPointMap);
dlIter = driveLetterLookup;
while (dlIter != NULL) {
dlIter2 = dlIter->nextPtr;
ckfree(dlIter->volumeName);
ckfree(dlIter);
dlIter = dlIter2;
}
Tcl_MutexUnlock(&mountPointMap);
}
/*
*--------------------------------------------------------------------
|
| ︙ | ︙ | |||
286 287 288 289 290 291 292 |
char
TclWinDriveLetterForVolMountPoint(
const WCHAR *mountPoint)
{
MountPointMap *dlIter, *dlPtr2;
WCHAR Target[55]; /* Target of mount at mount point */
| | | 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 |
char
TclWinDriveLetterForVolMountPoint(
const WCHAR *mountPoint)
{
MountPointMap *dlIter, *dlPtr2;
WCHAR Target[55]; /* Target of mount at mount point */
WCHAR drive[4] = L"A:\\";
/*
* Detect the volume mounted there. Unfortunately, there is no simple way
* to map a unique volume name to a DOS drive letter. So, we have to build
* an associative array.
*/
|
| ︙ | ︙ | |||
310 311 312 313 314 315 316 | drive[0] = (WCHAR) dlIter->driveLetter; /* * Try to read the volume mount point and see where it points. */ | | | 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 |
drive[0] = (WCHAR) dlIter->driveLetter;
/*
* Try to read the volume mount point and see where it points.
*/
if (GetVolumeNameForVolumeMountPointW(drive,
Target, 55) != 0) {
if (wcscmp(dlIter->volumeName, Target) == 0) {
/*
* Nothing has changed.
*/
Tcl_MutexUnlock(&mountPointMap);
|
| ︙ | ︙ | |||
345 346 347 348 349 350 351 | } } /* * Now dlPtr2 points to the structure to free. */ | | | | | | | | 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 |
}
}
/*
* Now dlPtr2 points to the structure to free.
*/
ckfree(dlPtr2->volumeName);
ckfree(dlPtr2);
/*
* Restart the loop - we could try to be clever and continue half
* way through, but the logic is a bit messy, so it's cleanest
* just to restart.
*/
dlIter = driveLetterLookup;
continue;
}
dlIter = dlIter->nextPtr;
}
/*
* We couldn't find it, so we must iterate over the letters.
*/
for (drive[0] = 'A'; drive[0] <= 'Z'; drive[0]++) {
/*
* Try to read the volume mount point and see where it points.
*/
if (GetVolumeNameForVolumeMountPointW(drive,
Target, 55) != 0) {
int alreadyStored = 0;
for (dlIter = driveLetterLookup; dlIter != NULL;
dlIter = dlIter->nextPtr) {
if (wcscmp(dlIter->volumeName, Target) == 0) {
alreadyStored = 1;
break;
}
}
if (!alreadyStored) {
dlPtr2 = (MountPointMap *)ckalloc(sizeof(MountPointMap));
dlPtr2->volumeName = (WCHAR *)TclNativeDupInternalRep(Target);
dlPtr2->driveLetter = (char) drive[0];
dlPtr2->nextPtr = driveLetterLookup;
driveLetterLookup = dlPtr2;
}
}
}
|
| ︙ | ︙ | |||
407 408 409 410 411 412 413 |
}
/*
* The volume doesn't appear to correspond to a drive letter - we remember
* that fact and store '-1' so we don't have to look it up each time.
*/
| | | | 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 |
}
/*
* The volume doesn't appear to correspond to a drive letter - we remember
* that fact and store '-1' so we don't have to look it up each time.
*/
dlPtr2 = (MountPointMap *)ckalloc(sizeof(MountPointMap));
dlPtr2->volumeName = (WCHAR *)TclNativeDupInternalRep((void *)mountPoint);
dlPtr2->driveLetter = -1;
dlPtr2->nextPtr = driveLetterLookup;
driveLetterLookup = dlPtr2;
Tcl_MutexUnlock(&mountPointMap);
return -1;
}
|
| ︙ | ︙ | |||
459 460 461 462 463 464 465 | * * Side effects: * None. * *--------------------------------------------------------------------------- */ | > > | | | < < < | | | | | < | | | < < < < < < | 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 |
*
* Side effects:
* None.
*
*---------------------------------------------------------------------------
*/
#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
#undef Tcl_WinUtfToTChar
TCHAR *
Tcl_WinUtfToTChar(
const char *string, /* Source string in UTF-8. */
int len, /* Source string length in bytes, or -1 for
* strlen(). */
Tcl_DString *dsPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
Tcl_DStringInit(dsPtr);
return (TCHAR *)Tcl_UtfToWCharDString(string, len, dsPtr);
}
#undef Tcl_WinTCharToUtf
char *
Tcl_WinTCharToUtf(
const TCHAR *string, /* Source string in Unicode. */
int len, /* Source string length in bytes, or -1 for
* platform-specific string length. */
Tcl_DString *dsPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
Tcl_DStringInit(dsPtr);
return Tcl_WCharToUtfDString((WCHAR *)string, len >> 1, dsPtr);
}
#endif /* !defined(TCL_NO_DEPRECATED) */
/*
*------------------------------------------------------------------------
*
* TclWinCPUID --
*
* Get CPU ID information on an Intel box under Windows
|
| ︙ | ︙ | |||
543 544 545 546 547 548 549 | "movl %[rptr], %%edi" "\n\t" "movl %[index], %%eax" "\n\t" "cpuid" "\n\t" "movl %%eax, 0x0(%%edi)" "\n\t" "movl %%ebx, 0x4(%%edi)" "\n\t" "movl %%ecx, 0x8(%%edi)" "\n\t" | | | 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 | "movl %[rptr], %%edi" "\n\t" "movl %[index], %%eax" "\n\t" "cpuid" "\n\t" "movl %%eax, 0x0(%%edi)" "\n\t" "movl %%ebx, 0x4(%%edi)" "\n\t" "movl %%ecx, 0x8(%%edi)" "\n\t" "movl %%edx, 0xC(%%edi)" "\n\t" : /* No outputs */ : [index] "m" (index), [rptr] "m" (regsPtr) : |
| ︙ | ︙ | |||
575 576 577 578 579 580 581 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ | | | | 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ "movl %%esp, 0xC(%%edx)" "\n\t" /* esp */ "movl %[error], 0x10(%%edx)" "\n\t" /* status */ /* * Link the TCLEXCEPTION_REGISTRATION on the chain */ "movl %%edx, %%fs:0" "\n\t" /* * Do the CPUID instruction, and save the results in the 'regsPtr' * area. */ "movl %[rptr], %%edi" "\n\t" "movl %[index], %%eax" "\n\t" "cpuid" "\n\t" "movl %%eax, 0x0(%%edi)" "\n\t" "movl %%ebx, 0x4(%%edi)" "\n\t" "movl %%ecx, 0x8(%%edi)" "\n\t" "movl %%edx, 0xC(%%edi)" "\n\t" /* * Come here on a normal exit. Recover the TCLEXCEPTION_REGISTRATION and * store a TCL_OK status. */ "movl %%fs:0, %%edx" "\n\t" |
| ︙ | ︙ | |||
622 623 624 625 626 627 628 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" | | | 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" "movl 0xC(%%edx), %%esp" "\n\t" "movl 0x8(%%edx), %%ebp" "\n\t" "movl 0x0(%%edx), %%eax" "\n\t" "movl %%eax, %%fs:0" "\n\t" : /* No outputs */ : |
| ︙ | ︙ |
Changes to win/tclWinChan.c.
| ︙ | ︙ | |||
72 73 74 75 76 77 78 | * Static routines for this file: */ static int FileBlockProc(ClientData instanceData, int mode); static void FileChannelExitHandler(ClientData clientData); static void FileCheckProc(ClientData clientData, int flags); static int FileCloseProc(ClientData instanceData, | | > > | > > > > | | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 |
* Static routines for this file:
*/
static int FileBlockProc(ClientData instanceData, int mode);
static void FileChannelExitHandler(ClientData clientData);
static void FileCheckProc(ClientData clientData, int flags);
static int FileCloseProc(ClientData instanceData,
Tcl_Interp *interp, int flags);
static int FileEventProc(Tcl_Event *evPtr, int flags);
static int FileGetHandleProc(ClientData instanceData,
int direction, ClientData *handlePtr);
static ThreadSpecificData *FileInit(void);
static int FileInputProc(ClientData instanceData, char *buf,
int toRead, int *errorCode);
static int FileOutputProc(ClientData instanceData,
const char *buf, int toWrite, int *errorCode);
#ifndef TCL_NO_DEPRECATED
static int FileSeekProc(ClientData instanceData, long offset,
int mode, int *errorCode);
#endif
static Tcl_WideInt FileWideSeekProc(ClientData instanceData,
Tcl_WideInt offset, int mode, int *errorCode);
static void FileSetupProc(ClientData clientData, int flags);
static void FileWatchProc(ClientData instanceData, int mask);
static void FileThreadActionProc(ClientData instanceData,
int action);
static int FileTruncateProc(ClientData instanceData,
Tcl_WideInt length);
static DWORD FileGetType(HANDLE handle);
static int NativeIsComPort(const WCHAR *nativeName);
/*
* This structure describes the channel type structure for file based IO.
*/
static const Tcl_ChannelType fileChannelType = {
"file", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
TCL_CLOSE2PROC, /* Close proc. */
FileInputProc, /* Input proc. */
FileOutputProc, /* Output proc. */
#ifndef TCL_NO_DEPRECATED
FileSeekProc, /* Seek proc. */
#else
NULL,
#endif
NULL, /* Set option proc. */
NULL, /* Get option proc. */
FileWatchProc, /* Set up the notifier to watch the channel. */
FileGetHandleProc, /* Get an OS handle from channel. */
FileCloseProc, /* close2proc. */
FileBlockProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
FileWideSeekProc, /* Wide seek proc. */
FileThreadActionProc, /* Thread action proc. */
FileTruncateProc /* Truncate proc. */
};
|
| ︙ | ︙ | |||
176 177 178 179 180 181 182 | * Destroys the communication window. * *---------------------------------------------------------------------- */ static void FileChannelExitHandler( | | | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 |
* Destroys the communication window.
*
*----------------------------------------------------------------------
*/
static void
FileChannelExitHandler(
TCL_UNUSED(ClientData))
{
Tcl_DeleteEventSource(FileSetupProc, FileCheckProc, NULL);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
200 201 202 203 204 205 206 | * Adjusts the block time if needed. * *---------------------------------------------------------------------- */ void FileSetupProc( | | | 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 |
* Adjusts the block time if needed.
*
*----------------------------------------------------------------------
*/
void
FileSetupProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
FileInfo *infoPtr;
Tcl_Time blockTime = { 0, 0 };
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!TEST_FLAG(flags, TCL_FILE_EVENTS)) {
|
| ︙ | ︙ | |||
243 244 245 246 247 248 249 | * May queue an event. * *---------------------------------------------------------------------- */ static void FileCheckProc( | | | | 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 |
* May queue an event.
*
*----------------------------------------------------------------------
*/
static void
FileCheckProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
FileEvent *evPtr;
FileInfo *infoPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!TEST_FLAG(flags, TCL_FILE_EVENTS)) {
return;
}
/*
* Queue events for any ready files that don't already have events queued
* (caused by persistent states that won't generate WinSock events).
*/
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->watchMask && !TEST_FLAG(infoPtr->flags, FILE_PENDING)) {
SET_FLAG(infoPtr->flags, FILE_PENDING);
evPtr = (FileEvent *)ckalloc(sizeof(FileEvent));
evPtr->header.proc = FileEventProc;
evPtr->infoPtr = infoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
}
}
}
|
| ︙ | ︙ | |||
346 347 348 349 350 351 352 |
static int
FileBlockProc(
ClientData instanceData, /* Instance data for channel. */
int mode) /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
| | | 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 |
static int
FileBlockProc(
ClientData instanceData, /* Instance data for channel. */
int mode) /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
/*
* Files on Windows can not be switched between blocking and nonblocking,
* hence we have to emulate the behavior. This is done in the input
* function by checking against a bit in the state. We set or unset the
* bit here to cause the input function to emulate the correct behavior.
*/
|
| ︙ | ︙ | |||
382 383 384 385 386 387 388 |
*
*----------------------------------------------------------------------
*/
static int
FileCloseProc(
ClientData instanceData, /* Pointer to FileInfo structure. */
| | > | > > > > | 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 |
*
*----------------------------------------------------------------------
*/
static int
FileCloseProc(
ClientData instanceData, /* Pointer to FileInfo structure. */
TCL_UNUSED(Tcl_Interp *),
int flags)
{
FileInfo *fileInfoPtr = (FileInfo *)instanceData;
FileInfo *infoPtr;
ThreadSpecificData *tsdPtr;
int errorCode = 0;
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
/*
* Remove the file from the watch list.
*/
FileWatchProc(instanceData, 0);
|
| ︙ | ︙ | |||
430 431 432 433 434 435 436 |
* pointer on the thread local list.
*/
FileThreadActionProc(fileInfoPtr,TCL_CHANNEL_THREAD_REMOVE);
break;
}
}
| | | | | 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 |
* pointer on the thread local list.
*/
FileThreadActionProc(fileInfoPtr,TCL_CHANNEL_THREAD_REMOVE);
break;
}
}
ckfree(fileInfoPtr);
return errorCode;
}
/*
*----------------------------------------------------------------------
*
* FileSeekProc --
*
* Seeks on a file-based channel. Returns the new position.
*
* Results:
* -1 if failed, the new position if successful. If failed, it also sets
* *errorCodePtr to the error code.
*
* Side effects:
* Moves the location at which the channel will be accessed in future
* operations.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
static int
FileSeekProc(
ClientData instanceData, /* File state. */
long offset, /* Offset to seek to. */
int mode, /* Relative to where should we seek? */
int *errorCodePtr) /* To store error code. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
LONG newPos, newPosHigh, oldPos, oldPosHigh;
DWORD moveMethod;
*errorCodePtr = 0;
if (mode == SEEK_SET) {
moveMethod = FILE_BEGIN;
} else if (mode == SEEK_CUR) {
|
| ︙ | ︙ | |||
511 512 513 514 515 516 517 518 519 520 521 522 523 524 |
if (newPosHigh != 0) {
*errorCodePtr = EOVERFLOW;
SetFilePointer(infoPtr->handle, oldPos, &oldPosHigh, FILE_BEGIN);
return -1;
}
return (int) newPos;
}
/*
*----------------------------------------------------------------------
*
* FileWideSeekProc --
*
* Seeks on a file-based channel. Returns the new position.
| > | 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 |
if (newPosHigh != 0) {
*errorCodePtr = EOVERFLOW;
SetFilePointer(infoPtr->handle, oldPos, &oldPosHigh, FILE_BEGIN);
return -1;
}
return (int) newPos;
}
#endif
/*
*----------------------------------------------------------------------
*
* FileWideSeekProc --
*
* Seeks on a file-based channel. Returns the new position.
|
| ︙ | ︙ | |||
537 538 539 540 541 542 543 |
static Tcl_WideInt
FileWideSeekProc(
ClientData instanceData, /* File state. */
Tcl_WideInt offset, /* Offset to seek to. */
int mode, /* Relative to where should we seek? */
int *errorCodePtr) /* To store error code. */
{
| | | 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 |
static Tcl_WideInt
FileWideSeekProc(
ClientData instanceData, /* File state. */
Tcl_WideInt offset, /* Offset to seek to. */
int mode, /* Relative to where should we seek? */
int *errorCodePtr) /* To store error code. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
DWORD moveMethod;
LONG newPos, newPosHigh;
*errorCodePtr = 0;
if (mode == SEEK_SET) {
moveMethod = FILE_BEGIN;
} else if (mode == SEEK_CUR) {
|
| ︙ | ︙ | |||
587 588 589 590 591 592 593 |
*/
static int
FileTruncateProc(
ClientData instanceData, /* File state. */
Tcl_WideInt length) /* Length to truncate at. */
{
| | | 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 |
*/
static int
FileTruncateProc(
ClientData instanceData, /* File state. */
Tcl_WideInt length) /* Length to truncate at. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
LONG newPos, newPosHigh, oldPos, oldPosHigh;
/*
* Save where we were...
*/
oldPosHigh = 0;
|
| ︙ | ︙ | |||
665 666 667 668 669 670 671 |
static int
FileInputProc(
ClientData instanceData, /* File state. */
char *buf, /* Where to store data read. */
int bufSize, /* Num bytes available in buffer. */
int *errorCode) /* Where to store error code. */
{
| | | 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 |
static int
FileInputProc(
ClientData instanceData, /* File state. */
char *buf, /* Where to store data read. */
int bufSize, /* Num bytes available in buffer. */
int *errorCode) /* Where to store error code. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
DWORD bytesRead;
*errorCode = 0;
/*
* TODO: This comment appears to be out of date. We *do* have a console
* driver, over in tclWinConsole.c. After some Windows developer confirms,
|
| ︙ | ︙ | |||
720 721 722 723 724 725 726 |
static int
FileOutputProc(
ClientData instanceData, /* File state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
| | | 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 |
static int
FileOutputProc(
ClientData instanceData, /* File state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
DWORD bytesWritten;
*errorCode = 0;
/*
* If we are writing to a file that was opened with O_APPEND, we need to
* seek to the end of the file before writing the current buffer.
|
| ︙ | ︙ | |||
767 768 769 770 771 772 773 |
static void
FileWatchProc(
ClientData instanceData, /* File state. */
int mask) /* What events to watch for; OR-ed combination
* of TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
| | | 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 |
static void
FileWatchProc(
ClientData instanceData, /* File state. */
int mask) /* What events to watch for; OR-ed combination
* of TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
Tcl_Time blockTime = { 0, 0 };
/*
* Since the file is always ready for events, we set the block time to
* zero so we will poll.
*/
|
| ︙ | ︙ | |||
805 806 807 808 809 810 811 |
static int
FileGetHandleProc(
ClientData instanceData, /* The file state. */
int direction, /* TCL_READABLE or TCL_WRITABLE */
ClientData *handlePtr) /* Where to store the handle. */
{
| | | 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 |
static int
FileGetHandleProc(
ClientData instanceData, /* The file state. */
int direction, /* TCL_READABLE or TCL_WRITABLE */
ClientData *handlePtr) /* Where to store the handle. */
{
FileInfo *infoPtr = (FileInfo *)instanceData;
if (!TEST_FLAG(direction, infoPtr->validMask)) {
return TCL_ERROR;
}
*handlePtr = (ClientData) infoPtr->handle;
return TCL_OK;
|
| ︙ | ︙ | |||
850 851 852 853 854 855 856 |
int channelPermissions = 0;
DWORD accessMode = 0, createMode, shareMode, flags;
const WCHAR *nativeName;
HANDLE handle;
char channelName[16 + TCL_INTEGER_SPACE];
TclFile readFile = NULL, writeFile = NULL;
| | | 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 |
int channelPermissions = 0;
DWORD accessMode = 0, createMode, shareMode, flags;
const WCHAR *nativeName;
HANDLE handle;
char channelName[16 + TCL_INTEGER_SPACE];
TclFile readFile = NULL, writeFile = NULL;
nativeName = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (nativeName == NULL) {
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open \"%s\": filename is invalid on this platform",
TclGetString(pathPtr)));
}
return NULL;
|
| ︙ | ︙ | |||
942 943 944 945 946 947 948 |
if (TEST_FLAG(mode, O_CREAT)) {
if (TEST_FLAG(permissions, S_IWRITE)) {
flags = FILE_ATTRIBUTE_NORMAL;
} else {
flags = FILE_ATTRIBUTE_READONLY;
}
} else {
| | | | | 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 |
if (TEST_FLAG(mode, O_CREAT)) {
if (TEST_FLAG(permissions, S_IWRITE)) {
flags = FILE_ATTRIBUTE_NORMAL;
} else {
flags = FILE_ATTRIBUTE_READONLY;
}
} else {
flags = GetFileAttributesW(nativeName);
if (flags == 0xFFFFFFFF) {
flags = 0;
}
}
/*
* Set up the file sharing mode. We want to allow simultaneous access.
*/
shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE;
/*
* Now we get to create the file.
*/
handle = CreateFileW(nativeName, accessMode, shareMode,
NULL, createMode, flags, (HANDLE) NULL);
if (handle == INVALID_HANDLE_VALUE) {
DWORD err = GetLastError();
if ((err & 0xFFFFL) == ERROR_OPEN_FAILED) {
err = TEST_FLAG(mode, O_CREAT) ? ERROR_FILE_EXISTS
: ERROR_FILE_NOT_FOUND;
}
TclWinConvertError(err);
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't open \"%s\": %s",
|
| ︙ | ︙ | |||
1064 1065 1066 1067 1068 1069 1070 |
Tcl_Channel
Tcl_MakeFileChannel(
ClientData rawHandle, /* OS level handle */
int mode) /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
| | | 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 |
Tcl_Channel
Tcl_MakeFileChannel(
ClientData rawHandle, /* OS level handle */
int mode) /* ORed combination of TCL_READABLE and
* TCL_WRITABLE to indicate file mode. */
{
#if defined(HAVE_NO_SEH) && !defined(_WIN64) && !defined(__clang__)
TCLEXCEPTION_REGISTRATION registration;
#endif
char channelName[16 + TCL_INTEGER_SPACE];
Tcl_Channel channel = NULL;
HANDLE handle = (HANDLE) rawHandle;
HANDLE dupedHandle;
TclFile readFile = NULL, writeFile = NULL;
|
| ︙ | ︙ | |||
1117 1118 1119 1120 1121 1122 1123 |
result = DuplicateHandle(GetCurrentProcess(), handle,
GetCurrentProcess(), &dupedHandle, 0, FALSE,
DUPLICATE_SAME_ACCESS);
if (result == 0) {
/*
| | | | 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 |
result = DuplicateHandle(GetCurrentProcess(), handle,
GetCurrentProcess(), &dupedHandle, 0, FALSE,
DUPLICATE_SAME_ACCESS);
if (result == 0) {
/*
* Unable to make a duplicate. It's definitely invalid at this
* point.
*/
return NULL;
}
/*
* Use structured exception handling (Win32 SEH) to protect the close
* of this duped handle which might throw EXCEPTION_INVALID_HANDLE.
*/
result = 0;
#if defined(HAVE_NO_SEH) && !defined(_WIN64) && !defined(__clang__)
/*
* Don't have SEH available, do things the hard way. Note that this
* needs to be one block of asm, to avoid stack imbalance; also, it is
* illegal for one asm block to contain a jump to another.
*/
__asm__ __volatile__ (
|
| ︙ | ︙ | |||
1156 1157 1158 1159 1160 1161 1162 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ | | | 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ "movl %%esp, 0xC(%%edx)" "\n\t" /* esp */ "movl $0, 0x10(%%edx)" "\n\t" /* status */ /* * Link the TCLEXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" |
| ︙ | ︙ | |||
1196 1197 1198 1199 1200 1201 1202 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" | | | 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" "movl 0xC(%%edx), %%esp" "\n\t" "movl 0x8(%%edx), %%ebp" "\n\t" "movl 0x0(%%edx), %%eax" "\n\t" "movl %%eax, %%fs:0" "\n\t" : /* No outputs */ : |
| ︙ | ︙ | |||
1361 1362 1363 1364 1365 1366 1367 |
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->handle == (HANDLE) handle) {
return (permissions==infoPtr->validMask) ? infoPtr->channel : NULL;
}
}
| | | 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 |
for (infoPtr = tsdPtr->firstFilePtr; infoPtr != NULL;
infoPtr = infoPtr->nextPtr) {
if (infoPtr->handle == (HANDLE) handle) {
return (permissions==infoPtr->validMask) ? infoPtr->channel : NULL;
}
}
infoPtr = (FileInfo *)ckalloc(sizeof(FileInfo));
/*
* TIP #218. Removed the code inserting the new structure into the global
* list. This is now handled in the thread action callbacks, and only
* there.
*/
|
| ︙ | ︙ | |||
1452 1453 1454 1455 1456 1457 1458 |
static void
FileThreadActionProc(
ClientData instanceData,
int action)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| | | 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 |
static void
FileThreadActionProc(
ClientData instanceData,
int action)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
FileInfo *infoPtr = (FileInfo *)instanceData;
if (action == TCL_CHANNEL_THREAD_INSERT) {
infoPtr->nextPtr = tsdPtr->firstFilePtr;
tsdPtr->firstFilePtr = infoPtr;
} else {
FileInfo **nextPtrPtr;
int removed = 0;
|
| ︙ | ︙ | |||
1567 1568 1569 1570 1571 1572 1573 |
*/
if ((len == 4) && (_wcsnicmp(p, L"com", 3) == 0)) {
/*
* The 4th character must be a digit 1..9
*/
| | | 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 |
*/
if ((len == 4) && (_wcsnicmp(p, L"com", 3) == 0)) {
/*
* The 4th character must be a digit 1..9
*/
if ((p[3] < '1') || (p[3] > '9')) {
return 0;
}
return 1;
}
/*
* 2. Look for \\.\com[0-9]+
|
| ︙ | ︙ |
Changes to win/tclWinConsole.c.
| ︙ | ︙ | |||
138 139 140 141 142 143 144 | * Declarations for functions used only in this file. */ static int ConsoleBlockModeProc(ClientData instanceData, int mode); static void ConsoleCheckProc(ClientData clientData, int flags); static int ConsoleCloseProc(ClientData instanceData, | | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 | * Declarations for functions used only in this file. */ static int ConsoleBlockModeProc(ClientData instanceData, int mode); static void ConsoleCheckProc(ClientData clientData, int flags); static int ConsoleCloseProc(ClientData instanceData, Tcl_Interp *interp, int flags); static int ConsoleEventProc(Tcl_Event *evPtr, int flags); static void ConsoleExitHandler(ClientData clientData); static int ConsoleGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr); static int ConsoleGetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); |
| ︙ | ︙ | |||
176 177 178 179 180 181 182 |
* This structure describes the channel type structure for command console
* based IO.
*/
static const Tcl_ChannelType consoleChannelType = {
"console", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
| | | | | < | | < | | | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 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 |
* This structure describes the channel type structure for command console
* based IO.
*/
static const Tcl_ChannelType consoleChannelType = {
"console", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
TCL_CLOSE2PROC, /* Close proc. */
ConsoleInputProc, /* Input proc. */
ConsoleOutputProc, /* Output proc. */
NULL, /* Seek proc. */
ConsoleSetOptionProc, /* Set option proc. */
ConsoleGetOptionProc, /* Get option proc. */
ConsoleWatchProc, /* Set up notifier to watch the channel. */
ConsoleGetHandleProc, /* Get an OS handle from channel. */
ConsoleCloseProc, /* close2proc. */
ConsoleBlockModeProc, /* Set blocking or non-blocking mode. */
NULL, /* Flush proc. */
NULL, /* Handler proc. */
NULL, /* Wide seek proc. */
ConsoleThreadActionProc, /* Thread action proc. */
NULL /* Truncation proc. */
};
/*
*----------------------------------------------------------------------
*
* ReadConsoleBytes, WriteConsoleBytes --
*
* Wrapper for ReadConsoleW, that takes and returns number of bytes
* instead of number of WCHARS.
*
*----------------------------------------------------------------------
*/
static BOOL
ReadConsoleBytes(
HANDLE hConsole,
LPVOID lpBuffer,
DWORD nbytes,
LPDWORD nbytesread)
{
DWORD ntchars;
BOOL result;
/*
* If user types a Ctrl-Break or Ctrl-C, ReadConsole will return
* success with ntchars == 0 and GetLastError() will be
* ERROR_OPERATION_ABORTED. We do not want to treat this case
* as EOF so we will loop around again. If no Ctrl signal handlers
* have been established, the default signal OS handler in a separate
* thread will terminate the program. If a Ctrl signal handler
* has been established (through an extension for example), it
* will run and take whatever action it deems appropriate.
*/
do {
result = ReadConsoleW(hConsole, lpBuffer, nbytes / sizeof(WCHAR), &ntchars,
NULL);
} while (result && ntchars == 0 && GetLastError() == ERROR_OPERATION_ABORTED);
if (nbytesread != NULL) {
*nbytesread = ntchars * sizeof(WCHAR);
}
return result;
}
static BOOL
WriteConsoleBytes(
HANDLE hConsole,
const void *lpBuffer,
DWORD nbytes,
LPDWORD nbyteswritten)
{
DWORD ntchars;
BOOL result;
result = WriteConsoleW(hConsole, lpBuffer, nbytes / sizeof(WCHAR), &ntchars,
NULL);
if (nbyteswritten != NULL) {
*nbyteswritten = ntchars * sizeof(WCHAR);
}
return result;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
315 316 317 318 319 320 321 | * Removes the console event source. * *---------------------------------------------------------------------- */ static void ConsoleExitHandler( | | | 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 |
* Removes the console event source.
*
*----------------------------------------------------------------------
*/
static void
ConsoleExitHandler(
TCL_UNUSED(ClientData))
{
Tcl_DeleteEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
339 340 341 342 343 344 345 | * Resets the process list. * *---------------------------------------------------------------------- */ static void ProcExitHandler( | | | 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 |
* Resets the process list.
*
*----------------------------------------------------------------------
*/
static void
ProcExitHandler(
TCL_UNUSED(ClientData))
{
Tcl_MutexLock(&consoleMutex);
initialized = 0;
Tcl_MutexUnlock(&consoleMutex);
}
/*
|
| ︙ | ︙ | |||
365 366 367 368 369 370 371 | * Adjusts the block time if needed. * *---------------------------------------------------------------------- */ void ConsoleSetupProc( | | | 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 |
* Adjusts the block time if needed.
*
*----------------------------------------------------------------------
*/
void
ConsoleSetupProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
ConsoleInfo *infoPtr;
Tcl_Time blockTime = { 0, 0 };
int block = 1;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
419 420 421 422 423 424 425 | * May queue an event. * *---------------------------------------------------------------------- */ static void ConsoleCheckProc( | | | 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 |
* May queue an event.
*
*----------------------------------------------------------------------
*/
static void
ConsoleCheckProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
ConsoleInfo *infoPtr;
int needEvent;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!(flags & TCL_FILE_EVENTS)) {
|
| ︙ | ︙ | |||
460 461 462 463 464 465 466 |
if (infoPtr->watchMask & TCL_READABLE) {
if (WaitForRead(infoPtr, 0) >= 0) {
needEvent = 1;
}
}
if (needEvent) {
| | | 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 |
if (infoPtr->watchMask & TCL_READABLE) {
if (WaitForRead(infoPtr, 0) >= 0) {
needEvent = 1;
}
}
if (needEvent) {
ConsoleEvent *evPtr = (ConsoleEvent *)ckalloc(sizeof(ConsoleEvent));
infoPtr->flags |= CONSOLE_PENDING;
evPtr->header.proc = ConsoleEventProc;
evPtr->infoPtr = infoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
}
}
|
| ︙ | ︙ | |||
492 493 494 495 496 497 498 |
static int
ConsoleBlockModeProc(
ClientData instanceData, /* Instance data for channel. */
int mode) /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
| | | 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 |
static int
ConsoleBlockModeProc(
ClientData instanceData, /* Instance data for channel. */
int mode) /* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
/*
* Consoles on Windows can not be switched between blocking and
* nonblocking, hence we have to emulate the behavior. This is done in the
* input function by checking against a bit in the state. We set or unset
* the bit here to cause the input function to emulate the correct
* behavior.
|
| ︙ | ︙ | |||
529 530 531 532 533 534 535 |
*
*----------------------------------------------------------------------
*/
static int
ConsoleCloseProc(
ClientData instanceData, /* Pointer to ConsoleInfo structure. */
| | > | > > > > | 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 |
*
*----------------------------------------------------------------------
*/
static int
ConsoleCloseProc(
ClientData instanceData, /* Pointer to ConsoleInfo structure. */
TCL_UNUSED(Tcl_Interp *),
int flags)
{
ConsoleInfo *consolePtr = (ConsoleInfo *)instanceData;
int errorCode = 0;
ConsoleInfo *infoPtr, **nextPtrPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
/*
* Clean up the background thread if necessary. Note that this must be
* done before we can close the file, since the thread may be blocking
* trying to read from the console.
*/
|
| ︙ | ︙ | |||
615 616 617 618 619 620 621 |
nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) {
if (infoPtr == (ConsoleInfo *) consolePtr) {
*nextPtrPtr = infoPtr->nextPtr;
break;
}
}
if (consolePtr->writeBuf != NULL) {
| | | | 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 |
nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) {
if (infoPtr == (ConsoleInfo *) consolePtr) {
*nextPtrPtr = infoPtr->nextPtr;
break;
}
}
if (consolePtr->writeBuf != NULL) {
ckfree(consolePtr->writeBuf);
consolePtr->writeBuf = 0;
}
ckfree(consolePtr);
return errorCode;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
649 650 651 652 653 654 655 |
ConsoleInputProc(
ClientData instanceData, /* Console state. */
char *buf, /* Where to store data read. */
int bufSize, /* How much space is available in the
* buffer? */
int *errorCode) /* Where to store error code. */
{
| | | 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 |
ConsoleInputProc(
ClientData instanceData, /* Console state. */
char *buf, /* Where to store data read. */
int bufSize, /* How much space is available in the
* buffer? */
int *errorCode) /* Where to store error code. */
{
ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
DWORD count, bytesRead = 0;
int result;
*errorCode = 0;
/*
* Synchronize with the reader thread.
|
| ︙ | ︙ | |||
741 742 743 744 745 746 747 |
static int
ConsoleOutputProc(
ClientData instanceData, /* Console state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
| | | 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 |
static int
ConsoleOutputProc(
ClientData instanceData, /* Console state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
ConsoleThreadInfo *threadInfo = &infoPtr->writer;
DWORD bytesWritten, timeout;
*errorCode = 0;
/* avoid blocking if pipe-thread exited */
timeout = (infoPtr->flags & CONSOLE_ASYNC) || !TclPipeThreadIsAlive(&threadInfo->TI)
|
| ︙ | ︙ | |||
782 783 784 785 786 787 788 |
if (toWrite > infoPtr->writeBufLen) {
/*
* Reallocate the buffer to be large enough to hold the data.
*/
if (infoPtr->writeBuf) {
| | | | 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 |
if (toWrite > infoPtr->writeBufLen) {
/*
* Reallocate the buffer to be large enough to hold the data.
*/
if (infoPtr->writeBuf) {
ckfree(infoPtr->writeBuf);
}
infoPtr->writeBufLen = toWrite;
infoPtr->writeBuf = (char *)ckalloc(toWrite);
}
memcpy(infoPtr->writeBuf, buf, toWrite);
infoPtr->toWrite = toWrite;
ResetEvent(threadInfo->readyEvent);
TclPipeThreadSignal(&threadInfo->TI);
bytesWritten = toWrite;
} else {
|
| ︙ | ︙ | |||
926 927 928 929 930 931 932 |
ConsoleWatchProc(
ClientData instanceData, /* Console state. */
int mask) /* What events to watch for, OR-ed combination
* of TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
ConsoleInfo **nextPtrPtr, *ptr;
| | | 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 |
ConsoleWatchProc(
ClientData instanceData, /* Console state. */
int mask) /* What events to watch for, OR-ed combination
* of TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
ConsoleInfo **nextPtrPtr, *ptr;
ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
int oldMask = infoPtr->watchMask;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* Since most of the work is handled by the background threads, we just
* need to update the watchMask and then force the notifier to poll once.
*/
|
| ︙ | ︙ | |||
981 982 983 984 985 986 987 |
*
*----------------------------------------------------------------------
*/
static int
ConsoleGetHandleProc(
ClientData instanceData, /* The console state. */
| | | | 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 |
*
*----------------------------------------------------------------------
*/
static int
ConsoleGetHandleProc(
ClientData instanceData, /* The console state. */
TCL_UNUSED(int) /*direction*/,
ClientData *handlePtr) /* Where to store the handle. */
{
ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
*handlePtr = infoPtr->handle;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1018 1019 1020 1021 1022 1023 1024 |
static int
WaitForRead(
ConsoleInfo *infoPtr, /* Console state. */
int blocking) /* Indicates whether call should be blocking
* or not. */
{
DWORD timeout, count;
| | | 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 |
static int
WaitForRead(
ConsoleInfo *infoPtr, /* Console state. */
int blocking) /* Indicates whether call should be blocking
* or not. */
{
DWORD timeout, count;
HANDLE *handle = (HANDLE *)infoPtr->handle;
ConsoleThreadInfo *threadInfo = &infoPtr->reader;
INPUT_RECORD input;
while (1) {
/*
* Synchronize with the reader thread.
*/
|
| ︙ | ︙ | |||
1053 1054 1055 1056 1057 1058 1059 |
* If the console has hit EOF, it is always readable.
*/
if (infoPtr->readFlags & CONSOLE_EOF) {
return 1;
}
| | | 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 |
* If the console has hit EOF, it is always readable.
*/
if (infoPtr->readFlags & CONSOLE_EOF) {
return 1;
}
if (PeekConsoleInputW(handle, &input, 1, &count) == FALSE) {
/*
* Check to see if the peek failed because of EOF.
*/
TclWinConvertError(GetLastError());
if (errno == EOF) {
|
| ︙ | ︙ | |||
1134 1135 1136 1137 1138 1139 1140 |
if (!TclPipeThreadWaitForSignal(&pipeTI)) {
/* exit */
break;
}
if (!infoPtr) {
infoPtr = (ConsoleInfo *)pipeTI->clientData;
| | | 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 |
if (!TclPipeThreadWaitForSignal(&pipeTI)) {
/* exit */
break;
}
if (!infoPtr) {
infoPtr = (ConsoleInfo *)pipeTI->clientData;
handle = (HANDLE *)infoPtr->handle;
threadInfo = &infoPtr->reader;
}
/*
* Look for data on the console, but first ignore any events that are
* not KEY_EVENTs.
|
| ︙ | ︙ | |||
1232 1233 1234 1235 1236 1237 1238 |
*/
if (!TclPipeThreadWaitForSignal(&pipeTI)) {
/* exit */
break;
}
if (!infoPtr) {
infoPtr = (ConsoleInfo *)pipeTI->clientData;
| | | 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 |
*/
if (!TclPipeThreadWaitForSignal(&pipeTI)) {
/* exit */
break;
}
if (!infoPtr) {
infoPtr = (ConsoleInfo *)pipeTI->clientData;
handle = (HANDLE *)infoPtr->handle;
threadInfo = &infoPtr->writer;
}
buf = infoPtr->writeBuf;
toWrite = infoPtr->toWrite;
/*
|
| ︙ | ︙ | |||
1319 1320 1321 1322 1323 1324 1325 |
ConsoleInit();
/*
* See if a channel with this handle already exists.
*/
| | | 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 |
ConsoleInit();
/*
* See if a channel with this handle already exists.
*/
infoPtr = (ConsoleInfo *)ckalloc(sizeof(ConsoleInfo));
memset(infoPtr, 0, sizeof(ConsoleInfo));
infoPtr->validMask = permissions;
infoPtr->handle = handle;
infoPtr->channel = (Tcl_Channel) NULL;
wsprintfA(encoding, "cp%d", GetConsoleCP());
|
| ︙ | ︙ | |||
1355 1356 1357 1358 1359 1360 1361 | infoPtr->flags |= CONSOLE_READ_OPS; GetConsoleMode(infoPtr->handle, &infoPtr->initMode); modes = infoPtr->initMode; modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT); modes |= ENABLE_LINE_INPUT; SetConsoleMode(infoPtr->handle, modes); | | | | | 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 |
infoPtr->flags |= CONSOLE_READ_OPS;
GetConsoleMode(infoPtr->handle, &infoPtr->initMode);
modes = infoPtr->initMode;
modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT);
modes |= ENABLE_LINE_INPUT;
SetConsoleMode(infoPtr->handle, modes);
infoPtr->reader.readyEvent = CreateEventW(NULL, TRUE, TRUE, NULL);
infoPtr->reader.thread = CreateThread(NULL, 256, ConsoleReaderThread,
TclPipeThreadCreateTI(&infoPtr->reader.TI, infoPtr,
infoPtr->reader.readyEvent), 0, NULL);
SetThreadPriority(infoPtr->reader.thread, THREAD_PRIORITY_HIGHEST);
}
if (permissions & TCL_WRITABLE) {
infoPtr->writer.readyEvent = CreateEventW(NULL, TRUE, TRUE, NULL);
infoPtr->writer.thread = CreateThread(NULL, 256, ConsoleWriterThread,
TclPipeThreadCreateTI(&infoPtr->writer.TI, infoPtr,
infoPtr->writer.readyEvent), 0, NULL);
SetThreadPriority(infoPtr->writer.thread, THREAD_PRIORITY_HIGHEST);
}
/*
* Files have default translation of AUTO and ^Z eof char, which means
* that a ^Z will be accepted as EOF when reading.
*/
Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");
Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "\032 {}");
Tcl_SetChannelOption(NULL, infoPtr->channel, "-encoding", "utf-16");
return infoPtr->channel;
}
/*
*----------------------------------------------------------------------
*
* ConsoleThreadActionProc --
|
| ︙ | ︙ | |||
1403 1404 1405 1406 1407 1408 1409 |
*/
static void
ConsoleThreadActionProc(
ClientData instanceData,
int action)
{
| | | 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 |
*/
static void
ConsoleThreadActionProc(
ClientData instanceData,
int action)
{
ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
/*
* We do not access firstConsolePtr in the thread structures. This is not
* for all serials managed by the thread, but only those we are watching.
* Removal of the filevent handlers before transfer thus takes care of
* this structure.
*/
|
| ︙ | ︙ | |||
1457 1458 1459 1460 1461 1462 1463 |
static int
ConsoleSetOptionProc(
ClientData instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Which option to set? */
const char *value) /* New value for option. */
{
| | | 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 |
static int
ConsoleSetOptionProc(
ClientData instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Which option to set? */
const char *value) /* New value for option. */
{
ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
int len = strlen(optionName);
int vlen = strlen(value);
/*
* Option -inputmode normal|password|raw
*/
|
| ︙ | ︙ | |||
1555 1556 1557 1558 1559 1560 1561 |
static int
ConsoleGetOptionProc(
ClientData instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Option to get. */
Tcl_DString *dsPtr) /* Where to store value(s). */
{
| | | 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 |
static int
ConsoleGetOptionProc(
ClientData instanceData, /* File state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Option to get. */
Tcl_DString *dsPtr) /* Where to store value(s). */
{
ConsoleInfo *infoPtr = (ConsoleInfo *)instanceData;
int valid = 0; /* Flag if valid option parsed. */
unsigned int len;
char buf[TCL_INTEGER_SPACE];
if (optionName == NULL) {
len = 0;
} else {
|
| ︙ | ︙ |
Changes to win/tclWinDde.c.
| ︙ | ︙ | |||
30 31 32 33 34 35 36 |
* registered by this process.
*/
typedef struct RegisteredInterp {
struct RegisteredInterp *nextPtr;
/* The next interp this application knows
* about. */
| | | 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
* registered by this process.
*/
typedef struct RegisteredInterp {
struct RegisteredInterp *nextPtr;
/* The next interp this application knows
* about. */
WCHAR *name; /* Interpreter's name (malloc-ed). */
Tcl_Obj *handlerPtr; /* The server handler command */
Tcl_Interp *interp; /* The interpreter attached to this name. */
} RegisteredInterp;
/*
* Used to keep track of conversations.
*/
|
| ︙ | ︙ | |||
75 76 77 78 79 80 81 | */ static HSZ ddeServiceGlobal = 0; static DWORD ddeInstance; /* The application instance handle given to us * by DdeInitialize. */ static int ddeIsServer = 0; | | | | | | | | | > > > > > > > > > > > > > > > > | 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 |
*/
static HSZ ddeServiceGlobal = 0;
static DWORD ddeInstance; /* The application instance handle given to us
* by DdeInitialize. */
static int ddeIsServer = 0;
#define TCL_DDE_VERSION "1.4.3"
#define TCL_DDE_PACKAGE_NAME "dde"
#define TCL_DDE_SERVICE_NAME L"TclEval"
#define TCL_DDE_EXECUTE_RESULT L"$TCLEVAL$EXECUTE$RESULT"
#define DDE_FLAG_ASYNC 1
#define DDE_FLAG_BINARY 2
#define DDE_FLAG_FORCE 4
TCL_DECLARE_MUTEX(ddeMutex)
/*
* Forward declarations for functions defined later in this file.
*/
static LRESULT CALLBACK DdeClientWindowProc(HWND hwnd, UINT uMsg,
WPARAM wParam, LPARAM lParam);
static int DdeCreateClient(DdeEnumServices *es);
static BOOL CALLBACK DdeEnumWindowsCallback(HWND hwndTarget,
LPARAM lParam);
static void DdeExitProc(void *clientData);
static int DdeGetServicesList(Tcl_Interp *interp,
const WCHAR *serviceName, const WCHAR *topicName);
static HDDEDATA CALLBACK DdeServerProc(UINT uType, UINT uFmt, HCONV hConv,
HSZ ddeTopic, HSZ ddeItem, HDDEDATA hData,
DWORD dwData1, DWORD dwData2);
static LRESULT DdeServicesOnAck(HWND hwnd, WPARAM wParam,
LPARAM lParam);
static void DeleteProc(void *clientData);
static Tcl_Obj * ExecuteRemoteObject(RegisteredInterp *riPtr,
Tcl_Obj *ddeObjectPtr);
static int MakeDdeConnection(Tcl_Interp *interp,
const WCHAR *name, HCONV *ddeConvPtr);
static void SetDdeError(Tcl_Interp *interp);
static int DdeObjCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
#if (TCL_MAJOR_VERSION < 9) && (TCL_MINOR_VERSION < 7)
# if TCL_UTF_MAX > 3
# define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf((TCHAR *)(a),(b)*sizeof(WCHAR),c)
# define Tcl_UtfToWCharDString(a,b,c) (WCHAR *)Tcl_WinUtfToTChar(a,b,c)
# else
# define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString
# define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString
# endif
#endif
static unsigned char *
getByteArrayFromObj(
Tcl_Obj *objPtr,
size_t *lengthPtr
) {
int length;
unsigned char *result = Tcl_GetByteArrayFromObj(objPtr, &length);
#if TCL_MAJOR_VERSION > 8
if (sizeof(TCL_HASH_TYPE) > sizeof(int)) {
/* 64-bit and TIP #494 situation: */
*lengthPtr = *(TCL_HASH_TYPE *) objPtr->internalRep.twoPtrValue.ptr1;
} else
#endif
/* 32-bit or without TIP #494 */
*lengthPtr = (size_t) (unsigned) length;
return result;
}
#ifdef __cplusplus
extern "C" {
#endif
DLLEXPORT int Dde_Init(Tcl_Interp *interp);
DLLEXPORT int Dde_SafeInit(Tcl_Interp *interp);
#ifdef __cplusplus
}
#endif
/*
*----------------------------------------------------------------------
*
* Dde_Init --
*
* This function initializes the dde command.
|
| ︙ | ︙ | |||
155 156 157 158 159 160 161 |
*----------------------------------------------------------------------
*/
int
Dde_Init(
Tcl_Interp *interp)
{
| | | | 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 |
*----------------------------------------------------------------------
*/
int
Dde_Init(
Tcl_Interp *interp)
{
if (!Tcl_InitStubs(interp, "8.5", 0)) {
return TCL_ERROR;
}
Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL);
Tcl_CreateExitHandler(DdeExitProc, NULL);
return Tcl_PkgProvideEx(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION, NULL);
}
/*
*----------------------------------------------------------------------
*
* Dde_SafeInit --
*
|
| ︙ | ︙ | |||
231 232 233 234 235 236 237 |
* Make sure that the DDE server is there. This is done only once, add an
* exit handler tear it down.
*/
if (ddeInstance == 0) {
Tcl_MutexLock(&ddeMutex);
if (ddeInstance == 0) {
| | | | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 |
* Make sure that the DDE server is there. This is done only once, add an
* exit handler tear it down.
*/
if (ddeInstance == 0) {
Tcl_MutexLock(&ddeMutex);
if (ddeInstance == 0) {
if (DdeInitializeW(&ddeInstance, (PFNCALLBACK)(void *)DdeServerProc,
CBF_SKIP_REGISTRATIONS | CBF_SKIP_UNREGISTRATIONS
| CBF_FAIL_POKES, 0) != DMLERR_NO_ERROR) {
ddeInstance = 0;
}
}
Tcl_MutexUnlock(&ddeMutex);
}
if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
Tcl_MutexLock(&ddeMutex);
if ((ddeServiceGlobal == 0) && (nameFound != 0)) {
ddeIsServer = 1;
Tcl_CreateExitHandler(DdeExitProc, NULL);
ddeServiceGlobal = DdeCreateStringHandleW(ddeInstance,
TCL_DDE_SERVICE_NAME, CP_WINUNICODE);
DdeNameService(ddeInstance, ddeServiceGlobal, 0L, DNS_REGISTER);
} else {
ddeIsServer = 0;
}
Tcl_MutexUnlock(&ddeMutex);
}
|
| ︙ | ︙ | |||
279 280 281 282 283 284 285 | * "send" command is created in the application's interpreter. The * registration will be removed automatically if the interpreter is * deleted or the "send" command is removed. * *---------------------------------------------------------------------- */ | | | | | 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 |
* "send" command is created in the application's interpreter. The
* registration will be removed automatically if the interpreter is
* deleted or the "send" command is removed.
*
*----------------------------------------------------------------------
*/
static const WCHAR *
DdeSetServerName(
Tcl_Interp *interp,
const WCHAR *name, /* The name that will be used to refer to the
* interpreter in later "send" commands. Must
* be globally unique. */
int flags, /* DDE_FLAG_FORCE or 0 */
Tcl_Obj *handlerPtr) /* Name of the optional proc/command to handle
* incoming Dde eval's */
{
int suffix, offset;
RegisteredInterp *riPtr, *prevPtr;
Tcl_DString dString;
const WCHAR *actualName;
Tcl_Obj *srvListPtr = NULL, **srvPtrPtr = NULL;
int n, srvCount = 0, lastSuffix, r = TCL_OK;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* See if the application is already registered; if so, remove its current
* name from the registry. The deletion of the command will take care of
|
| ︙ | ︙ | |||
330 331 332 333 334 335 336 |
if (name == NULL) {
/*
* The name was NULL, so the caller is asking for the name of the
* current interp, but it doesn't have a name.
*/
| | | | | | | | | | > | | | | | 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 |
if (name == NULL) {
/*
* The name was NULL, so the caller is asking for the name of the
* current interp, but it doesn't have a name.
*/
return L"";
}
/*
* Get the list of currently registered Tcl interpreters by calling the
* internal implementation of the 'dde services' command.
*/
Tcl_DStringInit(&dString);
actualName = name;
if (!(flags & DDE_FLAG_FORCE)) {
r = DdeGetServicesList(interp, TCL_DDE_SERVICE_NAME, NULL);
if (r == TCL_OK) {
srvListPtr = Tcl_GetObjResult(interp);
}
if (r == TCL_OK) {
r = Tcl_ListObjGetElements(interp, srvListPtr, &srvCount,
&srvPtrPtr);
}
if (r != TCL_OK) {
Tcl_DStringInit(&dString);
OutputDebugStringW(Tcl_UtfToWCharDString(Tcl_GetString(Tcl_GetObjResult(interp)), -1, &dString));
Tcl_DStringFree(&dString);
return NULL;
}
/*
* Pick a name to use for the application. Use "name" if it's not
* already in use. Otherwise add a suffix such as " #2", trying larger
* and larger numbers until we eventually find one that is unique.
*/
offset = lastSuffix = 0;
suffix = 1;
while (suffix != lastSuffix) {
lastSuffix = suffix;
if (suffix > 1) {
if (suffix == 2) {
Tcl_DStringAppend(&dString, (char *)name, wcslen(name) * sizeof(WCHAR));
Tcl_DStringAppend(&dString, (char *)L" #", 2 * sizeof(WCHAR));
offset = Tcl_DStringLength(&dString);
Tcl_DStringSetLength(&dString, offset + sizeof(WCHAR) * TCL_INTEGER_SPACE);
actualName = (WCHAR *) Tcl_DStringValue(&dString);
}
_snwprintf((WCHAR *) (Tcl_DStringValue(&dString) + offset),
TCL_INTEGER_SPACE, L"%d", suffix);
}
/*
* See if the name is already in use, if so increment suffix.
*/
for (n = 0; n < srvCount; ++n) {
Tcl_Obj* namePtr;
Tcl_DString ds;
Tcl_ListObjIndex(interp, srvPtrPtr[n], 1, &namePtr);
Tcl_DStringInit(&ds);
Tcl_UtfToWCharDString(Tcl_GetString(namePtr), -1, &ds);
if (wcscmp(actualName, (WCHAR *)Tcl_DStringValue(&ds)) == 0) {
suffix++;
Tcl_DStringFree(&ds);
break;
}
Tcl_DStringFree(&ds);
}
}
}
/*
* We have found a unique name. Now add it to the registry.
*/
riPtr = (RegisteredInterp *) Tcl_Alloc(sizeof(RegisteredInterp));
riPtr->interp = interp;
riPtr->name = (WCHAR *) Tcl_Alloc((wcslen(actualName) + 1) * sizeof(WCHAR));
riPtr->nextPtr = tsdPtr->interpListPtr;
riPtr->handlerPtr = handlerPtr;
if (riPtr->handlerPtr != NULL) {
Tcl_IncrRefCount(riPtr->handlerPtr);
}
tsdPtr->interpListPtr = riPtr;
wcscpy(riPtr->name, actualName);
if (Tcl_IsSafe(interp)) {
Tcl_ExposeCommand(interp, "dde", "dde");
}
Tcl_CreateObjCommand(interp, "dde", DdeObjCmd,
riPtr, DeleteProc);
|
| ︙ | ︙ | |||
485 486 487 488 489 490 491 | * The interpreter given by riPtr is unregistered. * *---------------------------------------------------------------------- */ static void DeleteProc( | | < | 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 |
* The interpreter given by riPtr is unregistered.
*
*----------------------------------------------------------------------
*/
static void
DeleteProc(
void *clientData) /* The interp we are deleting. */
{
RegisteredInterp *riPtr = (RegisteredInterp *) clientData;
RegisteredInterp *searchPtr, *prevPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
for (searchPtr = tsdPtr->interpListPtr, prevPtr = NULL;
(searchPtr != NULL) && (searchPtr != riPtr);
|
| ︙ | ︙ | |||
623 624 625 626 627 628 629 |
* performing. */
UINT uFmt, /* The format that data is sent or received */
HCONV hConv, /* The conversation associated with the
* current transaction. */
HSZ ddeTopic, HSZ ddeItem, /* String handles. Transaction-type
* dependent. */
HDDEDATA hData, /* DDE data. Transaction-type dependent. */
| | | > > | | | | | | | | | | | 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 |
* performing. */
UINT uFmt, /* The format that data is sent or received */
HCONV hConv, /* The conversation associated with the
* current transaction. */
HSZ ddeTopic, HSZ ddeItem, /* String handles. Transaction-type
* dependent. */
HDDEDATA hData, /* DDE data. Transaction-type dependent. */
DWORD unused1, DWORD unused2)
/* Transaction-dependent data. */
{
Tcl_DString dString;
size_t len;
DWORD dlen;
WCHAR *utilString;
Tcl_Obj *ddeObjectPtr;
HDDEDATA ddeReturn = NULL;
RegisteredInterp *riPtr;
Conversation *convPtr, *prevConvPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
(void)unused1;
(void)unused2;
switch(uType) {
case XTYP_CONNECT:
/*
* Dde is trying to initialize a conversation with us. Check and make
* sure we have a valid topic.
*/
len = DdeQueryStringW(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE);
Tcl_DStringInit(&dString);
Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1);
utilString = (WCHAR *) Tcl_DStringValue(&dString);
DdeQueryStringW(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
CP_WINUNICODE);
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
if (_wcsicmp(utilString, riPtr->name) == 0) {
Tcl_DStringFree(&dString);
return (HDDEDATA) TRUE;
}
}
Tcl_DStringFree(&dString);
return (HDDEDATA) FALSE;
case XTYP_CONNECT_CONFIRM:
/*
* Dde has decided that we can connect, so it gives us a conversation
* handle. We need to keep track of it so we know which execution
* result to return in an XTYP_REQUEST.
*/
len = DdeQueryStringW(ddeInstance, ddeTopic, NULL, 0, CP_WINUNICODE);
Tcl_DStringInit(&dString);
Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1);
utilString = (WCHAR *) Tcl_DStringValue(&dString);
DdeQueryStringW(ddeInstance, ddeTopic, utilString, (DWORD) len + 1,
CP_WINUNICODE);
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
if (_wcsicmp(riPtr->name, utilString) == 0) {
convPtr = (Conversation *) Tcl_Alloc(sizeof(Conversation));
convPtr->nextPtr = tsdPtr->currentConversations;
convPtr->returnPackagePtr = NULL;
convPtr->hConv = hConv;
convPtr->riPtr = riPtr;
tsdPtr->currentConversations = convPtr;
break;
|
| ︙ | ︙ | |||
736 737 738 739 740 741 742 |
*/
}
if (convPtr != NULL) {
Tcl_DString dsBuf;
char *returnString;
| | | | | | > | | > | > | | | 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 |
*/
}
if (convPtr != NULL) {
Tcl_DString dsBuf;
char *returnString;
len = DdeQueryStringW(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE);
Tcl_DStringInit(&dString);
Tcl_DStringInit(&dsBuf);
Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1);
utilString = (WCHAR *) Tcl_DStringValue(&dString);
DdeQueryStringW(ddeInstance, ddeItem, utilString, (DWORD) len + 1,
CP_WINUNICODE);
if (_wcsicmp(utilString, TCL_DDE_EXECUTE_RESULT) == 0) {
returnString =
Tcl_GetString(convPtr->returnPackagePtr);
len = convPtr->returnPackagePtr->length;
if (uFmt != CF_TEXT) {
Tcl_DStringInit(&dsBuf);
Tcl_UtfToWCharDString(returnString, len, &dsBuf);
returnString = Tcl_DStringValue(&dsBuf);
len = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR) - 1;
}
ddeReturn = DdeCreateDataHandle(ddeInstance, (BYTE *)returnString,
(DWORD) len+1, 0, ddeItem, uFmt, 0);
} else {
if (Tcl_IsSafe(convPtr->riPtr->interp)) {
ddeReturn = NULL;
} else {
Tcl_DString ds;
Tcl_Obj *variableObjPtr;
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds);
variableObjPtr = Tcl_GetVar2Ex(
convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL,
TCL_GLOBAL_ONLY);
if (variableObjPtr != NULL) {
returnString = Tcl_GetString(variableObjPtr);
len = variableObjPtr->length;
if (uFmt != CF_TEXT) {
Tcl_DStringInit(&dsBuf);
Tcl_UtfToWCharDString(returnString, len, &dsBuf);
returnString = Tcl_DStringValue(&dsBuf);
len = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR) - 1;
}
ddeReturn = DdeCreateDataHandle(ddeInstance,
(BYTE *)returnString, (DWORD) len+1, 0, ddeItem,
uFmt, 0);
} else {
ddeReturn = NULL;
}
|
| ︙ | ︙ | |||
813 814 815 816 817 818 819 |
if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) {
Tcl_DString ds, ds2;
Tcl_Obj *variableObjPtr;
DWORD len2;
Tcl_DStringInit(&dString);
Tcl_DStringInit(&ds2);
| | | | | > | | > | | | 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 |
if (convPtr && !Tcl_IsSafe(convPtr->riPtr->interp)) {
Tcl_DString ds, ds2;
Tcl_Obj *variableObjPtr;
DWORD len2;
Tcl_DStringInit(&dString);
Tcl_DStringInit(&ds2);
len = DdeQueryStringW(ddeInstance, ddeItem, NULL, 0, CP_WINUNICODE);
Tcl_DStringSetLength(&dString, (len + 1) * sizeof(WCHAR) - 1);
utilString = (WCHAR *) Tcl_DStringValue(&dString);
DdeQueryStringW(ddeInstance, ddeItem, utilString, (DWORD) len + 1,
CP_WINUNICODE);
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds);
utilString = (WCHAR *) DdeAccessData(hData, &len2);
len = len2;
if (uFmt != CF_TEXT) {
Tcl_DStringInit(&ds2);
Tcl_WCharToUtfDString(utilString, wcslen(utilString), &ds2);
utilString = (WCHAR *) Tcl_DStringValue(&ds2);
}
variableObjPtr = Tcl_NewStringObj((char *)utilString, -1);
Tcl_SetVar2Ex(convPtr->riPtr->interp, Tcl_DStringValue(&ds), NULL,
variableObjPtr, TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds2);
|
| ︙ | ︙ | |||
858 859 860 861 862 863 864 |
*/
}
if (convPtr == NULL) {
return (HDDEDATA) DDE_FNOTPROCESSED;
}
| | > | | 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 |
*/
}
if (convPtr == NULL) {
return (HDDEDATA) DDE_FNOTPROCESSED;
}
utilString = (WCHAR *) DdeAccessData(hData, &dlen);
string = (char *) utilString;
if (!dlen) {
/* Empty binary array. */
ddeObjectPtr = Tcl_NewObj();
} else if ((dlen & 1) || utilString[(dlen>>1)-1]) {
/* Cannot be unicode, so assume utf-8 */
if (!string[dlen-1]) {
dlen--;
}
ddeObjectPtr = Tcl_NewStringObj(string, dlen);
} else {
/* unicode */
Tcl_DString dsBuf;
Tcl_DStringInit(&dsBuf);
Tcl_WCharToUtfDString(utilString, (dlen>>1) - 1, &dsBuf);
ddeObjectPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
Tcl_DStringLength(&dsBuf));
Tcl_DStringFree(&dsBuf);
}
Tcl_IncrRefCount(ddeObjectPtr);
DdeUnaccessData(hData);
if (convPtr->returnPackagePtr != NULL) {
|
| ︙ | ︙ | |||
928 929 930 931 932 933 934 |
numItems = i;
ddeReturn = DdeCreateDataHandle(ddeInstance, NULL,
(numItems + 1) * sizeof(HSZPAIR), 0, 0, 0, 0);
returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, &dlen);
len = dlen;
for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems;
i++, riPtr = riPtr->nextPtr) {
| | | | 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 |
numItems = i;
ddeReturn = DdeCreateDataHandle(ddeInstance, NULL,
(numItems + 1) * sizeof(HSZPAIR), 0, 0, 0, 0);
returnPtr = (HSZPAIR *) DdeAccessData(ddeReturn, &dlen);
len = dlen;
for (i = 0, riPtr = tsdPtr->interpListPtr; i < numItems;
i++, riPtr = riPtr->nextPtr) {
returnPtr[i].hszSvc = DdeCreateStringHandleW(ddeInstance,
TCL_DDE_SERVICE_NAME, CP_WINUNICODE);
returnPtr[i].hszTopic = DdeCreateStringHandleW(ddeInstance,
riPtr->name, CP_WINUNICODE);
}
returnPtr[i].hszSvc = NULL;
returnPtr[i].hszTopic = NULL;
DdeUnaccessData(ddeReturn);
return ddeReturn;
}
|
| ︙ | ︙ | |||
962 963 964 965 966 967 968 | * The DDE server is deleted. * *---------------------------------------------------------------------- */ static void DdeExitProc( | | > | 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 |
* The DDE server is deleted.
*
*----------------------------------------------------------------------
*/
static void
DdeExitProc(
void *dummy) /* Not used. */
{
(void)dummy;
DdeNameService(ddeInstance, NULL, 0, DNS_UNREGISTER);
DdeUninitialize(ddeInstance);
ddeInstance = 0;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
989 990 991 992 993 994 995 |
*
*----------------------------------------------------------------------
*/
static int
MakeDdeConnection(
Tcl_Interp *interp, /* Used to report errors. */
| | | | | > | 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 |
*
*----------------------------------------------------------------------
*/
static int
MakeDdeConnection(
Tcl_Interp *interp, /* Used to report errors. */
const WCHAR *name, /* The connection to use. */
HCONV *ddeConvPtr)
{
HSZ ddeTopic, ddeService;
HCONV ddeConv;
ddeService = DdeCreateStringHandleW(ddeInstance, TCL_DDE_SERVICE_NAME, CP_WINUNICODE);
ddeTopic = DdeCreateStringHandleW(ddeInstance, name, CP_WINUNICODE);
ddeConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
DdeFreeStringHandle(ddeInstance, ddeTopic);
if (ddeConv == (HCONV) NULL) {
if (interp != NULL) {
Tcl_DString dString;
Tcl_DStringInit(&dString);
Tcl_WCharToUtfDString(name, wcslen(name), &dString);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"no registered server named \"%s\"", Tcl_DStringValue(&dString)));
Tcl_DStringFree(&dString);
Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL);
}
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1043 1044 1045 1046 1047 1048 1049 |
*----------------------------------------------------------------------
*/
static int
DdeCreateClient(
DdeEnumServices *es)
{
| | | | | | | | | | | | | | > | | > | 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 |
*----------------------------------------------------------------------
*/
static int
DdeCreateClient(
DdeEnumServices *es)
{
WNDCLASSEXW wc;
static const WCHAR *szDdeClientClassName = L"TclEval client class";
static const WCHAR *szDdeClientWindowName = L"TclEval client window";
memset(&wc, 0, sizeof(wc));
wc.cbSize = sizeof(wc);
wc.lpfnWndProc = DdeClientWindowProc;
wc.lpszClassName = szDdeClientClassName;
wc.cbWndExtra = sizeof(DdeEnumServices *);
/*
* Register and create the callback window.
*/
RegisterClassExW(&wc);
es->hwnd = CreateWindowExW(0, szDdeClientClassName, szDdeClientWindowName,
WS_POPUP, 0, 0, 0, 0, NULL, NULL, NULL, (LPVOID)es);
return TCL_OK;
}
static LRESULT CALLBACK
DdeClientWindowProc(
HWND hwnd, /* What window is the message for */
UINT uMsg, /* The type of message received */
WPARAM wParam,
LPARAM lParam) /* (Potentially) our local handle */
{
switch (uMsg) {
case WM_CREATE: {
LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam;
DdeEnumServices *es =
(DdeEnumServices *) lpcs->lpCreateParams;
#ifdef _WIN64
SetWindowLongPtrW(hwnd, GWLP_USERDATA, (LONG_PTR) es);
#else
SetWindowLongW(hwnd, GWL_USERDATA, (LONG) es);
#endif
return (LRESULT) 0L;
}
case WM_DDE_ACK:
return DdeServicesOnAck(hwnd, wParam, lParam);
default:
return DefWindowProcW(hwnd, uMsg, wParam, lParam);
}
}
static LRESULT
DdeServicesOnAck(
HWND hwnd,
WPARAM wParam,
LPARAM lParam)
{
HWND hwndRemote = (HWND)wParam;
ATOM service = (ATOM)LOWORD(lParam);
ATOM topic = (ATOM)HIWORD(lParam);
DdeEnumServices *es;
WCHAR sz[255];
Tcl_DString dString;
#ifdef _WIN64
es = (DdeEnumServices *) GetWindowLongPtrW(hwnd, GWLP_USERDATA);
#else
es = (DdeEnumServices *) GetWindowLongW(hwnd, GWL_USERDATA);
#endif
if (((es->service == (ATOM)0) || (es->service == service))
&& ((es->topic == (ATOM)0) || (es->topic == topic))) {
Tcl_Obj *matchPtr = Tcl_NewListObj(0, NULL);
Tcl_Obj *resultPtr = Tcl_GetObjResult(es->interp);
GlobalGetAtomNameW(service, sz, 255);
Tcl_DStringInit(&dString);
Tcl_WCharToUtfDString(sz, wcslen(sz), &dString);
Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1));
Tcl_DStringFree(&dString);
GlobalGetAtomNameW(topic, sz, 255);
Tcl_DStringInit(&dString);
Tcl_WCharToUtfDString(sz, wcslen(sz), &dString);
Tcl_ListObjAppendElement(NULL, matchPtr, Tcl_NewStringObj(Tcl_DStringValue(&dString), -1));
Tcl_DStringFree(&dString);
/*
* Adding the hwnd as a third list element provides a unique
* identifier in the case of multiple servers with the name
* application and topic names.
|
| ︙ | ︙ | |||
1147 1148 1149 1150 1151 1152 1153 |
}
}
/*
* Tell the server we are no longer interested.
*/
| | | | | | | | 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 |
}
}
/*
* Tell the server we are no longer interested.
*/
PostMessageW(hwndRemote, WM_DDE_TERMINATE, (WPARAM)hwnd, 0L);
return 0L;
}
static BOOL CALLBACK
DdeEnumWindowsCallback(
HWND hwndTarget,
LPARAM lParam)
{
DWORD_PTR dwResult = 0;
DdeEnumServices *es = (DdeEnumServices *) lParam;
SendMessageTimeoutW(hwndTarget, WM_DDE_INITIATE, (WPARAM)es->hwnd,
MAKELONG(es->service, es->topic), SMTO_ABORTIFHUNG, 1000,
&dwResult);
return TRUE;
}
static int
DdeGetServicesList(
Tcl_Interp *interp,
const WCHAR *serviceName,
const WCHAR *topicName)
{
DdeEnumServices es;
es.interp = interp;
es.result = TCL_OK;
es.service = (serviceName == NULL)
? (ATOM)0 : GlobalAddAtomW(serviceName);
es.topic = (topicName == NULL) ? (ATOM)0 : GlobalAddAtomW(topicName);
Tcl_ResetResult(interp); /* our list is to be appended to result. */
DdeCreateClient(&es);
EnumWindows(DdeEnumWindowsCallback, (LPARAM)&es);
if (IsWindow(es.hwnd)) {
DestroyWindow(es.hwnd);
|
| ︙ | ︙ | |||
1261 1262 1263 1264 1265 1266 1267 | * See the user documentation. * *---------------------------------------------------------------------- */ static int DdeObjCmd( | | | 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 |
* See the user documentation.
*
*----------------------------------------------------------------------
*/
static int
DdeObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* The interp we are sending from */
int objc, /* Number of arguments */
Tcl_Obj *const *objv) /* The arguments */
{
static const char *const ddeCommands[] = {
"servername", "execute", "poke", "request", "services", "eval",
(char *) NULL};
|
| ︙ | ︙ | |||
1298 1299 1300 1301 1302 1303 1304 |
int index, i, argIndex;
size_t length;
int flags = 0, result = TCL_OK, firstArg = 0;
HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL;
HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn;
HCONV hConv = NULL;
| | > | 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 |
int index, i, argIndex;
size_t length;
int flags = 0, result = TCL_OK, firstArg = 0;
HSZ ddeService = NULL, ddeTopic = NULL, ddeItem = NULL, ddeCookie = NULL;
HDDEDATA ddeData = NULL, ddeItemData = NULL, ddeReturn;
HCONV hConv = NULL;
const WCHAR *serviceName = NULL, *topicName = NULL;
const char *string;
DWORD ddeResult;
Tcl_Obj *objPtr, *handlerPtr = NULL;
Tcl_DString serviceBuf, topicBuf, itemBuf;
(void)dummy;
/*
* Initialize DDE server/client
*/
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "command ?arg ...?");
|
| ︙ | ︙ | |||
1458 1459 1460 1461 1462 1463 1464 |
Initialize();
if (firstArg != 1) {
const char *src = Tcl_GetString(objv[firstArg]);
length = objv[firstArg]->length;
| > | | | | > | | | > | | 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 |
Initialize();
if (firstArg != 1) {
const char *src = Tcl_GetString(objv[firstArg]);
length = objv[firstArg]->length;
Tcl_DStringInit(&serviceBuf);
Tcl_UtfToWCharDString(src, length, &serviceBuf);
serviceName = (WCHAR *) Tcl_DStringValue(&serviceBuf);
length = Tcl_DStringLength(&serviceBuf) / sizeof(WCHAR);
} else {
length = 0;
}
if (length == 0) {
serviceName = NULL;
} else if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
ddeService = DdeCreateStringHandleW(ddeInstance, serviceName,
CP_WINUNICODE);
}
if ((index != DDE_SERVERNAME) && (index != DDE_EVAL)) {
const char *src = Tcl_GetString(objv[firstArg + 1]);
length = objv[firstArg + 1]->length;
Tcl_DStringInit(&topicBuf);
topicName = Tcl_UtfToWCharDString(src, length, &topicBuf);
length = Tcl_DStringLength(&topicBuf) / sizeof(WCHAR);
if (length == 0) {
topicName = NULL;
} else {
ddeTopic = DdeCreateStringHandleW(ddeInstance, topicName,
CP_WINUNICODE);
}
}
switch ((enum DdeSubcommands) index) {
case DDE_SERVERNAME:
serviceName = DdeSetServerName(interp, serviceName, flags,
handlerPtr);
if (serviceName != NULL) {
Tcl_DString dsBuf;
Tcl_DStringInit(&dsBuf);
Tcl_WCharToUtfDString(serviceName, wcslen(serviceName), &dsBuf);
Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
Tcl_DStringLength(&dsBuf)));
Tcl_DStringFree(&dsBuf);
} else {
Tcl_ResetResult(interp);
}
break;
|
| ︙ | ︙ | |||
1516 1517 1518 1519 1520 1521 1522 |
dataString =
getByteArrayFromObj(objv[firstArg + 2], &dataLength);
} else {
const char *src;
src = Tcl_GetString(objv[firstArg + 2]);
dataLength = objv[firstArg + 2]->length;
| > | | | | 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 |
dataString =
getByteArrayFromObj(objv[firstArg + 2], &dataLength);
} else {
const char *src;
src = Tcl_GetString(objv[firstArg + 2]);
dataLength = objv[firstArg + 2]->length;
Tcl_DStringInit(&dsBuf);
dataString =
Tcl_UtfToWCharDString(src, dataLength, &dsBuf);
dataLength = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR);
}
if (dataLength + 1 < 2) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot execute null data", -1));
Tcl_DStringFree(&dsBuf);
Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
|
| ︙ | ︙ | |||
1564 1565 1566 1567 1568 1569 1570 |
SetDdeError(interp);
result = TCL_ERROR;
}
Tcl_DStringFree(&dsBuf);
break;
}
case DDE_REQUEST: {
| | > | | | | | | | > | | > | | > | | | | 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 |
SetDdeError(interp);
result = TCL_ERROR;
}
Tcl_DStringFree(&dsBuf);
break;
}
case DDE_REQUEST: {
const WCHAR *itemString;
const char *src;
src = Tcl_GetString(objv[firstArg + 2]);
length = objv[firstArg + 2]->length;
Tcl_DStringInit(&itemBuf);
itemString = Tcl_UtfToWCharDString(src, length, &itemBuf);
length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR);
if (length == 0) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot request value of null data", -1));
Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
result = TCL_ERROR;
goto cleanup;
}
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
DdeFreeStringHandle(ddeInstance, ddeTopic);
if (hConv == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
} else {
Tcl_Obj *returnObjPtr;
ddeItem = DdeCreateStringHandleW(ddeInstance, itemString,
CP_WINUNICODE);
if (ddeItem != NULL) {
ddeData = DdeClientTransaction(NULL, 0, hConv, ddeItem,
(flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_REQUEST, 5000, NULL);
if (ddeData == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
} else {
DWORD tmp;
WCHAR *dataString = (WCHAR *) DdeAccessData(ddeData, &tmp);
if (flags & DDE_FLAG_BINARY) {
returnObjPtr =
Tcl_NewByteArrayObj((BYTE *) dataString, tmp);
} else {
Tcl_DString dsBuf;
if ((tmp >= sizeof(WCHAR))
&& !dataString[tmp / sizeof(WCHAR) - 1]) {
tmp -= sizeof(WCHAR);
}
Tcl_DStringInit(&dsBuf);
Tcl_WCharToUtfDString(dataString, tmp>>1, &dsBuf);
returnObjPtr =
Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
Tcl_DStringLength(&dsBuf));
Tcl_DStringFree(&dsBuf);
}
DdeUnaccessData(ddeData);
DdeFreeDataHandle(ddeData);
Tcl_SetObjResult(interp, returnObjPtr);
}
} else {
SetDdeError(interp);
result = TCL_ERROR;
}
}
break;
}
case DDE_POKE: {
Tcl_DString dsBuf;
const WCHAR *itemString;
BYTE *dataString;
const char *src;
src = Tcl_GetString(objv[firstArg + 2]);
length = objv[firstArg + 2]->length;
Tcl_DStringInit(&itemBuf);
itemString = Tcl_UtfToWCharDString(src, length, &itemBuf);
length = Tcl_DStringLength(&itemBuf) / sizeof(WCHAR);
if (length == 0) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("cannot have a null item", -1));
Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
result = TCL_ERROR;
goto cleanup;
}
Tcl_DStringInit(&dsBuf);
if (flags & DDE_FLAG_BINARY) {
dataString = (BYTE *)
getByteArrayFromObj(objv[firstArg + 3], &length);
} else {
const char *data =
Tcl_GetString(objv[firstArg + 3]);
length = objv[firstArg + 3]->length;
Tcl_DStringInit(&dsBuf);
dataString = (BYTE *)
Tcl_UtfToWCharDString(data, length, &dsBuf);
length = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR);
}
hConv = DdeConnect(ddeInstance, ddeService, ddeTopic, NULL);
DdeFreeStringHandle(ddeInstance, ddeService);
DdeFreeStringHandle(ddeInstance, ddeTopic);
if (hConv == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
} else {
ddeItem = DdeCreateStringHandleW(ddeInstance, itemString,
CP_WINUNICODE);
if (ddeItem != NULL) {
ddeData = DdeClientTransaction(dataString, (DWORD) length,
hConv, ddeItem, (flags & DDE_FLAG_BINARY) ? CF_TEXT : CF_UNICODETEXT, XTYP_POKE, 5000, NULL);
if (ddeData == NULL) {
SetDdeError(interp);
result = TCL_ERROR;
|
| ︙ | ︙ | |||
1713 1714 1715 1716 1717 1718 1719 |
* producing a bytecode structure that refers to other objects owned
* by the target interp. If the target interp is then deleted, the
* bytecode structure would be referring to deallocated objects.
*/
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
| | | 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 |
* producing a bytecode structure that refers to other objects owned
* by the target interp. If the target interp is then deleted, the
* bytecode structure would be referring to deallocated objects.
*/
for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
riPtr = riPtr->nextPtr) {
if (_wcsicmp(serviceName, riPtr->name) == 0) {
break;
}
}
if (riPtr != NULL) {
Tcl_Interp *sendInterp;
|
| ︙ | ︙ | |||
1816 1817 1818 1819 1820 1821 1822 | result = TCL_ERROR; goto cleanup; } objPtr = Tcl_ConcatObj(objc, objv); string = Tcl_GetString(objPtr); length = objPtr->length; | > | | | | | | | > | | 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 |
result = TCL_ERROR;
goto cleanup;
}
objPtr = Tcl_ConcatObj(objc, objv);
string = Tcl_GetString(objPtr);
length = objPtr->length;
Tcl_DStringInit(&dsBuf);
Tcl_UtfToWCharDString(string, length, &dsBuf);
string = Tcl_DStringValue(&dsBuf);
length = Tcl_DStringLength(&dsBuf) + sizeof(WCHAR);
ddeItemData = DdeCreateDataHandle(ddeInstance, (BYTE *) string,
(DWORD) length, 0, 0, CF_UNICODETEXT, 0);
Tcl_DStringFree(&dsBuf);
if (flags & DDE_FLAG_ASYNC) {
ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
0xFFFFFFFF, hConv, 0,
CF_UNICODETEXT, XTYP_EXECUTE, TIMEOUT_ASYNC, &ddeResult);
DdeAbandonTransaction(ddeInstance, hConv, ddeResult);
} else {
ddeData = DdeClientTransaction((LPBYTE) ddeItemData,
0xFFFFFFFF, hConv, 0,
CF_UNICODETEXT, XTYP_EXECUTE, 30000, NULL);
if (ddeData != 0) {
ddeCookie = DdeCreateStringHandleW(ddeInstance,
TCL_DDE_EXECUTE_RESULT, CP_WINUNICODE);
ddeData = DdeClientTransaction(NULL, 0, hConv, ddeCookie,
CF_UNICODETEXT, XTYP_REQUEST, 30000, NULL);
}
}
Tcl_DecrRefCount(objPtr);
if (ddeData == 0) {
SetDdeError(interp);
result = TCL_ERROR;
goto cleanup;
}
if (!(flags & DDE_FLAG_ASYNC)) {
Tcl_Obj *resultPtr;
WCHAR *ddeDataString;
/*
* The return handle has a two or four element list in it. The
* first element is the return code (TCL_OK, TCL_ERROR, etc.).
* The second is the result of the script. If the return code
* is TCL_ERROR, then the third element is the value of the
* variable "errorCode", and the fourth is the value of the
* variable "errorInfo".
*/
length = DdeGetData(ddeData, NULL, 0, 0);
ddeDataString = (WCHAR *) Tcl_Alloc(length);
DdeGetData(ddeData, (BYTE *) ddeDataString, (DWORD) length, 0);
if (length > sizeof(WCHAR)) {
length -= sizeof(WCHAR);
}
Tcl_DStringInit(&dsBuf);
Tcl_WCharToUtfDString(ddeDataString, length>>1, &dsBuf);
resultPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsBuf),
Tcl_DStringLength(&dsBuf));
Tcl_DStringFree(&dsBuf);
Tcl_Free((char *) ddeDataString);
if (Tcl_ListObjIndex(NULL, resultPtr, 0, &objPtr) != TCL_OK) {
Tcl_DecrRefCount(resultPtr);
|
| ︙ | ︙ |
Changes to win/tclWinError.c.
| ︙ | ︙ | |||
377 378 379 380 381 382 383 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | > > > > > > | 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 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 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
TCL_NORETURN void
tclWinDebugPanic(
const char *format, ...)
{
#define TCL_MAX_WARN_LEN 1024
va_list argList;
va_start(argList, format);
if (IsDebuggerPresent()) {
WCHAR msgString[TCL_MAX_WARN_LEN];
char buf[TCL_MAX_WARN_LEN * 3];
vsnprintf(buf, sizeof(buf), format, argList);
msgString[TCL_MAX_WARN_LEN-1] = '\0';
MultiByteToWideChar(CP_UTF8, 0, buf, -1, msgString, TCL_MAX_WARN_LEN);
/*
* Truncate MessageBox string if it is too long to not overflow the buffer.
*/
if (msgString[TCL_MAX_WARN_LEN-1] != '\0') {
memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR));
}
OutputDebugStringW(msgString);
} else {
if (!isatty(fileno(stderr))) {
fprintf(stderr, "\xef\xbb\xbf");
}
vfprintf(stderr, format, argList);
fprintf(stderr, "\n");
fflush(stderr);
}
# if defined(__GNUC__)
__builtin_trap();
# else
DebugBreak();
# endif
abort();
}
#endif
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
|
| ︙ | ︙ |
Changes to win/tclWinFCmd.c.
| ︙ | ︙ | |||
141 142 143 144 145 146 147 |
*/
int
TclpObjRenameFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
| | | | 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 |
*/
int
TclpObjRenameFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
return DoRenameFile((const WCHAR *)Tcl_FSGetNativePath(srcPathPtr),
(const WCHAR *)Tcl_FSGetNativePath(destPathPtr));
}
static int
DoRenameFile(
const WCHAR *nativeSrc, /* Pathname of file or dir to be renamed
* (native). */
const WCHAR *nativeDst) /* New pathname for file or directory
|
| ︙ | ︙ | |||
200 201 202 203 204 205 206 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ | | | | | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ "movl %%esp, 0xC(%%edx)" "\n\t" /* esp */ "movl $0, 0x10(%%edx)" "\n\t" /* status */ /* * Link the TCLEXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" /* * Call MoveFileW(nativeSrc, nativeDst) */ "pushl %%ebx" "\n\t" "pushl %%ecx" "\n\t" "movl %[moveFileW], %%eax" "\n\t" "call *%%eax" "\n\t" /* * Come here on normal exit. Recover the TCLEXCEPTION_REGISTRATION and * put the status return from MoveFile into it. */ |
| ︙ | ︙ | |||
241 242 243 244 245 246 247 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" | | | | | | | | | | | 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 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 |
/*
* Come here however we exited. Restore context from the
* TCLEXCEPTION_REGISTRATION in case the stack is unbalanced.
*/
"2:" "\t"
"movl 0xC(%%edx), %%esp" "\n\t"
"movl 0x8(%%edx), %%ebp" "\n\t"
"movl 0x0(%%edx), %%eax" "\n\t"
"movl %%eax, %%fs:0" "\n\t"
:
/* No outputs */
:
[registration] "m" (registration),
[nativeDst] "m" (nativeDst),
[nativeSrc] "m" (nativeSrc),
[moveFileW] "r" (MoveFileW)
:
"%eax", "%ebx", "%ecx", "%edx", "memory"
);
if (registration.status != FALSE) {
retval = TCL_OK;
}
#else
#ifndef HAVE_NO_SEH
__try {
#endif
if ((*MoveFileW)(nativeSrc, nativeDst) != FALSE) {
retval = TCL_OK;
}
#ifndef HAVE_NO_SEH
} __except (EXCEPTION_EXECUTE_HANDLER) {}
#endif
#endif
if (retval != -1) {
return retval;
}
TclWinConvertError(GetLastError());
srcAttr = GetFileAttributesW(nativeSrc);
dstAttr = GetFileAttributesW(nativeDst);
if (srcAttr == 0xFFFFFFFF) {
if (GetFullPathNameW(nativeSrc, 0, NULL,
NULL) >= MAX_PATH) {
errno = ENAMETOOLONG;
return TCL_ERROR;
}
srcAttr = 0;
}
if (dstAttr == 0xFFFFFFFF) {
if (GetFullPathNameW(nativeDst, 0, NULL,
NULL) >= MAX_PATH) {
errno = ENAMETOOLONG;
return TCL_ERROR;
}
dstAttr = 0;
}
|
| ︙ | ︙ | |||
311 312 313 314 315 316 317 | const char **srcArgv, **dstArgv; int size, srcArgc, dstArgc; WCHAR nativeSrcPath[MAX_PATH]; WCHAR nativeDstPath[MAX_PATH]; Tcl_DString srcString, dstString; const char *src, *dst; | | | | | > > | | | 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 |
const char **srcArgv, **dstArgv;
int size, srcArgc, dstArgc;
WCHAR nativeSrcPath[MAX_PATH];
WCHAR nativeDstPath[MAX_PATH];
Tcl_DString srcString, dstString;
const char *src, *dst;
size = GetFullPathNameW(nativeSrc, MAX_PATH,
nativeSrcPath, &nativeSrcRest);
if ((size == 0) || (size > MAX_PATH)) {
return TCL_ERROR;
}
size = GetFullPathNameW(nativeDst, MAX_PATH,
nativeDstPath, &nativeDstRest);
if ((size == 0) || (size > MAX_PATH)) {
return TCL_ERROR;
}
CharLowerW(nativeSrcPath);
CharLowerW(nativeDstPath);
Tcl_DStringInit(&srcString);
Tcl_DStringInit(&dstString);
src = Tcl_WCharToUtfDString(nativeSrcPath, -1, &srcString);
dst = Tcl_WCharToUtfDString(nativeDstPath, -1, &dstString);
/*
* Check whether the destination path is actually inside the
* source path. This is true if the prefix matches, and the next
* character is either end-of-string or a directory separator
*/
|
| ︙ | ︙ | |||
372 373 374 375 376 377 378 | * The MoveFile system call already handles the case of moving * a file between filesystems. */ Tcl_SetErrno(EXDEV); } | | | | 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 | * The MoveFile system call already handles the case of moving * a file between filesystems. */ Tcl_SetErrno(EXDEV); } ckfree(srcArgv); ckfree(dstArgv); } /* * Other types of access failure is that dst is a read-only * filesystem, that an open file referred to src or dest, or that src * or dest specified the current working directory on the current * filesystem. EACCES is returned for those cases. |
| ︙ | ︙ | |||
404 405 406 407 408 409 410 |
if (DoRemoveJustDirectory(nativeDst, 0, NULL) == TCL_OK) {
/*
* Now that that empty directory is gone, we can try
* renaming again. If that fails, we'll put this empty
* directory back, for completeness.
*/
| | | | | 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 |
if (DoRemoveJustDirectory(nativeDst, 0, NULL) == TCL_OK) {
/*
* Now that that empty directory is gone, we can try
* renaming again. If that fails, we'll put this empty
* directory back, for completeness.
*/
if (MoveFileW(nativeSrc,
nativeDst) != FALSE) {
return TCL_OK;
}
/*
* Some new error has occurred. Don't know what it could
* be, but report this one.
*/
TclWinConvertError(GetLastError());
CreateDirectoryW(nativeDst, NULL);
SetFileAttributesW(nativeDst, dstAttr);
if (Tcl_GetErrno() == EACCES) {
/*
* Decode the EACCES to a more meaningful error.
*/
goto decode;
}
|
| ︙ | ︙ | |||
445 446 447 448 449 450 451 | * back to old name. */ WCHAR *nativeRest, *nativeTmp, *nativePrefix; int result, size; WCHAR tempBuf[MAX_PATH]; | | | | | | | | | | | | | 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 |
* back to old name.
*/
WCHAR *nativeRest, *nativeTmp, *nativePrefix;
int result, size;
WCHAR tempBuf[MAX_PATH];
size = GetFullPathNameW(nativeDst, MAX_PATH,
tempBuf, &nativeRest);
if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) {
return TCL_ERROR;
}
nativeTmp = (WCHAR *) tempBuf;
nativeRest[0] = '\0';
result = TCL_ERROR;
nativePrefix = (WCHAR *)L"tclr";
if (GetTempFileNameW(nativeTmp, nativePrefix,
0, tempBuf) != 0) {
/*
* Strictly speaking, need the following DeleteFile and
* MoveFile to be joined as an atomic operation so no
* other app comes along in the meantime and creates the
* same temp file.
*/
nativeTmp = tempBuf;
DeleteFileW(nativeTmp);
if (MoveFileW(nativeDst, nativeTmp) != FALSE) {
if (MoveFileW(nativeSrc, nativeDst) != FALSE) {
SetFileAttributesW(nativeTmp, FILE_ATTRIBUTE_NORMAL);
DeleteFileW(nativeTmp);
return TCL_OK;
} else {
DeleteFileW(nativeDst);
MoveFileW(nativeTmp, nativeDst);
}
}
/*
* Can't backup dst file or move src file. Return that
* error. Could happen if an open file refers to dst.
*/
|
| ︙ | ︙ | |||
530 531 532 533 534 535 536 |
*/
int
TclpObjCopyFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
| | | | 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 |
*/
int
TclpObjCopyFile(
Tcl_Obj *srcPathPtr,
Tcl_Obj *destPathPtr)
{
return DoCopyFile((const WCHAR *)Tcl_FSGetNativePath(srcPathPtr),
(const WCHAR *)Tcl_FSGetNativePath(destPathPtr));
}
static int
DoCopyFile(
const WCHAR *nativeSrc, /* Pathname of file to be copied (native). */
const WCHAR *nativeDst) /* Pathname of file to copy to (native). */
{
|
| ︙ | ︙ | |||
587 588 589 590 591 592 593 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ | | | | | 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 | "leal %[registration], %%edx" "\n\t" "movl %%fs:0, %%eax" "\n\t" "movl %%eax, 0x0(%%edx)" "\n\t" /* link */ "leal 1f, %%eax" "\n\t" "movl %%eax, 0x4(%%edx)" "\n\t" /* handler */ "movl %%ebp, 0x8(%%edx)" "\n\t" /* ebp */ "movl %%esp, 0xC(%%edx)" "\n\t" /* esp */ "movl $0, 0x10(%%edx)" "\n\t" /* status */ /* * Link the TCLEXCEPTION_REGISTRATION on the chain. */ "movl %%edx, %%fs:0" "\n\t" /* * Call CopyFileW(nativeSrc, nativeDst, 0) */ "movl %[copyFileW], %%eax" "\n\t" "pushl $0" "\n\t" "pushl %%ebx" "\n\t" "pushl %%ecx" "\n\t" "call *%%eax" "\n\t" /* * Come here on normal exit. Recover the TCLEXCEPTION_REGISTRATION and |
| ︙ | ︙ | |||
629 630 631 632 633 634 635 | /* * Come here however we exited. Restore context from the * TCLEXCEPTION_REGISTRATION in case the stack is unbalanced. */ "2:" "\t" | | | | | | | | | | | | 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 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 |
/*
* Come here however we exited. Restore context from the
* TCLEXCEPTION_REGISTRATION in case the stack is unbalanced.
*/
"2:" "\t"
"movl 0xC(%%edx), %%esp" "\n\t"
"movl 0x8(%%edx), %%ebp" "\n\t"
"movl 0x0(%%edx), %%eax" "\n\t"
"movl %%eax, %%fs:0" "\n\t"
:
/* No outputs */
:
[registration] "m" (registration),
[nativeDst] "m" (nativeDst),
[nativeSrc] "m" (nativeSrc),
[copyFileW] "r" (CopyFileW)
:
"%eax", "%ebx", "%ecx", "%edx", "memory"
);
if (registration.status != FALSE) {
retval = TCL_OK;
}
#else
#ifndef HAVE_NO_SEH
__try {
#endif
if (CopyFileW(nativeSrc, nativeDst, 0) != FALSE) {
retval = TCL_OK;
}
#ifndef HAVE_NO_SEH
} __except (EXCEPTION_EXECUTE_HANDLER) {}
#endif
#endif
if (retval != -1) {
return retval;
}
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EBADF) {
Tcl_SetErrno(EACCES);
return TCL_ERROR;
}
if (Tcl_GetErrno() == EACCES) {
DWORD srcAttr, dstAttr;
srcAttr = GetFileAttributesW(nativeSrc);
dstAttr = GetFileAttributesW(nativeDst);
if (srcAttr != 0xFFFFFFFF) {
if (dstAttr == 0xFFFFFFFF) {
dstAttr = 0;
}
if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
(dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
if (srcAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
/* Source is a symbolic link -- copy it */
if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst)==0) {
return TCL_OK;
}
}
Tcl_SetErrno(EISDIR);
}
if (dstAttr & FILE_ATTRIBUTE_READONLY) {
SetFileAttributesW(nativeDst,
dstAttr & ~((DWORD)FILE_ATTRIBUTE_READONLY));
if (CopyFileW(nativeSrc, nativeDst,
0) != FALSE) {
return TCL_OK;
}
/*
* Still can't copy onto dst. Return that error, and restore
* attributes of dst.
*/
TclWinConvertError(GetLastError());
SetFileAttributesW(nativeDst, dstAttr);
}
}
}
return TCL_ERROR;
}
/*
|
| ︙ | ︙ | |||
745 746 747 748 749 750 751 |
}
int
TclpDeleteFile(
const void *nativePath) /* Pathname of file to be removed (native). */
{
DWORD attr;
| | | | | | | | | | | 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 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 |
}
int
TclpDeleteFile(
const void *nativePath) /* Pathname of file to be removed (native). */
{
DWORD attr;
const WCHAR *path = (const WCHAR *)nativePath;
/*
* The DeleteFile API acts differently under Win95/98 and NT WRT NULL and
* "". Avoid passing these values.
*/
if (path == NULL || path[0] == '\0') {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
if (DeleteFileW(path) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
attr = GetFileAttributesW(path);
if (attr != 0xFFFFFFFF) {
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
/*
* It is a symbolic link - remove it.
*/
if (TclWinSymLinkDelete(path, 0) == 0) {
return TCL_OK;
}
}
/*
* If we fall through here, it is a directory.
*
* Windows NT reports removing a directory as EACCES instead
* of EISDIR.
*/
Tcl_SetErrno(EISDIR);
} else if (attr & FILE_ATTRIBUTE_READONLY) {
int res = SetFileAttributesW(path,
attr & ~((DWORD) FILE_ATTRIBUTE_READONLY));
if ((res != 0) &&
(DeleteFileW(path) != FALSE)) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
if (res != 0) {
SetFileAttributesW(path, attr);
}
}
}
} else if (Tcl_GetErrno() == ENOENT) {
attr = GetFileAttributesW(path);
if (attr != 0xFFFFFFFF) {
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
/*
* Windows 95 reports removing a directory as ENOENT instead
* of EISDIR.
*/
Tcl_SetErrno(EISDIR);
|
| ︙ | ︙ | |||
850 851 852 853 854 855 856 |
*---------------------------------------------------------------------------
*/
int
TclpObjCreateDirectory(
Tcl_Obj *pathPtr)
{
| | | | 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 |
*---------------------------------------------------------------------------
*/
int
TclpObjCreateDirectory(
Tcl_Obj *pathPtr)
{
return DoCreateDirectory((const WCHAR *)Tcl_FSGetNativePath(pathPtr));
}
static int
DoCreateDirectory(
const WCHAR *nativePath) /* Pathname of directory to create (native). */
{
if (CreateDirectoryW(nativePath, NULL) == 0) {
DWORD error = GetLastError();
TclWinConvertError(error);
return TCL_ERROR;
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
907 908 909 910 911 912 913 |
normSrcPtr = Tcl_FSGetNormalizedPath(NULL,srcPathPtr);
normDestPtr = Tcl_FSGetNormalizedPath(NULL,destPathPtr);
if ((normSrcPtr == NULL) || (normDestPtr == NULL)) {
return TCL_ERROR;
}
| > > | | | 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 |
normSrcPtr = Tcl_FSGetNormalizedPath(NULL,srcPathPtr);
normDestPtr = Tcl_FSGetNormalizedPath(NULL,destPathPtr);
if ((normSrcPtr == NULL) || (normDestPtr == NULL)) {
return TCL_ERROR;
}
Tcl_DStringInit(&srcString);
Tcl_DStringInit(&dstString);
Tcl_UtfToWCharDString(Tcl_GetString(normSrcPtr), -1, &srcString);
Tcl_UtfToWCharDString(Tcl_GetString(normDestPtr), -1, &dstString);
ret = TraverseWinTree(TraversalCopy, &srcString, &dstString, &ds);
Tcl_DStringFree(&srcString);
Tcl_DStringFree(&dstString);
if (ret != TCL_OK) {
|
| ︙ | ︙ | |||
980 981 982 983 984 985 986 |
*/
Tcl_DString native;
normPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normPtr == NULL) {
return TCL_ERROR;
}
| > | | | 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 |
*/
Tcl_DString native;
normPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normPtr == NULL) {
return TCL_ERROR;
}
Tcl_DStringInit(&native);
Tcl_UtfToWCharDString(Tcl_GetString(normPtr), -1, &native);
ret = DoRemoveDirectory(&native, recursive, &ds);
Tcl_DStringFree(&native);
} else {
ret = DoRemoveJustDirectory((const WCHAR *)Tcl_FSGetNativePath(pathPtr), 0, &ds);
}
if (ret != TCL_OK) {
if (Tcl_DStringLength(&ds) > 0) {
if (normPtr != NULL &&
!strcmp(Tcl_DStringValue(&ds), TclGetString(normPtr))) {
*errorPtr = pathPtr;
|
| ︙ | ︙ | |||
1026 1027 1028 1029 1030 1031 1032 |
if (nativePath == NULL || nativePath[0] == '\0') {
Tcl_SetErrno(ENOENT);
Tcl_DStringInit(errorPtr);
return TCL_ERROR;
}
| | | | | | 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 |
if (nativePath == NULL || nativePath[0] == '\0') {
Tcl_SetErrno(ENOENT);
Tcl_DStringInit(errorPtr);
return TCL_ERROR;
}
attr = GetFileAttributesW(nativePath);
if (attr & FILE_ATTRIBUTE_REPARSE_POINT) {
/*
* It is a symbolic link - remove it.
*/
if (TclWinSymLinkDelete(nativePath, 0) == 0) {
return TCL_OK;
}
} else {
/*
* Ordinary directory.
*/
if (RemoveDirectoryW(nativePath) != FALSE) {
return TCL_OK;
}
}
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
attr = GetFileAttributesW(nativePath);
if (attr != 0xFFFFFFFF) {
if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
/*
* Windows 95 reports calling RemoveDirectory on a file as an
* EACCES, not an ENOTDIR.
*/
Tcl_SetErrno(ENOTDIR);
|
| ︙ | ︙ | |||
1072 1073 1074 1075 1076 1077 1078 |
if (TclWinSymLinkDelete(nativePath, 1) != 0) {
goto end;
}
}
if (attr & FILE_ATTRIBUTE_READONLY) {
attr &= ~FILE_ATTRIBUTE_READONLY;
| | | | | 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 |
if (TclWinSymLinkDelete(nativePath, 1) != 0) {
goto end;
}
}
if (attr & FILE_ATTRIBUTE_READONLY) {
attr &= ~FILE_ATTRIBUTE_READONLY;
if (SetFileAttributesW(nativePath,
attr) == FALSE) {
goto end;
}
if (RemoveDirectoryW(nativePath) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
SetFileAttributesW(nativePath,
attr | FILE_ATTRIBUTE_READONLY);
}
}
}
if (Tcl_GetErrno() == ENOTEMPTY) {
/*
|
| ︙ | ︙ | |||
1105 1106 1107 1108 1109 1110 1111 |
* don't want to initialise the errorPtr yet.
*/
return TCL_ERROR;
}
end:
if (errorPtr != NULL) {
| > > > | | 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 |
* don't want to initialise the errorPtr yet.
*/
return TCL_ERROR;
}
end:
if (errorPtr != NULL) {
char *p;
Tcl_DStringInit(errorPtr);
p = Tcl_WCharToUtfDString(nativePath, -1, errorPtr);
for (; *p; ++p) {
if (*p == '\\') *p = '/';
}
}
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
1179 1180 1181 1182 1183 1184 1185 |
* filled with UTF-8 name of file causing
* error. */
{
DWORD sourceAttr;
WCHAR *nativeSource, *nativeTarget, *nativeErrfile;
int result, found, sourceLen, targetLen = 0, oldSourceLen, oldTargetLen;
HANDLE handle;
| | | | | | 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 |
* filled with UTF-8 name of file causing
* error. */
{
DWORD sourceAttr;
WCHAR *nativeSource, *nativeTarget, *nativeErrfile;
int result, found, sourceLen, targetLen = 0, oldSourceLen, oldTargetLen;
HANDLE handle;
WIN32_FIND_DATAW data;
nativeErrfile = NULL;
result = TCL_OK;
oldTargetLen = 0;
nativeSource = (WCHAR *) Tcl_DStringValue(sourcePtr);
nativeTarget = (WCHAR *)
(targetPtr == NULL ? NULL : Tcl_DStringValue(targetPtr));
oldSourceLen = Tcl_DStringLength(sourcePtr);
sourceAttr = GetFileAttributesW(nativeSource);
if (sourceAttr == 0xFFFFFFFF) {
nativeErrfile = nativeSource;
goto end;
}
if (sourceAttr & FILE_ATTRIBUTE_REPARSE_POINT) {
/*
* Process the symbolic link
|
| ︙ | ︙ | |||
1217 1218 1219 1220 1221 1222 1223 |
return traverseProc(nativeSource, nativeTarget, DOTREE_F, errorPtr);
}
Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1);
Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
nativeSource = (WCHAR *) Tcl_DStringValue(sourcePtr);
| | | 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 |
return traverseProc(nativeSource, nativeTarget, DOTREE_F, errorPtr);
}
Tcl_DStringAppend(sourcePtr, (char *) L"\\*.*", 4 * sizeof(WCHAR) + 1);
Tcl_DStringSetLength(sourcePtr, Tcl_DStringLength(sourcePtr) - 1);
nativeSource = (WCHAR *) Tcl_DStringValue(sourcePtr);
handle = FindFirstFileW(nativeSource, &data);
if (handle == INVALID_HANDLE_VALUE) {
/*
* Can't read directory.
*/
TclWinConvertError(GetLastError());
nativeErrfile = nativeSource;
|
| ︙ | ︙ | |||
1250 1251 1252 1253 1254 1255 1256 |
targetLen = oldTargetLen;
targetLen += sizeof(WCHAR);
Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1);
Tcl_DStringSetLength(targetPtr, targetLen);
}
found = 1;
| | | 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 |
targetLen = oldTargetLen;
targetLen += sizeof(WCHAR);
Tcl_DStringAppend(targetPtr, (char *) L"\\", sizeof(WCHAR) + 1);
Tcl_DStringSetLength(targetPtr, targetLen);
}
found = 1;
for (; found; found = FindNextFileW(handle, &data)) {
WCHAR *nativeName;
int len;
WCHAR *wp = data.cFileName;
if (*wp == '.') {
wp++;
if (*wp == '.') {
|
| ︙ | ︙ | |||
1319 1320 1321 1322 1323 1324 1325 |
DOTREE_POSTD, errorPtr);
}
end:
if (nativeErrfile != NULL) {
TclWinConvertError(GetLastError());
if (errorPtr != NULL) {
| > | | 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 |
DOTREE_POSTD, errorPtr);
}
end:
if (nativeErrfile != NULL) {
TclWinConvertError(GetLastError());
if (errorPtr != NULL) {
Tcl_DStringInit(errorPtr);
Tcl_WCharToUtfDString(nativeErrfile, -1, errorPtr);
}
result = TCL_ERROR;
}
return result;
}
|
| ︙ | ︙ | |||
1365 1366 1367 1368 1369 1370 1371 |
case DOTREE_LINK:
if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == TCL_OK) {
return TCL_OK;
}
break;
case DOTREE_PRED:
if (DoCreateDirectory(nativeDst) == TCL_OK) {
| | | > | | 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 |
case DOTREE_LINK:
if (TclWinSymLinkCopyDirectory(nativeSrc, nativeDst) == TCL_OK) {
return TCL_OK;
}
break;
case DOTREE_PRED:
if (DoCreateDirectory(nativeDst) == TCL_OK) {
DWORD attr = GetFileAttributesW(nativeSrc);
if (SetFileAttributesW(nativeDst,
attr) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
}
break;
case DOTREE_POSTD:
return TCL_OK;
}
/*
* There shouldn't be a problem with src, because we already checked it to
* get here.
*/
if (errorPtr != NULL) {
Tcl_DStringInit(errorPtr);
Tcl_WCharToUtfDString(nativeDst, -1, errorPtr);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1413 1414 1415 1416 1417 1418 1419 |
*
*----------------------------------------------------------------------
*/
static int
TraversalDelete(
const WCHAR *nativeSrc, /* Source pathname to delete. */
| | | 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 |
*
*----------------------------------------------------------------------
*/
static int
TraversalDelete(
const WCHAR *nativeSrc, /* Source pathname to delete. */
TCL_UNUSED(const WCHAR *) /*dstPtr*/,
int type, /* Reason for call - see TraverseWinTree() */
Tcl_DString *errorPtr) /* If non-NULL, initialized DString filled
* with UTF-8 name of file causing error. */
{
switch (type) {
case DOTREE_F:
if (TclpDeleteFile(nativeSrc) == TCL_OK) {
|
| ︙ | ︙ | |||
1439 1440 1441 1442 1443 1444 1445 |
if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) {
return TCL_OK;
}
break;
}
if (errorPtr != NULL) {
| > | | 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 |
if (DoRemoveJustDirectory(nativeSrc, 0, NULL) == TCL_OK) {
return TCL_OK;
}
break;
}
if (errorPtr != NULL) {
Tcl_DStringInit(errorPtr);
Tcl_WCharToUtfDString(nativeSrc, -1, errorPtr);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
1502 1503 1504 1505 1506 1507 1508 |
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
DWORD result;
const WCHAR *nativeName;
int attr;
| | | | | | 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 |
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
DWORD result;
const WCHAR *nativeName;
int attr;
nativeName = (const WCHAR *)Tcl_FSGetNativePath(fileName);
result = GetFileAttributesW(nativeName);
if (result == 0xFFFFFFFF) {
StatError(interp, fileName);
return TCL_ERROR;
}
attr = (int)(result & attributeArray[objIndex]);
if ((objIndex == WIN_HIDDEN_ATTRIBUTE) && (attr != 0)) {
/*
* It is hidden. However there is a bug on some Windows OSes in which
* root volumes (drives) formatted as NTFS are declared hidden when
* they are not (and cannot be).
*
* We test for, and fix that case, here.
*/
int len;
const char *str = TclGetStringFromObj(fileName, &len);
if (len < 4) {
if (len == 0) {
/*
* Not sure if this is possible, but we pass it on anyway.
*/
|
| ︙ | ︙ | |||
1575 1576 1577 1578 1579 1580 1581 |
*
*----------------------------------------------------------------------
*/
static int
ConvertFileNameFormat(
Tcl_Interp *interp, /* The interp we are using for errors. */
| | < | > | 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 |
*
*----------------------------------------------------------------------
*/
static int
ConvertFileNameFormat(
Tcl_Interp *interp, /* The interp we are using for errors. */
TCL_UNUSED(int) /*objIndex*/,
Tcl_Obj *fileName, /* The name of the file. */
int longShort, /* 0 to short name, 1 to long name. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
int pathc, i;
Tcl_Obj *splitPath;
splitPath = Tcl_FSSplitPath(fileName, &pathc);
if (splitPath == NULL || pathc == 0) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": no such file or directory",
Tcl_GetString(fileName)));
errno = ENOENT;
Tcl_PosixError(interp);
}
goto cleanup;
}
/*
* We will decrement this again at the end. It is safer to do this in
* case any of the calls below retain a reference to splitPath.
*/
Tcl_IncrRefCount(splitPath);
for (i = 0; i < pathc; i++) {
Tcl_Obj *elt;
char *pathv;
int length;
Tcl_ListObjIndex(NULL, splitPath, i, &elt);
pathv = TclGetStringFromObj(elt, &length);
if ((pathv[0] == '/') || ((length == 3) && (pathv[1] == ':'))
|| (strcmp(pathv, ".") == 0) || (strcmp(pathv, "..") == 0)) {
/*
|
| ︙ | ︙ | |||
1634 1635 1636 1637 1638 1639 1640 |
pathv[0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[0]));
} else {
Tcl_Obj *tempPath;
Tcl_DString ds;
Tcl_DString dsTemp;
const WCHAR *nativeName;
const char *tempString;
| | > | | | | | 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 |
pathv[0] = (char) Tcl_UniCharToUpper(UCHAR(pathv[0]));
} else {
Tcl_Obj *tempPath;
Tcl_DString ds;
Tcl_DString dsTemp;
const WCHAR *nativeName;
const char *tempString;
WIN32_FIND_DATAW data;
HANDLE handle;
DWORD attr;
tempPath = Tcl_FSJoinPath(splitPath, i+1);
Tcl_IncrRefCount(tempPath);
/*
* We'd like to call Tcl_FSGetNativePath(tempPath) but that is
* likely to lead to infinite loops.
*/
tempString = TclGetStringFromObj(tempPath, &length);
Tcl_DStringInit(&ds);
nativeName = Tcl_UtfToWCharDString(tempString, length, &ds);
Tcl_DecrRefCount(tempPath);
handle = FindFirstFileW(nativeName, &data);
if (handle == INVALID_HANDLE_VALUE) {
/*
* FindFirstFileW() doesn't like root directories. We would
* only get a root directory here if the caller specified "c:"
* or "c:." and the current directory on the drive was the
* root directory
*/
attr = GetFileAttributesW(nativeName);
if ((attr!=0xFFFFFFFF) && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
Tcl_DStringFree(&ds);
goto simple;
}
}
if (handle == INVALID_HANDLE_VALUE) {
|
| ︙ | ︙ | |||
1684 1685 1686 1687 1688 1689 1690 |
} else {
if (data.cAlternateFileName[0] == '\0') {
nativeName = (WCHAR *) data.cFileName;
}
}
/*
| | | | 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 |
} else {
if (data.cAlternateFileName[0] == '\0') {
nativeName = (WCHAR *) data.cFileName;
}
}
/*
* Purify reports a extraneous UMR in Tcl_WCharToUtfDString() trying
* to dereference nativeName as a Unicode string. I have proven to
* myself that purify is wrong by running the following example
* when nativeName == data.w.cAlternateFileName and noting that
* purify doesn't complain about the first line, but does complain
* about the second.
*
* fprintf(stderr, "%d\n", data.w.cAlternateFileName[0]);
* fprintf(stderr, "%d\n", ((WCHAR *) nativeName)[0]);
*/
Tcl_DStringInit(&dsTemp);
Tcl_WCharToUtfDString(nativeName, -1, &dsTemp);
Tcl_DStringFree(&ds);
/*
* Deal with issues of tildes being absolute.
*/
if (Tcl_DStringValue(&dsTemp)[0] == '~') {
|
| ︙ | ︙ | |||
1827 1828 1829 1830 1831 1832 1833 |
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
DWORD fileAttributes, old;
int yesNo, result;
const WCHAR *nativeName;
| | | | | | 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 |
Tcl_Obj *fileName, /* The name of the file. */
Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
DWORD fileAttributes, old;
int yesNo, result;
const WCHAR *nativeName;
nativeName = (const WCHAR *)Tcl_FSGetNativePath(fileName);
fileAttributes = old = GetFileAttributesW(nativeName);
if (fileAttributes == 0xFFFFFFFF) {
StatError(interp, fileName);
return TCL_ERROR;
}
result = Tcl_GetBooleanFromObj(interp, attributePtr, &yesNo);
if (result != TCL_OK) {
return result;
}
if (yesNo) {
fileAttributes |= (attributeArray[objIndex]);
} else {
fileAttributes &= ~(attributeArray[objIndex]);
}
if ((fileAttributes != old)
&& !SetFileAttributesW(nativeName, fileAttributes)) {
StatError(interp, fileName);
return TCL_ERROR;
}
return result;
}
|
| ︙ | ︙ | |||
1876 1877 1878 1879 1880 1881 1882 |
*/
static int
CannotSetAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file. */
| | | | 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 |
*/
static int
CannotSetAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
Tcl_Obj *fileName, /* The name of the file. */
TCL_UNUSED(Tcl_Obj *) /*attributePtr*/)
{
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot set attribute \"%s\" for file \"%s\": attribute is readonly",
tclpFileAttrStrings[objIndex], Tcl_GetString(fileName)));
errno = EINVAL;
Tcl_PosixError(interp);
return TCL_ERROR;
}
/*
*---------------------------------------------------------------------------
|
| ︙ | ︙ | |||
1920 1921 1922 1923 1924 1925 1926 |
* On Win32s:
* GetLogicalDriveStrings() isn't implemented.
* GetLogicalDrives() returns incorrect information.
*/
if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) {
/*
| | | | 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 |
* On Win32s:
* GetLogicalDriveStrings() isn't implemented.
* GetLogicalDrives() returns incorrect information.
*/
if (GetLogicalDriveStringsA(sizeof(buf), buf) == 0) {
/*
* GetVolumeInformationW() will detects all drives, but causes
* chattering on empty floppy drives. We only do this if
* GetLogicalDriveStrings() didn't work. It has also been reported
* that on some laptops it takes a while for GetVolumeInformationW() to
* return when pinging an empty floppy drive, another reason to try to
* avoid calling it.
*/
buf[1] = ':';
buf[2] = '/';
buf[3] = '\0';
|
| ︙ | ︙ | |||
1991 1992 1993 1994 1995 1996 1997 |
*/
if (dirObj) {
Tcl_GetString(dirObj);
if (dirObj->length < 1) {
goto useSystemTemp;
}
| > | | | < < | | | 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 |
*/
if (dirObj) {
Tcl_GetString(dirObj);
if (dirObj->length < 1) {
goto useSystemTemp;
}
Tcl_DStringInit(&base);
Tcl_UtfToWCharDString(Tcl_GetString(dirObj), -1, &base);
if (dirObj->bytes[dirObj->length - 1] != '\\') {
Tcl_UtfToWCharDString("\\", -1, &base);
}
} else {
useSystemTemp:
Tcl_DStringInit(&base);
Tcl_DStringAppend(&base, (char *) tempBuf, len * sizeof(WCHAR));
}
/*
* Next, the base of the directory name.
*/
#define DEFAULT_TEMP_DIR_PREFIX "tcl"
#define SUFFIX_LENGTH 8
if (basenameObj) {
Tcl_UtfToWCharDString(Tcl_GetString(basenameObj), -1, &base);
} else {
Tcl_UtfToWCharDString(DEFAULT_TEMP_DIR_PREFIX, -1, &base);
}
Tcl_UtfToWCharDString("_", -1, &base);
/*
* Now we keep on trying random suffixes until we get one that works
* (i.e., that doesn't trigger the ERROR_ALREADY_EXISTS error). Note that
* SUFFIX_LENGTH is longer than on Unix because we expect to be not on a
* case-sensitive filesystem.
*/
|
| ︙ | ︙ | |||
2042 2043 2044 2045 2046 2047 2048 |
error = ERROR_SUCCESS;
tempbuf[SUFFIX_LENGTH] = '\0';
for (i = 0 ; i < SUFFIX_LENGTH; i++) {
tempbuf[i] = randChars[(int) (rand() % numRandChars)];
}
Tcl_DStringSetLength(&base, baseLen);
| | > | | 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 |
error = ERROR_SUCCESS;
tempbuf[SUFFIX_LENGTH] = '\0';
for (i = 0 ; i < SUFFIX_LENGTH; i++) {
tempbuf[i] = randChars[(int) (rand() % numRandChars)];
}
Tcl_DStringSetLength(&base, baseLen);
Tcl_UtfToWCharDString(tempbuf, -1, &base);
} while (!CreateDirectoryW((LPCWSTR) Tcl_DStringValue(&base), NULL)
&& (error = GetLastError()) == ERROR_ALREADY_EXISTS);
/*
* Check for other errors. The big ones are ERROR_PATH_NOT_FOUND and
* ERROR_ACCESS_DENIED.
*/
if (error != ERROR_SUCCESS) {
TclWinConvertError(error);
Tcl_DStringFree(&base);
return NULL;
}
/*
* We actually made the directory, so we're done! Report what we made back
* as a (clean) Tcl_Obj.
*/
Tcl_DStringInit(&name);
Tcl_WCharToUtfDString((LPCWSTR) Tcl_DStringValue(&base), -1, &name);
Tcl_DStringFree(&base);
return TclDStringToObj(&name);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinFile.c.
| ︙ | ︙ | |||
173 174 175 176 177 178 179 | static int WinIsReserved(const char *path); static Tcl_Obj * WinReadLink(const WCHAR *LinkSource); static Tcl_Obj * WinReadLinkDirectory(const WCHAR *LinkDirectory); static int WinLink(const WCHAR *LinkSource, const WCHAR *LinkTarget, int linkAction); static int WinSymLinkDirectory(const WCHAR *LinkDirectory, const WCHAR *LinkTarget); | | | 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 | static int WinIsReserved(const char *path); static Tcl_Obj * WinReadLink(const WCHAR *LinkSource); static Tcl_Obj * WinReadLinkDirectory(const WCHAR *LinkDirectory); static int WinLink(const WCHAR *LinkSource, const WCHAR *LinkTarget, int linkAction); static int WinSymLinkDirectory(const WCHAR *LinkDirectory, const WCHAR *LinkTarget); MODULE_SCOPE TCL_NORETURN void tclWinDebugPanic(const char *format, ...); /* *-------------------------------------------------------------------- * * WinLink -- * * Make a link from source to target. |
| ︙ | ︙ | |||
199 200 201 202 203 204 205 |
WCHAR *tempFilePart;
DWORD attr;
/*
* Get the full path referenced by the target.
*/
| | | | | | | 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 |
WCHAR *tempFilePart;
DWORD attr;
/*
* Get the full path referenced by the target.
*/
if (!GetFullPathNameW(linkTargetPath, MAX_PATH, tempFileName,
&tempFilePart)) {
/*
* Invalid file.
*/
TclWinConvertError(GetLastError());
return -1;
}
/*
* Make sure source file doesn't exist.
*/
attr = GetFileAttributesW(linkSourcePath);
if (attr != INVALID_FILE_ATTRIBUTES) {
Tcl_SetErrno(EEXIST);
return -1;
}
/*
* Get the full path referenced by the source file/directory.
*/
if (!GetFullPathNameW(linkSourcePath, MAX_PATH, tempFileName,
&tempFilePart)) {
/*
* Invalid file.
*/
TclWinConvertError(GetLastError());
return -1;
}
/*
* Check the target.
*/
attr = GetFileAttributesW(linkTargetPath);
if (attr == INVALID_FILE_ATTRIBUTES) {
/*
* The target doesn't exist.
*/
TclWinConvertError(GetLastError());
} else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
/*
* It is a file.
*/
if (linkAction & TCL_CREATE_HARD_LINK) {
if (CreateHardLinkW(linkSourcePath, linkTargetPath, NULL)) {
/*
* Success!
*/
return 0;
}
|
| ︙ | ︙ | |||
312 313 314 315 316 317 318 |
WCHAR *tempFilePart;
DWORD attr;
/*
* Get the full path referenced by the target.
*/
| | | | 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 |
WCHAR *tempFilePart;
DWORD attr;
/*
* Get the full path referenced by the target.
*/
if (!GetFullPathNameW(linkSourcePath, MAX_PATH, tempFileName,
&tempFilePart)) {
/*
* Invalid file.
*/
TclWinConvertError(GetLastError());
return NULL;
}
/*
* Make sure source file does exist.
*/
attr = GetFileAttributesW(linkSourcePath);
if (attr == INVALID_FILE_ATTRIBUTES) {
/*
* The source doesn't exist.
*/
TclWinConvertError(GetLastError());
return NULL;
|
| ︙ | ︙ | |||
391 392 393 394 395 396 397 |
/*
* We must have backslashes only. This is VERY IMPORTANT. If we have any
* forward slashes everything appears to work, but the resulting symlink
* is useless!
*/
for (loop = nativeTarget; *loop != 0; loop++) {
| | | | | 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 |
/*
* We must have backslashes only. This is VERY IMPORTANT. If we have any
* forward slashes everything appears to work, but the resulting symlink
* is useless!
*/
for (loop = nativeTarget; *loop != 0; loop++) {
if (*loop == '/') {
*loop = '\\';
}
}
if ((nativeTarget[len-1] == '\\') && (nativeTarget[len-2] != ':')) {
nativeTarget[len-1] = 0;
}
/*
* Build the reparse info.
*/
|
| ︙ | ︙ | |||
483 484 485 486 487 488 489 |
DUMMY_REPARSE_BUFFER dummy;
REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy;
HANDLE hFile;
DWORD returnedLength;
memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
| | | | 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 |
DUMMY_REPARSE_BUFFER dummy;
REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy;
HANDLE hFile;
DWORD returnedLength;
memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
hFile = CreateFileW(linkOrigPath, GENERIC_WRITE, 0, NULL, OPEN_EXISTING,
FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL);
if (hFile != INVALID_HANDLE_VALUE) {
if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer,
REPARSE_MOUNTPOINT_HEADER_SIZE,NULL,0,&returnedLength,NULL)) {
/*
* Error setting junction.
*/
TclWinConvertError(GetLastError());
CloseHandle(hFile);
} else {
CloseHandle(hFile);
if (!linkOnly) {
RemoveDirectoryW(linkOrigPath);
}
return 0;
}
}
return -1;
}
|
| ︙ | ︙ | |||
543 544 545 546 547 548 549 |
int attr, len, offset;
DUMMY_REPARSE_BUFFER dummy;
REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy;
Tcl_Obj *retVal;
Tcl_DString ds;
const char *copy;
| | | 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 |
int attr, len, offset;
DUMMY_REPARSE_BUFFER dummy;
REPARSE_DATA_BUFFER *reparseBuffer = (REPARSE_DATA_BUFFER *) &dummy;
Tcl_Obj *retVal;
Tcl_DString ds;
const char *copy;
attr = GetFileAttributesW(linkDirPath);
if (!(attr & FILE_ATTRIBUTE_REPARSE_POINT)) {
goto invalidError;
}
if (NativeReadReparse(linkDirPath, reparseBuffer, 0)) {
return NULL;
}
|
| ︙ | ︙ | |||
568 569 570 571 572 573 574 | * There is an assumption in this code that 'wide' interfaces are * being used (see tclWin32Dll.c), which is true for the only systems * which support reparse tags at present. If that changes in the * future, this code will have to be generalised. */ offset = 0; | | | | 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 |
* There is an assumption in this code that 'wide' interfaces are
* being used (see tclWin32Dll.c), which is true for the only systems
* which support reparse tags at present. If that changes in the
* future, this code will have to be generalised.
*/
offset = 0;
if (reparseBuffer->MountPointReparseBuffer.PathBuffer[0] == '\\') {
/*
* Check whether this is a mounted volume.
*/
if (wcsncmp(reparseBuffer->MountPointReparseBuffer.PathBuffer,
L"\\??\\Volume{",11) == 0) {
char drive;
/*
* There is some confusion between \??\ and \\?\ which we have
* to fix here. It doesn't seem very well documented.
*/
reparseBuffer->MountPointReparseBuffer.PathBuffer[1] = '\\';
/*
* Check if a corresponding drive letter exists, and use that
* if it is found
*/
drive = TclWinDriveLetterForVolMountPoint(
|
| ︙ | ︙ | |||
630 631 632 633 634 635 636 | * Strip off the prefix. */ offset = 4; } } | > | | | 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 | * Strip off the prefix. */ offset = 4; } } Tcl_DStringInit(&ds); Tcl_WCharToUtfDString( reparseBuffer->MountPointReparseBuffer.PathBuffer, reparseBuffer->MountPointReparseBuffer .SubstituteNameLength>>1, &ds); copy = Tcl_DStringValue(&ds)+offset; len = Tcl_DStringLength(&ds)-offset; retVal = Tcl_NewStringObj(copy,len); Tcl_IncrRefCount(retVal); Tcl_DStringFree(&ds); return retVal; |
| ︙ | ︙ | |||
676 677 678 679 680 681 682 |
const WCHAR *linkDirPath, /* The junction to read */
REPARSE_DATA_BUFFER *buffer,/* Pointer to buffer. Cannot be NULL */
DWORD desiredAccess)
{
HANDLE hFile;
DWORD returnedLength;
| | | 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 |
const WCHAR *linkDirPath, /* The junction to read */
REPARSE_DATA_BUFFER *buffer,/* Pointer to buffer. Cannot be NULL */
DWORD desiredAccess)
{
HANDLE hFile;
DWORD returnedLength;
hFile = CreateFileW(linkDirPath, desiredAccess, FILE_SHARE_READ, NULL,
OPEN_EXISTING,
FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL);
if (hFile == INVALID_HANDLE_VALUE) {
/*
* Error creating directory.
*/
|
| ︙ | ︙ | |||
736 737 738 739 740 741 742 |
HANDLE hFile;
DWORD returnedLength;
/*
* Create the directory - it must not already exist.
*/
| | | | 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 |
HANDLE hFile;
DWORD returnedLength;
/*
* Create the directory - it must not already exist.
*/
if (CreateDirectoryW(linkDirPath, NULL) == 0) {
/*
* Error creating directory.
*/
TclWinConvertError(GetLastError());
return -1;
}
hFile = CreateFileW(linkDirPath, GENERIC_WRITE, 0, NULL,
OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT
| FILE_FLAG_BACKUP_SEMANTICS, NULL);
if (hFile == INVALID_HANDLE_VALUE) {
/*
* Error creating directory.
*/
|
| ︙ | ︙ | |||
769 770 771 772 773 774 775 |
NULL, 0, &returnedLength, NULL)) {
/*
* Error setting junction.
*/
TclWinConvertError(GetLastError());
CloseHandle(hFile);
| | | 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 |
NULL, 0, &returnedLength, NULL)) {
/*
* Error setting junction.
*/
TclWinConvertError(GetLastError());
CloseHandle(hFile);
RemoveDirectoryW(linkDirPath);
return -1;
}
CloseHandle(hFile);
/*
* We succeeded.
*/
|
| ︙ | ︙ | |||
798 799 800 801 802 803 804 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | > > > > > > > > > > | 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 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
TCL_NORETURN void
tclWinDebugPanic(
const char *format, ...)
{
#define TCL_MAX_WARN_LEN 1024
va_list argList;
char buf[TCL_MAX_WARN_LEN * 3];
WCHAR msgString[TCL_MAX_WARN_LEN];
va_start(argList, format);
vsnprintf(buf, sizeof(buf), format, argList);
msgString[TCL_MAX_WARN_LEN-1] = '\0';
MultiByteToWideChar(CP_UTF8, 0, buf, -1, msgString, TCL_MAX_WARN_LEN);
/*
* Truncate MessageBox string if it is too long to not overflow the screen
* and cause possible oversized window error.
*/
if (msgString[TCL_MAX_WARN_LEN-1] != '\0') {
memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR));
}
if (IsDebuggerPresent()) {
OutputDebugStringW(msgString);
} else {
MessageBeep(MB_ICONEXCLAMATION);
MessageBoxW(NULL, msgString, L"Fatal Error",
MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND);
}
#if defined(__GNUC__)
__builtin_trap();
#elif defined(_WIN64)
__debugbreak();
#elif defined(_MSC_VER) && defined (_M_IX86)
_asm {int 3}
#else
DebugBreak();
#endif
abort();
}
/*
*---------------------------------------------------------------------------
*
* TclpFindExecutable --
*
|
| ︙ | ︙ | |||
854 855 856 857 858 859 860 861 862 863 864 865 866 867 |
void
TclpFindExecutable(
const char *argv0) /* If NULL, install PanicMessageBox, otherwise
* ignore. */
{
WCHAR wName[MAX_PATH];
char name[MAX_PATH * 3];
GetModuleFileNameW(NULL, wName, MAX_PATH);
WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL);
TclWinNoBackslash(name);
TclSetObjNameOfExecutable(Tcl_NewStringObj(name, -1), NULL);
}
| > > > > > > > > > > | 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 |
void
TclpFindExecutable(
const char *argv0) /* If NULL, install PanicMessageBox, otherwise
* ignore. */
{
WCHAR wName[MAX_PATH];
char name[MAX_PATH * 3];
/*
* Under Windows we ignore argv0, and return the path for the file used to
* create this process. Only if it is NULL, install a new panic handler.
*/
if (argv0 == NULL) {
# undef Tcl_SetPanicProc
Tcl_SetPanicProc(tclWinDebugPanic);
}
GetModuleFileNameW(NULL, wName, MAX_PATH);
WideCharToMultiByte(CP_UTF8, 0, wName, -1, name, sizeof(name), NULL, NULL);
TclWinNoBackslash(name);
TclSetObjNameOfExecutable(Tcl_NewStringObj(name, -1), NULL);
}
|
| ︙ | ︙ | |||
908 909 910 911 912 913 914 915 916 |
Tcl_Obj *norm = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (norm != NULL) {
/*
* Match a single file directly.
*/
DWORD attr;
WIN32_FILE_ATTRIBUTE_DATA data;
| > < | | | | | | | 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 |
Tcl_Obj *norm = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (norm != NULL) {
/*
* Match a single file directly.
*/
int len;
DWORD attr;
WIN32_FILE_ATTRIBUTE_DATA data;
const char *str = TclGetStringFromObj(norm, &len);
native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (GetFileAttributesExW(native,
GetFileExInfoStandard, &data) != TRUE) {
return TCL_OK;
}
attr = data.dwFileAttributes;
if (NativeMatchType(WinIsDrive(str,len), attr, native, types)) {
Tcl_ListObjAppendElement(interp, resultPtr, pathPtr);
}
}
return TCL_OK;
} else {
DWORD attr;
HANDLE handle;
WIN32_FIND_DATAW data;
const char *dirName; /* UTF-8 dir name, later with pattern
* appended. */
int dirLength;
int matchSpecialDots;
Tcl_DString ds; /* Native encoding of dir, also used
* temporarily for other things. */
Tcl_DString dsOrig; /* UTF-8 encoding of dir. */
Tcl_Obj *fileNamePtr;
char lastChar;
|
| ︙ | ︙ | |||
954 955 956 957 958 959 960 | return TCL_ERROR; } /* * Verify that the specified path exists and is actually a directory. */ | | | | 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 |
return TCL_ERROR;
}
/*
* Verify that the specified path exists and is actually a directory.
*/
native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (native == NULL) {
return TCL_OK;
}
attr = GetFileAttributesW(native);
if ((attr == INVALID_FILE_ATTRIBUTES)
|| ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0)) {
return TCL_OK;
}
/*
|
| ︙ | ︙ | |||
999 1000 1001 1002 1003 1004 1005 |
*/
dirName = Tcl_DStringAppend(&dsOrig, pattern, -1);
} else {
dirName = TclDStringAppendLiteral(&dsOrig, "*.*");
}
| > | | | | 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 |
*/
dirName = Tcl_DStringAppend(&dsOrig, pattern, -1);
} else {
dirName = TclDStringAppendLiteral(&dsOrig, "*.*");
}
Tcl_DStringInit(&ds);
native = Tcl_UtfToWCharDString(dirName, -1, &ds);
if ((types == NULL) || (types->type != TCL_GLOB_TYPE_DIR)) {
handle = FindFirstFileW(native, &data);
} else {
/*
* We can be more efficient, for pure directory requests.
*/
handle = FindFirstFileExW(native,
FindExInfoStandard, &data,
FindExSearchLimitToDirectories, NULL, 0);
}
if (handle == INVALID_HANDLE_VALUE) {
DWORD err = GetLastError();
|
| ︙ | ︙ | |||
1072 1073 1074 1075 1076 1077 1078 |
do {
const char *utfname;
int checkDrive = 0, isDrive;
DWORD attr;
native = data.cFileName;
attr = data.dwFileAttributes;
| > | | 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 |
do {
const char *utfname;
int checkDrive = 0, isDrive;
DWORD attr;
native = data.cFileName;
attr = data.dwFileAttributes;
Tcl_DStringInit(&ds);
utfname = Tcl_WCharToUtfDString(native, -1, &ds);
if (!matchSpecialDots) {
/*
* If it is exactly '.' or '..' then we ignore it.
*/
if ((utfname[0] == '.') && (utfname[1] == '\0'
|
| ︙ | ︙ | |||
1132 1133 1134 1135 1136 1137 1138 | } /* * Free ds here to ensure that native is valid above. */ Tcl_DStringFree(&ds); | | | 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 |
}
/*
* Free ds here to ensure that native is valid above.
*/
Tcl_DStringFree(&ds);
} while (FindNextFileW(handle, &data) == TRUE);
FindClose(handle);
Tcl_DStringFree(&dsOrig);
return TCL_OK;
}
}
|
| ︙ | ︙ | |||
1447 1448 1449 1450 1451 1452 1453 |
rc = 1;
result = Tcl_DStringValue(bufferPtr);
}
}
Tcl_DStringFree(&ds);
} else {
Tcl_DStringInit(&ds);
| | | | | | | | 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 |
rc = 1;
result = Tcl_DStringValue(bufferPtr);
}
}
Tcl_DStringFree(&ds);
} else {
Tcl_DStringInit(&ds);
wName = Tcl_UtfToWCharDString(domain + 1, -1, &ds);
rc = NetGetDCName(NULL, wName, (LPBYTE *) &wDomain);
Tcl_DStringFree(&ds);
nameLen = domain - name;
}
if (rc == 0) {
Tcl_DStringInit(&ds);
wName = Tcl_UtfToWCharDString(name, nameLen, &ds);
while (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) &uiPtr) != 0) {
/*
* User does not exist; if domain was not specified, try again
* using current domain.
*/
rc = 1;
if (domain != NULL) {
break;
}
/*
* Get current domain
*/
rc = NetGetDCName(NULL, NULL, (LPBYTE *) &wDomain);
if (rc != 0) {
break;
}
domain = (const char *)INT2PTR(-1); /* repeat once */
}
if (rc == 0) {
DWORD i, size = MAX_PATH;
wHomeDir = uiPtr->usri1_home_dir;
if ((wHomeDir != NULL) && (wHomeDir[0] != '\0')) {
size = lstrlenW(wHomeDir);
Tcl_WCharToUtfDString(wHomeDir, size, bufferPtr);
} else {
/*
* User exists but has no home dir. Return
* "{GetProfilesDirectory}/<user>".
*/
GetProfilesDirectoryW(buf, &size);
Tcl_WCharToUtfDString(buf, size-1, bufferPtr);
Tcl_DStringAppend(bufferPtr, "/", 1);
Tcl_DStringAppend(bufferPtr, name, nameLen);
}
result = Tcl_DStringValue(bufferPtr);
/*
* Be sure we return normalized path
|
| ︙ | ︙ | |||
1566 1567 1568 1569 1570 1571 1572 |
static int
NativeAccess(
const WCHAR *nativePath, /* Path of file to access, native encoding. */
int mode) /* Permission setting. */
{
DWORD attr;
| | | 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 |
static int
NativeAccess(
const WCHAR *nativePath, /* Path of file to access, native encoding. */
int mode) /* Permission setting. */
{
DWORD attr;
attr = GetFileAttributesW(nativePath);
if (attr == INVALID_FILE_ATTRIBUTES) {
/*
* File might not exist.
*/
DWORD lasterror = GetLastError();
|
| ︙ | ︙ | |||
1635 1636 1637 1638 1639 1640 1641 |
if (mode & W_OK) {
mask |= GENERIC_WRITE;
}
if (mode & X_OK) {
mask |= GENERIC_EXECUTE;
}
| | | 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 |
if (mode & W_OK) {
mask |= GENERIC_WRITE;
}
if (mode & X_OK) {
mask |= GENERIC_EXECUTE;
}
hFile = CreateFileW(nativePath, mask,
FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
NULL, OPEN_EXISTING, FILE_FLAG_NO_BUFFERING, NULL);
if (hFile != INVALID_HANDLE_VALUE) {
CloseHandle(hFile);
return 0;
}
|
| ︙ | ︙ | |||
1685 1686 1687 1688 1689 1690 1691 | int error; /* * First find out how big the buffer needs to be. */ size = 0; | | | 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 | int error; /* * First find out how big the buffer needs to be. */ size = 0; GetFileSecurityW(nativePath, OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION | DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION, 0, 0, &size); /* * Should have failed with ERROR_INSUFFICIENT_BUFFER */ |
| ︙ | ︙ | |||
1716 1717 1718 1719 1720 1721 1722 |
sdPtr = (SECURITY_DESCRIPTOR *) HeapAlloc(GetProcessHeap(), 0, size);
if (sdPtr == NULL) {
goto accessError;
}
/*
| | | | 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 |
sdPtr = (SECURITY_DESCRIPTOR *) HeapAlloc(GetProcessHeap(), 0, size);
if (sdPtr == NULL) {
goto accessError;
}
/*
* Call GetFileSecurityW() for real.
*/
if (!GetFileSecurityW(nativePath,
OWNER_SECURITY_INFORMATION | GROUP_SECURITY_INFORMATION
| DACL_SECURITY_INFORMATION | LABEL_SECURITY_INFORMATION,
sdPtr, size, &size)) {
/*
* Error getting owner SD
*/
|
| ︙ | ︙ | |||
1860 1861 1862 1863 1864 1865 1866 |
}
if (path[len-4] != '.') {
return 0;
}
path += len-3;
| | | | | | | 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 |
}
if (path[len-4] != '.') {
return 0;
}
path += len-3;
if ((_wcsicmp(path, L"exe") == 0)
|| (_wcsicmp(path, L"com") == 0)
|| (_wcsicmp(path, L"cmd") == 0)
|| (_wcsicmp(path, L"cmd") == 0)
|| (_wcsicmp(path, L"bat") == 0)) {
return 1;
}
return 0;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1893 1894 1895 1896 1897 1898 1899 |
int
TclpObjChdir(
Tcl_Obj *pathPtr) /* Path to new working directory. */
{
int result;
const WCHAR *nativePath;
| | | | 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 |
int
TclpObjChdir(
Tcl_Obj *pathPtr) /* Path to new working directory. */
{
int result;
const WCHAR *nativePath;
nativePath = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (!nativePath) {
return -1;
}
result = SetCurrentDirectoryW(nativePath);
if (result == 0) {
TclWinConvertError(GetLastError());
return -1;
}
return 0;
}
|
| ︙ | ︙ | |||
1939 1940 1941 1942 1943 1944 1945 |
Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with
* name of current directory. */
{
WCHAR buffer[MAX_PATH];
char *p;
WCHAR *native;
| | > | | 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 1988 1989 1990 1991 1992 1993 1994 1995 1996 |
Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with
* name of current directory. */
{
WCHAR buffer[MAX_PATH];
char *p;
WCHAR *native;
if (GetCurrentDirectoryW(MAX_PATH, buffer) == 0) {
TclWinConvertError(GetLastError());
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error getting working directory name: %s",
Tcl_PosixError(interp)));
}
return NULL;
}
/*
* Watch for the weird Windows c:\\UNC syntax.
*/
native = (WCHAR *) buffer;
if ((native[0] != '\0') && (native[1] == ':')
&& (native[2] == '\\') && (native[3] == '\\')) {
native += 2;
}
Tcl_DStringInit(bufferPtr);
Tcl_WCharToUtfDString(native, -1, bufferPtr);
/*
* Convert to forward slashes for easier use in scripts.
*/
for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
if (*p == '\\') {
|
| ︙ | ︙ | |||
1985 1986 1987 1988 1989 1990 1991 |
* Ensure correct file sizes by forcing the OS to write any pending data
* to disk. This is done only for channels which are dirty, i.e. have been
* written to since the last flush here.
*/
TclWinFlushDirtyChannels();
| | | 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 |
* Ensure correct file sizes by forcing the OS to write any pending data
* to disk. This is done only for channels which are dirty, i.e. have been
* written to since the last flush here.
*/
TclWinFlushDirtyChannels();
return NativeStat((const WCHAR *)Tcl_FSGetNativePath(pathPtr), statPtr, 0);
}
/*
*----------------------------------------------------------------------
*
* NativeStat --
*
|
| ︙ | ︙ | |||
2039 2040 2041 2042 2043 2044 2045 |
* CON, NULL, COM1, LPT1 etc. For these, we still need to do the
* CreateFile as some may not exist (e.g. there is no CON in wish by
* default). However the subsequent GetFileInformationByHandle will
* fail. We do a WinIsReserved to see if it is one of the special names,
* and if successful, mock up a BY_HANDLE_FILE_INFORMATION structure.
*/
| | | 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 |
* CON, NULL, COM1, LPT1 etc. For these, we still need to do the
* CreateFile as some may not exist (e.g. there is no CON in wish by
* default). However the subsequent GetFileInformationByHandle will
* fail. We do a WinIsReserved to see if it is one of the special names,
* and if successful, mock up a BY_HANDLE_FILE_INFORMATION structure.
*/
fileHandle = CreateFileW(nativePath, GENERIC_READ,
FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE,
NULL, OPEN_EXISTING,
FILE_FLAG_BACKUP_SEMANTICS | FILE_FLAG_OPEN_REPARSE_POINT, NULL);
if (fileHandle != INVALID_HANDLE_VALUE) {
BY_HANDLE_FILE_INFORMATION data;
|
| ︙ | ︙ | |||
2097 2098 2099 2100 2101 2102 2103 |
} else {
/*
* Fall back on the less capable routines. This means no nlink or ino.
*/
WIN32_FILE_ATTRIBUTE_DATA data;
| | | | | 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 |
} else {
/*
* Fall back on the less capable routines. This means no nlink or ino.
*/
WIN32_FILE_ATTRIBUTE_DATA data;
if (GetFileAttributesExW(nativePath,
GetFileExInfoStandard, &data) != TRUE) {
HANDLE hFind;
WIN32_FIND_DATAW ffd;
DWORD lasterror = GetLastError();
if (lasterror != ERROR_SHARING_VIOLATION) {
TclWinConvertError(lasterror);
return -1;
}
hFind = FindFirstFileW(nativePath, &ffd);
if (hFind == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
return -1;
}
memcpy(&data, &ffd, sizeof(data));
FindClose(hFind);
}
|
| ︙ | ︙ | |||
2165 2166 2167 2168 2169 2170 2171 |
{
int dev;
Tcl_DString ds;
WCHAR nativeFullPath[MAX_PATH];
WCHAR *nativePart;
const char *fullPath;
| | > | | > | | | | | 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 |
{
int dev;
Tcl_DString ds;
WCHAR nativeFullPath[MAX_PATH];
WCHAR *nativePart;
const char *fullPath;
GetFullPathNameW(nativePath, MAX_PATH, nativeFullPath, &nativePart);
Tcl_DStringInit(&ds);
fullPath = Tcl_WCharToUtfDString(nativeFullPath, -1, &ds);
if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
const char *p;
DWORD dw;
const WCHAR *nativeVol;
Tcl_DString volString;
p = strchr(fullPath + 2, '\\');
p = strchr(p + 1, '\\');
if (p == NULL) {
/*
* Add terminating backslash to fullpath or GetVolumeInformationW()
* won't work.
*/
fullPath = TclDStringAppendLiteral(&ds, "\\");
p = fullPath + Tcl_DStringLength(&ds);
} else {
p++;
}
Tcl_DStringInit(&volString);
nativeVol = Tcl_UtfToWCharDString(fullPath, p - fullPath, &volString);
dw = (DWORD) -1;
GetVolumeInformationW(nativeVol, NULL, 0, &dw, NULL, NULL, NULL, 0);
/*
* GetFullPathNameW() turns special devices like "NUL" into "\\.\NUL",
* but GetVolumeInformationW() returns failure for "\\.\NUL". This will
* cause "NUL" to get a drive number of -1, which makes about as much
* sense as anything since the special devices don't live on any
* drive.
*/
dev = dw;
Tcl_DStringFree(&volString);
|
| ︙ | ︙ | |||
2335 2336 2337 2338 2339 2340 2341 |
ClientData
TclpGetNativeCwd(
ClientData clientData)
{
WCHAR buffer[MAX_PATH];
| | | | | | | | 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 |
ClientData
TclpGetNativeCwd(
ClientData clientData)
{
WCHAR buffer[MAX_PATH];
if (GetCurrentDirectoryW(MAX_PATH, buffer) == 0) {
TclWinConvertError(GetLastError());
return NULL;
}
if (clientData != NULL) {
if (wcscmp((const WCHAR *) clientData, buffer) == 0) {
return clientData;
}
}
return TclNativeDupInternalRep(buffer);
}
int
TclpObjAccess(
Tcl_Obj *pathPtr,
int mode)
{
return NativeAccess((const WCHAR *)Tcl_FSGetNativePath(pathPtr), mode);
}
int
TclpObjLstat(
Tcl_Obj *pathPtr,
Tcl_StatBuf *statPtr)
{
/*
* Ensure correct file sizes by forcing the OS to write any pending data
* to disk. This is done only for channels which are dirty, i.e. have been
* written to since the last flush here.
*/
TclWinFlushDirtyChannels();
return NativeStat((const WCHAR *)Tcl_FSGetNativePath(pathPtr), statPtr, 1);
}
#ifdef S_IFLNK
Tcl_Obj *
TclpObjLink(
Tcl_Obj *pathPtr,
Tcl_Obj *toPtr,
int linkAction)
{
if (toPtr != NULL) {
int res;
const WCHAR *LinkTarget;
const WCHAR *LinkSource = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
Tcl_Obj *normalizedToPtr = Tcl_FSGetNormalizedPath(NULL, toPtr);
if (normalizedToPtr == NULL) {
return NULL;
}
LinkTarget = (const WCHAR *)Tcl_FSGetNativePath(normalizedToPtr);
if (LinkSource == NULL || LinkTarget == NULL) {
return NULL;
}
res = WinLink(LinkSource, LinkTarget, linkAction);
if (res == 0) {
return toPtr;
} else {
return NULL;
}
} else {
const WCHAR *LinkSource = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (LinkSource == NULL) {
return NULL;
}
return WinReadLink(LinkSource);
}
}
|
| ︙ | ︙ | |||
2444 2445 2446 2447 2448 2449 2450 |
char *firstSeparator;
const char *path;
Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normPath == NULL) {
return NULL;
}
| | | | > | | 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 |
char *firstSeparator;
const char *path;
Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normPath == NULL) {
return NULL;
}
path = Tcl_GetString(normPath);
if (path == NULL) {
return NULL;
}
firstSeparator = strchr(path, '/');
if (firstSeparator == NULL) {
found = GetVolumeInformationW((const WCHAR *)Tcl_FSGetNativePath(pathPtr),
NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE);
} else {
Tcl_Obj *driveName = Tcl_NewStringObj(path, firstSeparator - path+1);
Tcl_IncrRefCount(driveName);
found = GetVolumeInformationW((const WCHAR *)Tcl_FSGetNativePath(driveName),
NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE);
Tcl_DecrRefCount(driveName);
}
if (found == 0) {
return NULL;
} else {
Tcl_DString ds;
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString(volType, -1, &ds);
return TclDStringToObj(&ds);
}
#undef VOL_BUF_SIZE
}
/*
* This define can be turned on to experiment with a different way of
|
| ︙ | ︙ | |||
2510 2511 2512 2513 2514 2515 2516 | * modified in place. * *--------------------------------------------------------------------------- */ int TclpObjNormalizePath( | | | > | | | > > > | | | | 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 |
* modified in place.
*
*---------------------------------------------------------------------------
*/
int
TclpObjNormalizePath(
TCL_UNUSED(Tcl_Interp *),
Tcl_Obj *pathPtr, /* An unshared object containing the path to
* normalize */
int nextCheckpoint) /* offset to start at in pathPtr */
{
char *lastValidPathEnd = NULL;
Tcl_DString dsNorm; /* This will hold the normalized string. */
char *path, *currentPathEndPosition;
Tcl_Obj *temp = NULL;
int isDrive = 1;
Tcl_DString ds; /* Some workspace. */
Tcl_DStringInit(&dsNorm);
path = Tcl_GetString(pathPtr);
currentPathEndPosition = path + nextCheckpoint;
if (*currentPathEndPosition == '/') {
currentPathEndPosition++;
}
while (1) {
char cur = *currentPathEndPosition;
if ((cur=='/' || cur==0) && (path != currentPathEndPosition)) {
/*
* Reached directory separator, or end of string.
*/
WIN32_FILE_ATTRIBUTE_DATA data;
const WCHAR *nativePath;
Tcl_DStringInit(&ds);
nativePath = Tcl_UtfToWCharDString(path,
currentPathEndPosition - path, &ds);
if (GetFileAttributesExW(nativePath,
GetFileExInfoStandard, &data) != TRUE) {
/*
* File doesn't exist.
*/
if (isDrive) {
int len = WinIsReserved(path);
if (len > 0) {
/*
* Actually it does exist - COM1, etc.
*/
int i;
for (i=0 ; i<len ; i++) {
WCHAR wc = ((WCHAR *) nativePath)[i];
if (wc >= 'a') {
wc -= ('a' - 'A');
((WCHAR *) nativePath)[i] = wc;
}
}
Tcl_DStringAppend(&dsNorm,
(const char *)nativePath,
(int)(sizeof(WCHAR) * len));
lastValidPathEnd = currentPathEndPosition;
|
| ︙ | ︙ | |||
2617 2618 2619 2620 2621 2622 2623 | nextCheckpoint = 0; Tcl_AppendToObj(to, currentPathEndPosition, -1); /* * Convert link to forward slashes. */ | | | | 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 |
nextCheckpoint = 0;
Tcl_AppendToObj(to, currentPathEndPosition, -1);
/*
* Convert link to forward slashes.
*/
for (path = Tcl_GetString(to); *path != 0; path++) {
if (*path == '\\') {
*path = '/';
}
}
path = Tcl_GetString(to);
currentPathEndPosition = path + nextCheckpoint;
if (temp != NULL) {
Tcl_DecrRefCount(temp);
}
temp = to;
/*
|
| ︙ | ︙ | |||
2650 2651 2652 2653 2654 2655 2656 |
* and append it to 'dsNorm' which holds the current normalized
* path
*/
if (isDrive) {
WCHAR drive = ((WCHAR *) nativePath)[0];
| | | | 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 |
* and append it to 'dsNorm' which holds the current normalized
* path
*/
if (isDrive) {
WCHAR drive = ((WCHAR *) nativePath)[0];
if (drive >= 'a') {
drive -= ('a' - 'A');
((WCHAR *) nativePath)[0] = drive;
}
Tcl_DStringAppend(&dsNorm, (const char *)nativePath,
Tcl_DStringLength(&ds));
} else {
char *checkDots = NULL;
|
| ︙ | ︙ | |||
2739 2740 2741 2742 2743 2744 2745 |
#ifdef TclNORM_LONG_PATH
/*
* Convert the entire known path to long form.
*/
if (1) {
WCHAR wpath[MAX_PATH];
| | > > > > | | < | | > | | > < | | | 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 |
#ifdef TclNORM_LONG_PATH
/*
* Convert the entire known path to long form.
*/
if (1) {
WCHAR wpath[MAX_PATH];
const WCHAR *nativePath;
DWORD wpathlen;
Tcl_DStringInit(&ds);
nativePath =
Tcl_UtfToWCharDString(path, lastValidPathEnd - path, &ds);
wpathlen = GetLongPathNameProc(nativePath,
(WCHAR *) wpath, MAX_PATH);
/*
* We have to make the drive letter uppercase.
*/
if (wpath[0] >= 'a') {
wpath[0] -= ('a' - 'A');
}
Tcl_DStringAppend(&dsNorm, (const char *) wpath,
wpathlen * sizeof(WCHAR));
Tcl_DStringFree(&ds);
}
#endif /* TclNORM_LONG_PATH */
}
/*
* Common code path for all Windows platforms.
*/
nextCheckpoint = currentPathEndPosition - path;
if (lastValidPathEnd != NULL) {
/*
* Concatenate the normalized string in dsNorm with the tail of the
* path which we didn't recognise. The string in dsNorm is in the
* native encoding, so we have to convert it to Utf.
*/
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString((const WCHAR *) Tcl_DStringValue(&dsNorm),
Tcl_DStringLength(&dsNorm)>>1, &ds);
nextCheckpoint = Tcl_DStringLength(&ds);
if (*lastValidPathEnd != 0) {
/*
* Not the end of the string.
*/
int len;
char *path;
Tcl_Obj *tmpPathPtr;
tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
nextCheckpoint);
Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1);
path = TclGetStringFromObj(tmpPathPtr, &len);
Tcl_SetStringObj(pathPtr, path, len);
Tcl_DecrRefCount(tmpPathPtr);
} else {
/*
* End of string was reached above.
*/
Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds), nextCheckpoint);
|
| ︙ | ︙ | |||
2854 2855 2856 2857 2858 2859 2860 |
if (path[0] == '/') {
/*
* Path of form /foo/bar which is a path in the root directory of the
* current volume.
*/
| | | | 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 |
if (path[0] == '/') {
/*
* Path of form /foo/bar which is a path in the root directory of the
* current volume.
*/
const char *drive = Tcl_GetString(useThisCwd);
absolutePath = Tcl_NewStringObj(drive,2);
Tcl_AppendToObj(absolutePath, path, -1);
Tcl_IncrRefCount(absolutePath);
/*
* We have a refCount on the cwd.
*/
} else {
/*
* Path of form C:foo/bar, but this only makes sense if the cwd is
* also on drive C.
*/
int cwdLen;
const char *drive = TclGetStringFromObj(useThisCwd, &cwdLen);
char drive_cur = path[0];
if (drive_cur >= 'a') {
drive_cur -= ('a' - 'A');
}
if (drive[0] == drive_cur) {
|
| ︙ | ︙ | |||
2943 2944 2945 2946 2947 2948 2949 |
Tcl_Obj *
TclpNativeToNormalized(
ClientData clientData)
{
Tcl_DString ds;
Tcl_Obj *objPtr;
| | > | | 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 |
Tcl_Obj *
TclpNativeToNormalized(
ClientData clientData)
{
Tcl_DString ds;
Tcl_Obj *objPtr;
int len;
char *copy, *p;
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString((const WCHAR *) clientData, -1, &ds);
copy = Tcl_DStringValue(&ds);
len = Tcl_DStringLength(&ds);
/*
* Certain native path representations on Windows have this special prefix
* to indicate that they are to be treated specially. For example
* extremely long paths, or symlinks.
|
| ︙ | ︙ | |||
2993 2994 2995 2996 2997 2998 2999 | * * Create a native representation for the given path. * * Results: * The nativePath representation. * * Side effects: | | | 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 3043 |
*
* Create a native representation for the given path.
*
* Results:
* The nativePath representation.
*
* Side effects:
* Memory will be allocated. The path might be normalized.
*
*---------------------------------------------------------------------------
*/
ClientData
TclNativeCreateNativeRep(
Tcl_Obj *pathPtr)
|
| ︙ | ︙ | |||
3042 3043 3044 3045 3046 3047 3048 |
* validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl,
* so incr refCount here
*/
Tcl_IncrRefCount(validPathPtr);
}
| > | | 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 |
* validPathPtr returned from Tcl_FSGetNormalizedPath is owned by Tcl,
* so incr refCount here
*/
Tcl_IncrRefCount(validPathPtr);
}
str = Tcl_GetString(validPathPtr);
len = validPathPtr->length;
if (strlen(str) != len) {
/*
* String contains NUL-bytes. This is invalid.
*/
goto done;
|
| ︙ | ︙ | |||
3073 3074 3075 3076 3077 3078 3079 |
}
}
/*
* Overallocate 6 chars, making some room for extended paths
*/
| | | 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 |
}
}
/*
* Overallocate 6 chars, making some room for extended paths
*/
wp = nativePathPtr = (WCHAR *)ckalloc((len + 6) * sizeof(WCHAR));
if (nativePathPtr==0) {
goto done;
}
MultiByteToWideChar(CP_UTF8, MB_ERR_INVALID_CHARS, str, -1, nativePathPtr,
len + 1);
/*
|
| ︙ | ︙ | |||
3171 3172 3173 3174 3175 3176 3177 |
if (clientData == NULL) {
return NULL;
}
len = sizeof(WCHAR) * (wcslen((const WCHAR *) clientData) + 1);
| | | 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 |
if (clientData == NULL) {
return NULL;
}
len = sizeof(WCHAR) * (wcslen((const WCHAR *) clientData) + 1);
copy = (char *)ckalloc(len);
memcpy(copy, clientData, len);
return copy;
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3208 3209 3210 3211 3212 3213 3214 |
DWORD attr = 0;
DWORD flags = FILE_ATTRIBUTE_NORMAL;
FILETIME lastAccessTime, lastModTime;
FromCTime(tval->actime, &lastAccessTime);
FromCTime(tval->modtime, &lastModTime);
| | | | | 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 |
DWORD attr = 0;
DWORD flags = FILE_ATTRIBUTE_NORMAL;
FILETIME lastAccessTime, lastModTime;
FromCTime(tval->actime, &lastAccessTime);
FromCTime(tval->modtime, &lastModTime);
native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
attr = GetFileAttributesW(native);
if (attr != INVALID_FILE_ATTRIBUTES && attr & FILE_ATTRIBUTE_DIRECTORY) {
flags = FILE_FLAG_BACKUP_SEMANTICS;
}
/*
* We use the native APIs (not 'utime') because there are some daylight
* savings complications that utime gets wrong.
*/
fileHandle = CreateFileW(native, FILE_WRITE_ATTRIBUTES, 0, NULL,
OPEN_EXISTING, flags, NULL);
if (fileHandle == INVALID_HANDLE_VALUE ||
!SetFileTime(fileHandle, NULL, &lastAccessTime, &lastModTime)) {
TclWinConvertError(GetLastError());
res = -1;
}
|
| ︙ | ︙ | |||
3259 3260 3261 3262 3263 3264 3265 |
PSID ownerSid = NULL;
PSECURITY_DESCRIPTOR secd = NULL;
HANDLE token;
LPBYTE buf = NULL;
DWORD bufsz;
int owned = 0;
| | | | 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 |
PSID ownerSid = NULL;
PSECURITY_DESCRIPTOR secd = NULL;
HANDLE token;
LPBYTE buf = NULL;
DWORD bufsz;
int owned = 0;
native = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (GetNamedSecurityInfoW((LPWSTR) native, SE_FILE_OBJECT,
OWNER_SECURITY_INFORMATION, &ownerSid, NULL, NULL, NULL,
&secd) != ERROR_SUCCESS) {
/*
* Either not a file, or we do not have access to it in which case we
* are in all likelihood not the owner.
*/
|
| ︙ | ︙ | |||
3287 3288 3289 3290 3291 3292 3293 |
/*
* Find out how big the buffer needs to be.
*/
bufsz = 0;
GetTokenInformation(token, TokenUser, NULL, 0, &bufsz);
if (bufsz) {
| | | | 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 |
/*
* Find out how big the buffer needs to be.
*/
bufsz = 0;
GetTokenInformation(token, TokenUser, NULL, 0, &bufsz);
if (bufsz) {
buf = (LPBYTE)ckalloc(bufsz);
if (GetTokenInformation(token, TokenUser, buf, bufsz, &bufsz)) {
owned = EqualSid(ownerSid, ((PTOKEN_USER) buf)->User.Sid);
}
}
CloseHandle(token);
}
/*
* Free allocations and be done.
*/
if (secd) {
LocalFree(secd); /* Also frees ownerSid */
}
if (buf) {
ckfree(buf);
}
return (owned != 0); /* Convert non-0 to 1 */
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinInit.c.
| ︙ | ︙ | |||
13 14 15 16 17 18 19 | #include "tclWinInt.h" #include <winnt.h> #include <winbase.h> #include <lmcons.h> /* | | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | #include "tclWinInt.h" #include <winnt.h> #include <winbase.h> #include <lmcons.h> /* * GetUserNameW() is found in advapi32.dll */ #ifdef _MSC_VER # pragma comment(lib, "advapi32.lib") #endif /* * The following declaration is a workaround for some Microsoft brain damage. |
| ︙ | ︙ | |||
79 80 81 82 83 84 85 | /* * Windows version dependend functions */ TclWinProcs tclWinProcs; /* | | < | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 |
/*
* Windows version dependend functions
*/
TclWinProcs tclWinProcs;
/*
* The following arrays contain the human readable strings for the
* processor values.
*/
#define NUMPROCESSORS 11
static const char *const processors[NUMPROCESSORS] = {
"intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil",
"amd64", "ia32_on_win64"
};
|
| ︙ | ︙ | |||
109 110 111 112 113 114 115 | static void AppendEnvironment(Tcl_Obj *listPtr, const char *lib); /* *--------------------------------------------------------------------------- * * TclpInitPlatform -- * | | | 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 | static void AppendEnvironment(Tcl_Obj *listPtr, const char *lib); /* *--------------------------------------------------------------------------- * * TclpInitPlatform -- * * Initialize all the platform-dependent things like signals, * floating-point error handling and sockets. * * Called at process initialization time. * * Results: * None. * |
| ︙ | ︙ | |||
145 146 147 148 149 150 151 |
#ifdef STATIC_BUILD
/*
* If we are in a statically linked executable, then we need to explicitly
* initialize the Windows function tables here since DllMain() will not be
* invoked.
*/
| | | | | 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 |
#ifdef STATIC_BUILD
/*
* If we are in a statically linked executable, then we need to explicitly
* initialize the Windows function tables here since DllMain() will not be
* invoked.
*/
TclWinInit(GetModuleHandleW(NULL));
#endif
/*
* Fill available functions depending on windows version
*/
handle = GetModuleHandleW(L"KERNEL32");
tclWinProcs.cancelSynchronousIo =
(BOOL (WINAPI *)(HANDLE))(void *)GetProcAddress(handle,
"CancelSynchronousIo");
}
/*
*-------------------------------------------------------------------------
*
* TclpInitLibraryPath --
|
| ︙ | ︙ | |||
177 178 179 180 181 182 183 |
*
*-------------------------------------------------------------------------
*/
void
TclpInitLibraryPath(
char **valuePtr,
| | | | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 |
*
*-------------------------------------------------------------------------
*/
void
TclpInitLibraryPath(
char **valuePtr,
unsigned int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
#define LIBRARY_SIZE 64
Tcl_Obj *pathPtr;
char installLib[LIBRARY_SIZE];
const char *bytes;
int length;
pathPtr = Tcl_NewObj();
/*
* Initialize the substring used when locating the script library. The
* installLib variable computes the script library path relative to the
* installed DLL.
|
| ︙ | ︙ | |||
222 223 224 225 226 227 228 |
Tcl_ListObjAppendElement(NULL, pathPtr,
TclGetProcessGlobalValue(&sourceLibraryDir));
*encodingPtr = NULL;
bytes = TclGetStringFromObj(pathPtr, &length);
*lengthPtr = length++;
| | | 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 |
Tcl_ListObjAppendElement(NULL, pathPtr,
TclGetProcessGlobalValue(&sourceLibraryDir));
*encodingPtr = NULL;
bytes = TclGetStringFromObj(pathPtr, &length);
*lengthPtr = length++;
*valuePtr = (char *)ckalloc(length);
memcpy(*valuePtr, bytes, length);
Tcl_DecrRefCount(pathPtr);
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
293 294 295 296 297 298 299 | objPtr = Tcl_NewStringObj(buf, -1); Tcl_ListObjAppendElement(NULL, pathPtr, objPtr); TclWinNoBackslash(buf); Tcl_SplitPath(buf, &pathc, &pathv); /* | | | | 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 |
objPtr = Tcl_NewStringObj(buf, -1);
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
TclWinNoBackslash(buf);
Tcl_SplitPath(buf, &pathc, &pathv);
/*
* The lstrcmpiA() will work even if pathv[pathc-1] is random UTF-8
* chars because I know shortlib is ascii.
*/
if ((pathc > 0) && (lstrcmpiA(shortlib, pathv[pathc - 1]) != 0)) {
/*
* TCL_LIBRARY is set but refers to a different tcl installation
* than the current version. Try fiddling with the specified
* directory to make it refer to this installation by removing the
* old "tclX.Y" and substituting the current version string.
*/
pathv[pathc - 1] = shortlib;
Tcl_DStringInit(&ds);
(void) Tcl_JoinPath(pathc, pathv, &ds);
objPtr = TclDStringToObj(&ds);
} else {
objPtr = Tcl_NewStringObj(buf, -1);
}
Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
ckfree(pathv);
}
}
/*
*---------------------------------------------------------------------------
*
* InitializeDefaultLibraryDir --
|
| ︙ | ︙ | |||
337 338 339 340 341 342 343 |
*
*---------------------------------------------------------------------------
*/
static void
InitializeDefaultLibraryDir(
char **valuePtr,
| | | 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 |
*
*---------------------------------------------------------------------------
*/
static void
InitializeDefaultLibraryDir(
char **valuePtr,
unsigned int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
HMODULE hModule = TclWinGetTclInstance();
WCHAR wName[MAX_PATH + LIBRARY_SIZE];
char name[(MAX_PATH + LIBRARY_SIZE) * 3];
char *end, *p;
|
| ︙ | ︙ | |||
359 360 361 362 363 364 365 |
end = p;
}
*end = '\\';
TclWinNoBackslash(name);
sprintf(end + 1, "lib/tcl%s", TCL_VERSION);
*lengthPtr = strlen(name);
| | | 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 |
end = p;
}
*end = '\\';
TclWinNoBackslash(name);
sprintf(end + 1, "lib/tcl%s", TCL_VERSION);
*lengthPtr = strlen(name);
*valuePtr = (char *)ckalloc(*lengthPtr + 1);
*encodingPtr = NULL;
memcpy(*valuePtr, name, *lengthPtr + 1);
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
385 386 387 388 389 390 391 |
*
*---------------------------------------------------------------------------
*/
static void
InitializeSourceLibraryDir(
char **valuePtr,
| | | 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 |
*
*---------------------------------------------------------------------------
*/
static void
InitializeSourceLibraryDir(
char **valuePtr,
unsigned int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
HMODULE hModule = TclWinGetTclInstance();
WCHAR wName[MAX_PATH + LIBRARY_SIZE];
char name[(MAX_PATH + LIBRARY_SIZE) * 3];
char *end, *p;
|
| ︙ | ︙ | |||
407 408 409 410 411 412 413 |
end = p;
}
*end = '\\';
TclWinNoBackslash(name);
sprintf(end + 1, "../library");
*lengthPtr = strlen(name);
| | | 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 |
end = p;
}
*end = '\\';
TclWinNoBackslash(name);
sprintf(end + 1, "../library");
*lengthPtr = strlen(name);
*valuePtr = (char *)ckalloc(*lengthPtr + 1);
*encodingPtr = NULL;
memcpy(*valuePtr, name, *lengthPtr + 1);
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
450 451 452 453 454 455 456 457 |
Tcl_DStringFree(&encodingName);
}
const char *
Tcl_GetEncodingNameFromEnvironment(
Tcl_DString *bufPtr)
{
Tcl_DStringInit(bufPtr);
| > > > > > | | | > | | | | 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 |
Tcl_DStringFree(&encodingName);
}
const char *
Tcl_GetEncodingNameFromEnvironment(
Tcl_DString *bufPtr)
{
UINT acp = GetACP();
Tcl_DStringInit(bufPtr);
if (acp == CP_UTF8) {
Tcl_DStringAppend(bufPtr, "utf-8", 5);
} else {
Tcl_DStringSetLength(bufPtr, 2+TCL_INTEGER_SPACE);
wsprintfA(Tcl_DStringValue(bufPtr), "cp%d", GetACP());
Tcl_DStringSetLength(bufPtr, strlen(Tcl_DStringValue(bufPtr)));
}
return Tcl_DStringValue(bufPtr);
}
const char *
TclpGetUserName(
Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with
* the name of user. */
{
Tcl_DStringInit(bufferPtr);
if (TclGetEnv("USERNAME", bufferPtr) == NULL) {
WCHAR szUserName[UNLEN+1];
DWORD cchUserNameLen = UNLEN;
if (!GetUserNameW(szUserName, &cchUserNameLen)) {
return NULL;
}
cchUserNameLen--;
Tcl_DStringInit(bufferPtr);
Tcl_WCharToUtfDString(szUserName, cchUserNameLen, bufferPtr);
}
return Tcl_DStringValue(bufferPtr);
}
/*
*---------------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
513 514 515 516 517 518 519 |
static int osInfoInitialized = 0;
Tcl_DString ds;
Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL,
TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY);
if (!osInfoInitialized) {
| | | | > | | 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 |
static int osInfoInitialized = 0;
Tcl_DString ds;
Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL,
TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY);
if (!osInfoInitialized) {
HMODULE handle = GetModuleHandleW(L"NTDLL");
int(__stdcall *getversion)(void *) =
(int(__stdcall *)(void *))(void *)GetProcAddress(handle, "RtlGetVersion");
osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW);
if (!getversion || getversion(&osInfo)) {
GetVersionExW(&osInfo);
}
osInfoInitialized = 1;
}
GetSystemInfo(&sys.info);
/*
* Define the tcl_platform array.
*/
Tcl_SetVar2(interp, "tcl_platform", "platform", "windows",
TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tcl_platform", "os",
"Windows NT", TCL_GLOBAL_ONLY);
wsprintfA(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY);
if (sys.oemId.wProcessorArchitecture < NUMPROCESSORS) {
Tcl_SetVar2(interp, "tcl_platform", "machine",
processors[sys.oemId.wProcessorArchitecture],
TCL_GLOBAL_ONLY);
}
#ifndef NDEBUG
/*
* The existence of the "debug" element of the tcl_platform array
* indicates that this particular Tcl shell has been compiled with debug
* information. Using "info exists tcl_platform(debug)" a Tcl script can
* direct the interpreter to load debug versions of DLLs with the load
* command.
*/
|
| ︙ | ︙ | |||
604 605 606 607 608 609 610 | * TclpFindVariable -- * * Locate the entry in environ for a given name. On Unix this routine is * case sensitive, on Windows this matches mixed case. * * Results: * The return value is the index in environ of an entry with the name | | | | < > > | > | | > | | | > > > | | | 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 |
* TclpFindVariable --
*
* Locate the entry in environ for a given name. On Unix this routine is
* case sensitive, on Windows this matches mixed case.
*
* Results:
* The return value is the index in environ of an entry with the name
* "name", or -1 if there is no such entry. The integer at *lengthPtr is
* filled in with the length of name (if a matching entry is found) or
* the length of the environ array (if no matching entry is found).
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
# define tenviron2utfdstr(string, len, dsPtr) \
(char *)Tcl_Char16ToUtfDString((const unsigned short *)(string), ((((len) + 2) >> 1) - 1), (dsPtr))
int
TclpFindVariable(
const char *name, /* Name of desired environment variable
* (UTF-8). */
int *lengthPtr) /* Used to return length of name (for
* successful searches) or number of non-NULL
* entries in environ (for unsuccessful
* searches). */
{
int i, length, result = -1;
const WCHAR *env;
const char *p1, *p2;
char *envUpper, *nameUpper;
Tcl_DString envString;
/*
* Convert the name to all upper case for the case insensitive comparison.
*/
length = strlen(name);
nameUpper = (char *)ckalloc(length + 1);
memcpy(nameUpper, name, length+1);
Tcl_UtfToUpper(nameUpper);
Tcl_DStringInit(&envString);
for (i = 0, env = _wenviron[i];
env != NULL;
i++, env = _wenviron[i]) {
/*
* Chop the env string off after the equal sign, then Convert the name
* to all upper case, so we do not have to convert all the characters
* after the equal sign.
*/
Tcl_DStringInit(&envString);
envUpper = Tcl_WCharToUtfDString(env, -1, &envString);
p1 = strchr(envUpper, '=');
if (p1 == NULL) {
continue;
}
length = (int) (p1 - envUpper);
Tcl_DStringSetLength(&envString, length+1);
Tcl_UtfToUpper(envUpper);
p1 = envUpper;
p2 = nameUpper;
for (; *p2 == *p1; p1++, p2++) {
/* NULL loop body. */
|
| ︙ | ︙ | |||
673 674 675 676 677 678 679 |
Tcl_DStringFree(&envString);
}
*lengthPtr = i;
done:
Tcl_DStringFree(&envString);
| | | 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 |
Tcl_DStringFree(&envString);
}
*lengthPtr = i;
done:
Tcl_DStringFree(&envString);
ckfree(nameUpper);
return result;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinInt.h.
| ︙ | ︙ | |||
43 44 45 46 47 48 49 | /* * Declarations of functions that are not accessible by way of the * stubs table. */ MODULE_SCOPE char TclWinDriveLetterForVolMountPoint( const WCHAR *mountPoint); | | | | | | 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 | /* * Declarations of functions that are not accessible by way of the * stubs table. */ MODULE_SCOPE char TclWinDriveLetterForVolMountPoint( const WCHAR *mountPoint); MODULE_SCOPE void TclWinEncodingsCleanup(void); MODULE_SCOPE void TclWinInit(HINSTANCE hInst); MODULE_SCOPE TclFile TclWinMakeFile(HANDLE handle); MODULE_SCOPE Tcl_Channel TclWinOpenConsoleChannel(HANDLE handle, char *channelName, int permissions); MODULE_SCOPE Tcl_Channel TclWinOpenFileChannel(HANDLE handle, char *channelName, int permissions, int appendMode); MODULE_SCOPE Tcl_Channel TclWinOpenSerialChannel(HANDLE handle, char *channelName, int permissions); MODULE_SCOPE HANDLE TclWinSerialOpen(HANDLE handle, const WCHAR *name, DWORD access); MODULE_SCOPE int TclWinSymLinkCopyDirectory(const WCHAR *LinkOriginal, const WCHAR *LinkCopy); MODULE_SCOPE int TclWinSymLinkDelete(const WCHAR *LinkOriginal, int linkOnly); MODULE_SCOPE int TclWinFileOwned(Tcl_Obj *); MODULE_SCOPE const char*TclpGetUserName(Tcl_DString *bufferPtr); /* Needed by tclWinFile.c and tclWinFCmd.c */ #ifndef FILE_ATTRIBUTE_REPARSE_POINT |
| ︙ | ︙ | |||
81 82 83 84 85 86 87 |
typedef struct TclPipeThreadInfo {
HANDLE evControl; /* Auto-reset event used by the main thread to
* signal when the pipe thread should attempt
* to do read/write operation. Additionally
* used as signal to stop (state set to -1) */
volatile LONG state; /* Indicates current state of the thread */
| | | | 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 |
typedef struct TclPipeThreadInfo {
HANDLE evControl; /* Auto-reset event used by the main thread to
* signal when the pipe thread should attempt
* to do read/write operation. Additionally
* used as signal to stop (state set to -1) */
volatile LONG state; /* Indicates current state of the thread */
ClientData clientData; /* Referenced data of the main thread */
HANDLE evWakeUp; /* Optional wake-up event worker set by shutdown */
} TclPipeThreadInfo;
/* If pipe-workers will use some tcl subsystem, we can use ckalloc without
* more overhead for finalize thread (should be executed anyway)
*
* #define _PTI_USE_CKALLOC 1
*/
/*
* State of the pipe-worker.
|
| ︙ | ︙ | |||
108 109 110 111 112 113 114 | #define PTI_STATE_STOP 2 /* thread should stop work (owns TI structure) */ #define PTI_STATE_END 4 /* thread should stop work (worker is busy) */ #define PTI_STATE_DOWN 8 /* worker is down */ MODULE_SCOPE TclPipeThreadInfo * TclPipeThreadCreateTI(TclPipeThreadInfo **pipeTIPtr, | | | 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 |
#define PTI_STATE_STOP 2 /* thread should stop work (owns TI structure) */
#define PTI_STATE_END 4 /* thread should stop work (worker is busy) */
#define PTI_STATE_DOWN 8 /* worker is down */
MODULE_SCOPE
TclPipeThreadInfo * TclPipeThreadCreateTI(TclPipeThreadInfo **pipeTIPtr,
ClientData clientData, HANDLE wakeEvent);
MODULE_SCOPE int TclPipeThreadWaitForSignal(TclPipeThreadInfo **pipeTIPtr);
static inline void
TclPipeThreadSignal(
TclPipeThreadInfo **pipeTIPtr)
{
TclPipeThreadInfo *pipeTI = *pipeTIPtr;
|
| ︙ | ︙ |
Changes to win/tclWinLoad.c.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr,
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for this
* file. */
| | | | | > | | | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 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 |
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr,
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for this
* file. */
TCL_UNUSED(int) /*flags*/)
{
HINSTANCE hInstance = NULL;
const WCHAR *nativeName;
Tcl_LoadHandle handlePtr;
DWORD firstError;
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
nativeName = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
if (nativeName != NULL) {
hInstance = LoadLibraryExW(nativeName, NULL,
LOAD_WITH_ALTERED_SEARCH_PATH);
}
if (hInstance == NULL) {
/*
* Let the OS loader examine the binary search path for whatever
* string the user gave us which hopefully refers to a file on the
* binary path.
*/
Tcl_DString ds;
/*
* Remember the first error on load attempt to be used if the
* second load attempt below also fails.
*/
firstError = (nativeName == NULL) ?
ERROR_MOD_NOT_FOUND : GetLastError();
Tcl_DStringInit(&ds);
nativeName = Tcl_UtfToWCharDString(Tcl_GetString(pathPtr), -1, &ds);
hInstance = LoadLibraryExW(nativeName, NULL,
LOAD_WITH_ALTERED_SEARCH_PATH);
Tcl_DStringFree(&ds);
}
if (hInstance == NULL) {
DWORD lastError;
Tcl_Obj *errMsg;
/*
* We choose to only use the error from the second call if the first
* call failed due to the file not being found. Else stick to the
* first error for reporting purposes.
*/
if (firstError == ERROR_MOD_NOT_FOUND ||
firstError == ERROR_DLL_NOT_FOUND)
lastError = GetLastError();
else
lastError = firstError;
errMsg = Tcl_ObjPrintf("couldn't load library \"%s\": ",
Tcl_GetString(pathPtr));
/*
* Check for possible DLL errors. This doesn't work quite right,
* because Windows seems to only return ERROR_MOD_NOT_FOUND for just
* about any problem, but it's better than nothing. It'd be even
* better if there was a way to get what DLLs
*/
|
| ︙ | ︙ | |||
166 167 168 169 170 171 172 |
return TCL_ERROR;
}
/*
* Succeded; package everything up for Tcl.
*/
| | | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 |
return TCL_ERROR;
}
/*
* Succeded; package everything up for Tcl.
*/
handlePtr = (Tcl_LoadHandle)ckalloc(sizeof(struct Tcl_LoadHandle_));
handlePtr->clientData = (ClientData) hInstance;
handlePtr->findSymbolProcPtr = &FindSymbol;
handlePtr->unloadFileProcPtr = &UnloadFile;
*loadHandle = handlePtr;
*unloadProcPtr = &UnloadFile;
return TCL_OK;
}
|
| ︙ | ︙ | |||
198 199 200 201 202 203 204 |
static void *
FindSymbol(
Tcl_Interp *interp,
Tcl_LoadHandle loadHandle,
const char *symbol)
{
HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData;
| | | | | 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 |
static void *
FindSymbol(
Tcl_Interp *interp,
Tcl_LoadHandle loadHandle,
const char *symbol)
{
HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData;
void *proc = NULL;
/*
* For each symbol, check for both Symbol and _Symbol, since Borland
* generates C symbols with a leading '_' by default.
*/
proc = (void *)GetProcAddress(hInstance, symbol);
if (proc == NULL) {
Tcl_DString ds;
const char *sym2;
Tcl_DStringInit(&ds);
TclDStringAppendLiteral(&ds, "_");
sym2 = Tcl_DStringAppend(&ds, symbol, -1);
proc = (void *)GetProcAddress(hInstance, sym2);
Tcl_DStringFree(&ds);
}
if (proc == NULL && interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"cannot find symbol \"%s\"", symbol));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LOAD_SYMBOL", symbol, NULL);
}
|
| ︙ | ︙ | |||
251 252 253 254 255 256 257 |
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData;
FreeLibrary(hInstance);
| | | 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 |
Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to
* TclpDlopen(). The loadHandle is a token
* that represents the loaded file. */
{
HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData;
FreeLibrary(hInstance);
ckfree(loadHandle);
}
/*
*----------------------------------------------------------------------
*
* TclGuessPackageName --
*
|
| ︙ | ︙ | |||
276 277 278 279 280 281 282 | * None. * *---------------------------------------------------------------------- */ int TclGuessPackageName( | | < | < | 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 |
* None.
*
*----------------------------------------------------------------------
*/
int
TclGuessPackageName(
TCL_UNUSED(const char *),
TCL_UNUSED(Tcl_DString *))
{
return 0;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
412 413 414 415 416 417 418 |
return TCL_ERROR;
/*
* Store our computed value in the global.
*/
copyToGlobalBuffer:
| | | 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 |
return TCL_ERROR;
/*
* Store our computed value in the global.
*/
copyToGlobalBuffer:
dllDirectoryName = (WCHAR *)ckalloc((nameLen+1) * sizeof(WCHAR));
wcscpy(dllDirectoryName, name);
return TCL_OK;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinNotify.c.
| ︙ | ︙ | |||
45 46 47 48 49 50 51 | * The following static indicates the number of threads that have initialized * notifiers. It controls the lifetime of the TclNotifier window class. * * You must hold the notifierMutex lock before accessing this variable. */ static int notifierCount = 0; | | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | * The following static indicates the number of threads that have initialized * notifiers. It controls the lifetime of the TclNotifier window class. * * You must hold the notifierMutex lock before accessing this variable. */ static int notifierCount = 0; static const WCHAR className[] = L"TclNotifier"; static int initialized = 0; static CRITICAL_SECTION notifierMutex; /* * Static routines defined in this file. */ |
| ︙ | ︙ | |||
79 80 81 82 83 84 85 |
ClientData
Tcl_InitNotifier(void)
{
if (tclNotifierHooks.initNotifierProc) {
return tclNotifierHooks.initNotifierProc();
} else {
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
| < > > | | | | | | | | | | | | | 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 |
ClientData
Tcl_InitNotifier(void)
{
if (tclNotifierHooks.initNotifierProc) {
return tclNotifierHooks.initNotifierProc();
} else {
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
TclpMasterLock();
if (!initialized) {
initialized = 1;
InitializeCriticalSection(¬ifierMutex);
}
TclpMasterUnlock();
/*
* Register Notifier window class if this is the first thread to use
* this module.
*/
EnterCriticalSection(¬ifierMutex);
if (notifierCount == 0) {
WNDCLASSW clazz;
clazz.style = 0;
clazz.cbClsExtra = 0;
clazz.cbWndExtra = 0;
clazz.hInstance = TclWinGetTclInstance();
clazz.hbrBackground = NULL;
clazz.lpszMenuName = NULL;
clazz.lpszClassName = className;
clazz.lpfnWndProc = NotifierProc;
clazz.hIcon = NULL;
clazz.hCursor = NULL;
if (!RegisterClassW(&clazz)) {
Tcl_Panic("Unable to register TclNotifier window class");
}
}
notifierCount++;
LeaveCriticalSection(¬ifierMutex);
tsdPtr->pending = 0;
tsdPtr->timerActive = 0;
InitializeCriticalSection(&tsdPtr->crit);
tsdPtr->hwnd = NULL;
tsdPtr->thread = GetCurrentThreadId();
tsdPtr->event = CreateEventW(NULL, TRUE /* manual */,
FALSE /* !signaled */, NULL);
return tsdPtr;
}
}
/*
|
| ︙ | ︙ | |||
190 191 192 193 194 195 196 |
* notifier window class.
*/
EnterCriticalSection(¬ifierMutex);
if (notifierCount) {
notifierCount--;
if (notifierCount == 0) {
| | | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 |
* notifier window class.
*/
EnterCriticalSection(¬ifierMutex);
if (notifierCount) {
notifierCount--;
if (notifierCount == 0) {
UnregisterClassW(className, TclWinGetTclInstance());
}
}
LeaveCriticalSection(¬ifierMutex);
}
}
/*
|
| ︙ | ︙ | |||
242 243 244 245 246 247 248 |
if (tsdPtr->hwnd) {
/*
* We do need to lock around access to the pending flag.
*/
EnterCriticalSection(&tsdPtr->crit);
if (!tsdPtr->pending) {
| | | 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 |
if (tsdPtr->hwnd) {
/*
* We do need to lock around access to the pending flag.
*/
EnterCriticalSection(&tsdPtr->crit);
if (!tsdPtr->pending) {
PostMessageW(tsdPtr->hwnd, WM_WAKEUP, 0, 0);
}
tsdPtr->pending = 1;
LeaveCriticalSection(&tsdPtr->crit);
} else {
SetEvent(tsdPtr->event);
}
}
|
| ︙ | ︙ | |||
354 355 356 357 358 359 360 |
* or Windows will hang waiting for the window to respond to
* synchronous system messages. At some point, we may want to consider
* destroying the window if we leave the modal loop, but for now we'll
* leave it around.
*/
if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) {
| | | 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 |
* or Windows will hang waiting for the window to respond to
* synchronous system messages. At some point, we may want to consider
* destroying the window if we leave the modal loop, but for now we'll
* leave it around.
*/
if (mode == TCL_SERVICE_ALL && !tsdPtr->hwnd) {
tsdPtr->hwnd = CreateWindowW(className, className,
WS_TILED, 0, 0, 0, 0, NULL, NULL, TclWinGetTclInstance(),
NULL);
/*
* Send an initial message to the window to ensure that we wake up
* the notifier once we get into the modal loop. This will force
* the notifier to recompute the timeout value and schedule a timer
|
| ︙ | ︙ | |||
402 403 404 405 406 407 408 |
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (message == WM_WAKEUP) {
EnterCriticalSection(&tsdPtr->crit);
tsdPtr->pending = 0;
LeaveCriticalSection(&tsdPtr->crit);
} else if (message != WM_TIMER) {
| | | 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 |
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (message == WM_WAKEUP) {
EnterCriticalSection(&tsdPtr->crit);
tsdPtr->pending = 0;
LeaveCriticalSection(&tsdPtr->crit);
} else if (message != WM_TIMER) {
return DefWindowProcW(hwnd, message, wParam, lParam);
}
/*
* Process all of the runnable events.
*/
Tcl_ServiceAll();
|
| ︙ | ︙ | |||
474 475 476 477 478 479 480 | /* * Check to see if there are any messages in the queue before waiting * because MsgWaitForMultipleObjects will not wake up if there are * events currently sitting in the queue. */ | | | 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 |
/*
* Check to see if there are any messages in the queue before waiting
* because MsgWaitForMultipleObjects will not wake up if there are
* events currently sitting in the queue.
*/
if (!PeekMessageW(&msg, NULL, 0, 0, PM_NOREMOVE)) {
/*
* Wait for something to happen (a signal from another thread, a
* message, or timeout) or loop servicing asynchronous procedure
* calls queued to this thread.
*/
again:
|
| ︙ | ︙ | |||
496 497 498 499 500 501 502 | } } /* * Check to see if there are any messages to process. */ | | | | | 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 |
}
}
/*
* Check to see if there are any messages to process.
*/
if (PeekMessageW(&msg, NULL, 0, 0, PM_NOREMOVE)) {
/*
* Retrieve and dispatch the first message.
*/
result = GetMessageW(&msg, NULL, 0, 0);
if (result == 0) {
/*
* We received a request to exit this thread (WM_QUIT), so
* propagate the quit message and start unwinding.
*/
PostQuitMessage((int) msg.wParam);
status = -1;
} else if (result == (DWORD)-1) {
/*
* We got an error from the system. I have no idea why this
* would happen, so we'll just unwind.
*/
status = -1;
} else {
TranslateMessage(&msg);
DispatchMessageW(&msg);
status = 1;
}
} else {
status = 0;
}
end:
|
| ︙ | ︙ |
Changes to win/tclWinPanic.c.
|
| | | 1 2 3 4 5 6 7 8 | /* * tclWinPanic.c -- * * Contains the Windows-specific command-line panic proc. * * Copyright (c) 2013 by Jan Nijtmans. * All rights reserved. * |
| ︙ | ︙ | |||
24 25 26 27 28 29 30 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
Tcl_ConsolePanic(
const char *format, ...)
{
#define TCL_MAX_WARN_LEN 26000
va_list argList;
WCHAR msgString[TCL_MAX_WARN_LEN];
char buf[TCL_MAX_WARN_LEN * 3];
HANDLE handle = GetStdHandle(STD_ERROR_HANDLE);
DWORD dummy;
va_start(argList, format);
vsnprintf(buf+3, sizeof(buf)-3, format, argList);
buf[sizeof(buf)-1] = 0;
msgString[TCL_MAX_WARN_LEN-1] = '\0';
MultiByteToWideChar(CP_UTF8, 0, buf+3, -1, msgString, TCL_MAX_WARN_LEN);
/*
* Truncate MessageBox string if it is too long to not overflow the buffer.
*/
if (msgString[TCL_MAX_WARN_LEN-1] != '\0') {
memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR));
}
if (IsDebuggerPresent()) {
OutputDebugStringW(msgString);
} else if (_isatty(2)) {
WriteConsoleW(handle, msgString, wcslen(msgString), &dummy, 0);
|
| ︙ | ︙ |
Changes to win/tclWinPipe.c.
| ︙ | ︙ | |||
57 58 59 60 61 62 63 |
/*
* This list is used to map from pids to process handles.
*/
typedef struct ProcInfo {
HANDLE hProcess;
| | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 |
/*
* This list is used to map from pids to process handles.
*/
typedef struct ProcInfo {
HANDLE hProcess;
DWORD dwProcessId;
struct ProcInfo *nextPtr;
} ProcInfo;
static ProcInfo *procList;
/*
* Bit masks used in the flags field of the PipeInfo structure below.
|
| ︙ | ︙ | |||
306 307 308 309 310 311 312 | * Adjusts the block time if needed. * *---------------------------------------------------------------------- */ void PipeSetupProc( | | | 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 |
* Adjusts the block time if needed.
*
*----------------------------------------------------------------------
*/
void
PipeSetupProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
PipeInfo *infoPtr;
Tcl_Time blockTime = { 0, 0 };
int block = 1;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
359 360 361 362 363 364 365 | * May queue an event. * *---------------------------------------------------------------------- */ static void PipeCheckProc( | | | 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 |
* May queue an event.
*
*----------------------------------------------------------------------
*/
static void
PipeCheckProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
PipeInfo *infoPtr;
PipeEvent *evPtr;
int needEvent;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
398 399 400 401 402 403 404 |
if ((infoPtr->watchMask & TCL_READABLE) &&
(WaitForRead(infoPtr, 0) >= 0)) {
needEvent = 1;
}
if (needEvent) {
infoPtr->flags |= PIPE_PENDING;
| | | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 |
if ((infoPtr->watchMask & TCL_READABLE) &&
(WaitForRead(infoPtr, 0) >= 0)) {
needEvent = 1;
}
if (needEvent) {
infoPtr->flags |= PIPE_PENDING;
evPtr = (PipeEvent *)ckalloc(sizeof(PipeEvent));
evPtr->header.proc = PipeEventProc;
evPtr->infoPtr = infoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
}
}
}
|
| ︙ | ︙ | |||
429 430 431 432 433 434 435 |
TclFile
TclWinMakeFile(
HANDLE handle) /* Type-specific data. */
{
WinFile *filePtr;
| | | 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 |
TclFile
TclWinMakeFile(
HANDLE handle) /* Type-specific data. */
{
WinFile *filePtr;
filePtr = (WinFile *)ckalloc(sizeof(WinFile));
filePtr->type = WIN_FILE;
filePtr->handle = handle;
return (TclFile)filePtr;
}
/*
|
| ︙ | ︙ | |||
462 463 464 465 466 467 468 |
static int
TempFileName(
WCHAR name[MAX_PATH]) /* Buffer in which name for temporary file
* gets stored. */
{
const WCHAR *prefix = L"TCL";
| | | | | 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 |
static int
TempFileName(
WCHAR name[MAX_PATH]) /* Buffer in which name for temporary file
* gets stored. */
{
const WCHAR *prefix = L"TCL";
if (GetTempPathW(MAX_PATH, name) != 0) {
if (GetTempFileNameW(name, prefix, 0, name) != 0) {
return 1;
}
}
name[0] = '.';
name[1] = '\0';
return GetTempFileNameW(name, prefix, 0, name);
}
/*
*----------------------------------------------------------------------
*
* TclpMakeFile --
*
|
| ︙ | ︙ | |||
573 574 575 576 577 578 579 |
createMode = TRUNCATE_EXISTING;
break;
default:
createMode = OPEN_EXISTING;
break;
}
| > | | | | | 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 |
createMode = TRUNCATE_EXISTING;
break;
default:
createMode = OPEN_EXISTING;
break;
}
Tcl_DStringInit(&ds);
nativePath = Tcl_UtfToWCharDString(path, -1, &ds);
/*
* If the file is not being created, use the existing file attributes.
*/
flags = 0;
if (!(mode & O_CREAT)) {
flags = GetFileAttributesW(nativePath);
if (flags == 0xFFFFFFFF) {
flags = 0;
}
}
/*
* Set up the file sharing mode. We want to allow simultaneous access.
*/
shareMode = FILE_SHARE_READ | FILE_SHARE_WRITE;
/*
* Now we get to create the file.
*/
handle = CreateFileW(nativePath, accessMode, shareMode,
NULL, createMode, flags, NULL);
Tcl_DStringFree(&ds);
if (handle == INVALID_HANDLE_VALUE) {
DWORD err;
err = GetLastError();
if ((err & 0xFFFFL) == ERROR_OPEN_FAILED) {
err = (mode & O_CREAT) ? ERROR_FILE_EXISTS : ERROR_FILE_NOT_FOUND;
}
TclWinConvertError(err);
return NULL;
}
/*
|
| ︙ | ︙ | |||
654 655 656 657 658 659 660 |
Tcl_DString dstring;
HANDLE handle;
if (TempFileName(name) == 0) {
return NULL;
}
| | | 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 |
Tcl_DString dstring;
HANDLE handle;
if (TempFileName(name) == 0) {
return NULL;
}
handle = CreateFileW(name,
GENERIC_READ | GENERIC_WRITE, 0, NULL, CREATE_ALWAYS,
FILE_ATTRIBUTE_TEMPORARY|FILE_FLAG_DELETE_ON_CLOSE, NULL);
if (handle == INVALID_HANDLE_VALUE) {
goto error;
}
/*
|
| ︙ | ︙ | |||
716 717 718 719 720 721 722 |
if (contents != NULL) {
Tcl_DStringFree(&dstring);
}
TclWinConvertError(GetLastError());
CloseHandle(handle);
| | | 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 |
if (contents != NULL) {
Tcl_DStringFree(&dstring);
}
TclWinConvertError(GetLastError());
CloseHandle(handle);
DeleteFileW(name);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* TclpTempFileName --
|
| ︙ | ︙ | |||
821 822 823 824 825 826 827 |
if (!TclInThreadExit()
|| ((GetStdHandle(STD_INPUT_HANDLE) != filePtr->handle)
&& (GetStdHandle(STD_OUTPUT_HANDLE) != filePtr->handle)
&& (GetStdHandle(STD_ERROR_HANDLE) != filePtr->handle))) {
if (filePtr->handle != NULL &&
CloseHandle(filePtr->handle) == FALSE) {
TclWinConvertError(GetLastError());
| | | | | | | | 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 |
if (!TclInThreadExit()
|| ((GetStdHandle(STD_INPUT_HANDLE) != filePtr->handle)
&& (GetStdHandle(STD_OUTPUT_HANDLE) != filePtr->handle)
&& (GetStdHandle(STD_ERROR_HANDLE) != filePtr->handle))) {
if (filePtr->handle != NULL &&
CloseHandle(filePtr->handle) == FALSE) {
TclWinConvertError(GetLastError());
ckfree(filePtr);
return -1;
}
}
break;
default:
Tcl_Panic("TclpCloseFile: unexpected file type");
}
ckfree(filePtr);
return 0;
}
/*
*--------------------------------------------------------------------------
*
* TclpGetPid --
*
* Given a HANDLE to a child process, return the process id for that
* child process.
*
* Results:
* Returns the process id for the child process. If the pid was not known
* by Tcl, either because the pid was not created by Tcl or the child
* process has already been reaped, -1 is returned.
*
* Side effects:
* None.
*
*--------------------------------------------------------------------------
*/
int
TclpGetPid(
Tcl_Pid pid) /* The HANDLE of the child process. */
{
ProcInfo *infoPtr;
PipeInit();
Tcl_MutexLock(&pipeMutex);
for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
if (infoPtr->dwProcessId == (DWORD) (size_t) pid) {
Tcl_MutexUnlock(&pipeMutex);
return infoPtr->dwProcessId;
}
}
Tcl_MutexUnlock(&pipeMutex);
return (unsigned long) -1;
}
/*
*----------------------------------------------------------------------
*
* TclpCreateProcess --
*
|
| ︙ | ︙ | |||
932 933 934 935 936 937 938 |
* may be the same as outputFile. */
Tcl_Pid *pidPtr) /* If this function is successful, pidPtr is
* filled with the process id of the child
* process. */
{
int result, applType, createFlags;
Tcl_DString cmdLine; /* Complete command line (WCHAR). */
| | | 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 |
* may be the same as outputFile. */
Tcl_Pid *pidPtr) /* If this function is successful, pidPtr is
* filled with the process id of the child
* process. */
{
int result, applType, createFlags;
Tcl_DString cmdLine; /* Complete command line (WCHAR). */
STARTUPINFOW startInfo;
PROCESS_INFORMATION procInfo;
SECURITY_ATTRIBUTES secAtts;
HANDLE hProcess, h, inputHandle, outputHandle, errorHandle;
char execPath[MAX_PATH * 3];
WinFile *filePtr;
PipeInit();
|
| ︙ | ︙ | |||
1043 1044 1045 1046 1047 1048 1049 | * the child process would hang forever waiting for input from the * unmapped console window used by the helper application. * * Fortunately, the helper application will detect a closed pipe as a * sink. */ | | | | 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 |
* the child process would hang forever waiting for input from the
* unmapped console window used by the helper application.
*
* Fortunately, the helper application will detect a closed pipe as a
* sink.
*/
startInfo.hStdOutput = CreateFileW(L"NUL:", GENERIC_WRITE, 0,
&secAtts, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL);
} else {
DuplicateHandle(hProcess, outputHandle, hProcess,
&startInfo.hStdOutput, 0, TRUE, DUPLICATE_SAME_ACCESS);
}
if (startInfo.hStdOutput == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't duplicate output handle: %s",
Tcl_PosixError(interp)));
goto end;
}
if (errorHandle == INVALID_HANDLE_VALUE) {
/*
* If handle was not set, errors should be sent to an infinitely deep
* sink.
*/
startInfo.hStdError = CreateFileW(L"NUL:", GENERIC_WRITE, 0,
&secAtts, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
} else {
DuplicateHandle(hProcess, errorHandle, hProcess, &startInfo.hStdError,
0, TRUE, DUPLICATE_SAME_ACCESS);
}
if (startInfo.hStdError == INVALID_HANDLE_VALUE) {
TclWinConvertError(GetLastError());
|
| ︙ | ︙ | |||
1129 1130 1131 1132 1133 1134 1135 |
* Additionally, when calling a 16-bit dos or windows application, all
* path names must use the short, cryptic, path format (e.g., using
* ab~1.def instead of "a b.default").
*/
BuildCommandLine(execPath, argc, argv, &cmdLine);
| | | 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 |
* Additionally, when calling a 16-bit dos or windows application, all
* path names must use the short, cryptic, path format (e.g., using
* ab~1.def instead of "a b.default").
*/
BuildCommandLine(execPath, argc, argv, &cmdLine);
if (CreateProcessW(NULL, (WCHAR *) Tcl_DStringValue(&cmdLine),
NULL, NULL, TRUE, (DWORD) createFlags, NULL, NULL, &startInfo,
&procInfo) == 0) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf("couldn't execute \"%s\": %s",
argv[0], Tcl_PosixError(interp)));
goto end;
}
|
| ︙ | ︙ | |||
1151 1152 1153 1154 1155 1156 1157 |
}
/*
* "When an application spawns a process repeatedly, a new thread instance
* will be created for each process but the previous instances may not be
* cleaned up. This results in a significant virtual memory loss each time
* the process is spawned. If there is a WaitForInputIdle() call between
| | | 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 |
}
/*
* "When an application spawns a process repeatedly, a new thread instance
* will be created for each process but the previous instances may not be
* cleaned up. This results in a significant virtual memory loss each time
* the process is spawned. If there is a WaitForInputIdle() call between
* CreateProcessW() and CloseHandle(), the problem does not occur." PSS ID
* Number: Q124121
*/
WaitForInputIdle(procInfo.hProcess, 5000);
CloseHandle(procInfo.hThread);
*pidPtr = (Tcl_Pid) (size_t) procInfo.dwProcessId;
|
| ︙ | ︙ | |||
1200 1201 1202 1203 1204 1205 1206 |
*/
static BOOL
HasConsole(void)
{
HANDLE handle;
| | | 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 |
*/
static BOOL
HasConsole(void)
{
HANDLE handle;
handle = CreateFileW(L"CONOUT$", GENERIC_WRITE, FILE_SHARE_WRITE,
NULL, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
if (handle != INVALID_HANDLE_VALUE) {
CloseHandle(handle);
return TRUE;
} else {
return FALSE;
|
| ︙ | ︙ | |||
1270 1271 1272 1273 1274 1275 1276 |
static const char extensions[][5] = {"", ".com", ".exe", ".bat", ".cmd"};
/*
* Look for the program as an external program. First try the name as it
* is, then try adding .com, .exe, .bat and .cmd, in that order, to the name,
* looking for an executable.
*
| | > | | | | > | | | 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 |
static const char extensions[][5] = {"", ".com", ".exe", ".bat", ".cmd"};
/*
* Look for the program as an external program. First try the name as it
* is, then try adding .com, .exe, .bat and .cmd, in that order, to the name,
* looking for an executable.
*
* Using the raw SearchPathW() function doesn't do quite what is necessary.
* If the name of the executable already contains a '.' character, it will
* not try appending the specified extension when searching (in other
* words, SearchPath will not find the program "a.b.exe" if the arguments
* specified "a.b" and ".exe"). So, first look for the file as it is
* named. Then manually append the extensions, looking for a match.
*/
applType = APPL_NONE;
Tcl_DStringInit(&nameBuf);
Tcl_DStringAppend(&nameBuf, originalName, -1);
nameLen = Tcl_DStringLength(&nameBuf);
for (i = 0; i < (int) (sizeof(extensions) / sizeof(extensions[0])); i++) {
Tcl_DStringSetLength(&nameBuf, nameLen);
Tcl_DStringAppend(&nameBuf, extensions[i], -1);
Tcl_DStringInit(&ds);
nativeName = Tcl_UtfToWCharDString(Tcl_DStringValue(&nameBuf),
Tcl_DStringLength(&nameBuf), &ds);
found = SearchPathW(NULL, nativeName, NULL, MAX_PATH,
nativeFullPath, &rest);
Tcl_DStringFree(&ds);
if (found == 0) {
continue;
}
/*
* Ignore matches on directories or data files, return if identified a
* known type.
*/
attr = GetFileAttributesW(nativeFullPath);
if ((attr == 0xFFFFFFFF) || (attr & FILE_ATTRIBUTE_DIRECTORY)) {
continue;
}
Tcl_DStringInit(&ds);
strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, -1, &ds));
Tcl_DStringFree(&ds);
ext = strrchr(fullName, '.');
if ((ext != NULL) &&
(strcasecmp(ext, ".cmd") == 0 || strcasecmp(ext, ".bat") == 0)) {
applType = APPL_DOS;
break;
}
hFile = CreateFileW(nativeFullPath,
GENERIC_READ, FILE_SHARE_READ, NULL, OPEN_EXISTING,
FILE_ATTRIBUTE_NORMAL, NULL);
if (hFile == INVALID_HANDLE_VALUE) {
continue;
}
header.e_magic = 0;
|
| ︙ | ︙ | |||
1394 1395 1396 1397 1398 1399 1400 | /* * Replace long path name of executable with short path name for * 16-bit applications. Otherwise the application may not be able to * correctly parse its own command line to separate off the * application name from the arguments. */ | | > | | | 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 |
/*
* Replace long path name of executable with short path name for
* 16-bit applications. Otherwise the application may not be able to
* correctly parse its own command line to separate off the
* application name from the arguments.
*/
GetShortPathNameW(nativeFullPath, nativeFullPath, MAX_PATH);
Tcl_DStringInit(&ds);
strcpy(fullName, Tcl_WCharToUtfDString(nativeFullPath, -1, &ds));
Tcl_DStringFree(&ds);
}
return applType;
}
/*
*----------------------------------------------------------------------
*
* BuildCommandLine --
*
* The command line arguments are stored in linePtr separated by spaces,
* in a form that CreateProcessW() understands. Special characters in
* individual arguments from argv[] must be quoted when being stored in
* cmdLine.
*
* Results:
* None.
*
* Side effects:
|
| ︙ | ︙ | |||
1723 1724 1725 1726 1727 1728 1729 |
* End of argument (main closing quote-char)
*/
TclDStringAppendLiteral(&ds, "\"");
}
}
Tcl_DStringFree(linePtr);
| > | | 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 |
* End of argument (main closing quote-char)
*/
TclDStringAppendLiteral(&ds, "\"");
}
}
Tcl_DStringFree(linePtr);
Tcl_DStringInit(linePtr);
Tcl_UtfToWCharDString(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds), linePtr);
Tcl_DStringFree(&ds);
}
/*
*----------------------------------------------------------------------
*
* TclpCreateCommandChannel --
|
| ︙ | ︙ | |||
1754 1755 1756 1757 1758 1759 1760 |
TclFile writeFile, /* If non-null, gives the file for writing. */
TclFile errorFile, /* If non-null, gives the file where errors
* can be read. */
int numPids, /* The number of pids in the pid array. */
Tcl_Pid *pidPtr) /* An array of process identifiers. */
{
char channelName[16 + TCL_INTEGER_SPACE];
| | | 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 |
TclFile writeFile, /* If non-null, gives the file for writing. */
TclFile errorFile, /* If non-null, gives the file where errors
* can be read. */
int numPids, /* The number of pids in the pid array. */
Tcl_Pid *pidPtr) /* An array of process identifiers. */
{
char channelName[16 + TCL_INTEGER_SPACE];
PipeInfo *infoPtr = (PipeInfo *)ckalloc(sizeof(PipeInfo));
PipeInit();
infoPtr->watchMask = 0;
infoPtr->flags = 0;
infoPtr->readFlags = 0;
infoPtr->readFile = readFile;
|
| ︙ | ︙ | |||
1780 1781 1782 1783 1784 1785 1786 |
infoPtr->threadId = Tcl_GetCurrentThread();
if (readFile != NULL) {
/*
* Start the background reader thread.
*/
| | | | 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 |
infoPtr->threadId = Tcl_GetCurrentThread();
if (readFile != NULL) {
/*
* Start the background reader thread.
*/
infoPtr->readable = CreateEventW(NULL, TRUE, TRUE, NULL);
infoPtr->readThread = CreateThread(NULL, 256, PipeReaderThread,
TclPipeThreadCreateTI(&infoPtr->readTI, infoPtr, infoPtr->readable),
0, NULL);
SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
infoPtr->validMask |= TCL_READABLE;
} else {
infoPtr->readTI = NULL;
infoPtr->readThread = 0;
}
if (writeFile != NULL) {
/*
* Start the background writer thread.
*/
infoPtr->writable = CreateEventW(NULL, TRUE, TRUE, NULL);
infoPtr->writeThread = CreateThread(NULL, 256, PipeWriterThread,
TclPipeThreadCreateTI(&infoPtr->writeTI, infoPtr, infoPtr->writable),
0, NULL);
SetThreadPriority(infoPtr->writeThread, THREAD_PRIORITY_HIGHEST);
infoPtr->validMask |= TCL_WRITABLE;
} else {
infoPtr->writeTI = NULL;
|
| ︙ | ︙ | |||
1847 1848 1849 1850 1851 1852 1853 |
*/
int
Tcl_CreatePipe(
Tcl_Interp *interp, /* Errors returned in result.*/
Tcl_Channel *rchan, /* Where to return the read side. */
Tcl_Channel *wchan, /* Where to return the write side. */
| | | 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 |
*/
int
Tcl_CreatePipe(
Tcl_Interp *interp, /* Errors returned in result.*/
Tcl_Channel *rchan, /* Where to return the read side. */
Tcl_Channel *wchan, /* Where to return the write side. */
TCL_UNUSED(int) /*flags*/) /* Reserved for future use. */
{
HANDLE readHandle, writeHandle;
SECURITY_ATTRIBUTES sec;
sec.nLength = sizeof(SECURITY_ATTRIBUTES);
sec.lpSecurityDescriptor = NULL;
sec.bInheritHandle = FALSE;
|
| ︙ | ︙ | |||
1908 1909 1910 1911 1912 1913 1914 |
*/
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
return;
}
| | | | | 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 |
*/
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
return;
}
pipePtr = (PipeInfo *)Tcl_GetChannelInstanceData(chan);
TclNewObj(pidsObj);
for (i = 0; i < pipePtr->numPids; i++) {
Tcl_ListObjAppendElement(NULL, pidsObj,
Tcl_NewWideIntObj((unsigned)
TclpGetPid(pipePtr->pidPtr[i])));
Tcl_DetachPids(1, &pipePtr->pidPtr[i]);
}
Tcl_SetObjResult(interp, pidsObj);
if (pipePtr->numPids > 0) {
ckfree(pipePtr->pidPtr);
pipePtr->numPids = 0;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2105 2106 2107 2108 2109 2110 2111 |
*/
if (pipePtr->errorFile) {
WinFile *filePtr = (WinFile *) pipePtr->errorFile;
errChan = Tcl_MakeFileChannel((ClientData) filePtr->handle,
TCL_READABLE);
| | | | | | 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 |
*/
if (pipePtr->errorFile) {
WinFile *filePtr = (WinFile *) pipePtr->errorFile;
errChan = Tcl_MakeFileChannel((ClientData) filePtr->handle,
TCL_READABLE);
ckfree(filePtr);
} else {
errChan = NULL;
}
result = TclCleanupChildren(interp, pipePtr->numPids,
pipePtr->pidPtr, errChan);
}
if (pipePtr->numPids > 0) {
ckfree(pipePtr->pidPtr);
}
if (pipePtr->writeBuf != NULL) {
ckfree(pipePtr->writeBuf);
}
ckfree(pipePtr);
if (errorCode == 0) {
return result;
}
return errorCode;
}
|
| ︙ | ︙ | |||
2291 2292 2293 2294 2295 2296 2297 |
if (toWrite > infoPtr->writeBufLen) {
/*
* Reallocate the buffer to be large enough to hold the data.
*/
if (infoPtr->writeBuf) {
| | | | 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 |
if (toWrite > infoPtr->writeBufLen) {
/*
* Reallocate the buffer to be large enough to hold the data.
*/
if (infoPtr->writeBuf) {
ckfree(infoPtr->writeBuf);
}
infoPtr->writeBufLen = toWrite;
infoPtr->writeBuf = (char *)ckalloc(toWrite);
}
memcpy(infoPtr->writeBuf, buf, toWrite);
infoPtr->toWrite = toWrite;
ResetEvent(infoPtr->writable);
TclPipeThreadSignal(&infoPtr->writeTI);
bytesWritten = toWrite;
} else {
|
| ︙ | ︙ | |||
2556 2557 2558 2559 2560 2561 2562 |
* Find the process and cut it from the process list.
*/
Tcl_MutexLock(&pipeMutex);
prevPtrPtr = &procList;
for (infoPtr = procList; infoPtr != NULL;
prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) {
| | | 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 |
* Find the process and cut it from the process list.
*/
Tcl_MutexLock(&pipeMutex);
prevPtrPtr = &procList;
for (infoPtr = procList; infoPtr != NULL;
prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) {
if (infoPtr->dwProcessId == (DWORD) (size_t) pid) {
*prevPtrPtr = infoPtr->nextPtr;
break;
}
}
Tcl_MutexUnlock(&pipeMutex);
/*
|
| ︙ | ︙ | |||
2674 2675 2676 2677 2678 2679 2680 |
}
/*
* Officially close the process handle.
*/
CloseHandle(infoPtr->hProcess);
| | | 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 |
}
/*
* Officially close the process handle.
*/
CloseHandle(infoPtr->hProcess);
ckfree(infoPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2700 2701 2702 2703 2704 2705 2706 |
*
*----------------------------------------------------------------------
*/
void
TclWinAddProcess(
void *hProcess, /* Handle to process */
| | | | 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 |
*
*----------------------------------------------------------------------
*/
void
TclWinAddProcess(
void *hProcess, /* Handle to process */
unsigned long id) /* Global process identifier */
{
ProcInfo *procPtr = (ProcInfo*)ckalloc(sizeof(ProcInfo));
PipeInit();
procPtr->hProcess = hProcess;
procPtr->dwProcessId = id;
Tcl_MutexLock(&pipeMutex);
procPtr->nextPtr = procList;
|
| ︙ | ︙ | |||
2731 2732 2733 2734 2735 2736 2737 | * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | | | 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 |
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_PidObjCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Argument strings. */
{
Tcl_Channel chan;
const Tcl_ChannelType *chanTypePtr;
PipeInfo *pipePtr;
int i;
Tcl_Obj *resultPtr;
if (objc > 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?channelId?");
return TCL_ERROR;
}
if (objc == 1) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((unsigned) getpid()));
} else {
chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]),
NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
chanTypePtr = Tcl_GetChannelType(chan);
if (chanTypePtr != &pipeChannelType) {
return TCL_OK;
|
| ︙ | ︙ | |||
2803 2804 2805 2806 2807 2808 2809 |
static int
WaitForRead(
PipeInfo *infoPtr, /* Pipe state. */
int blocking) /* Indicates whether call should be blocking
* or not. */
{
DWORD timeout, count;
| | | 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 |
static int
WaitForRead(
PipeInfo *infoPtr, /* Pipe state. */
int blocking) /* Indicates whether call should be blocking
* or not. */
{
DWORD timeout, count;
HANDLE *handle = (HANDLE *)((WinFile *) infoPtr->readFile)->handle;
while (1) {
/*
* Synchronize with the reader thread.
*/
/* avoid blocking if pipe-thread exited */
|
| ︙ | ︙ | |||
3180 3181 3182 3183 3184 3185 3186 | * A read-write Tcl Channel open on the file. * *---------------------------------------------------------------------- */ Tcl_Channel TclpOpenTemporaryFile( | | | < | | > | > | | | 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 |
* A read-write Tcl Channel open on the file.
*
*----------------------------------------------------------------------
*/
Tcl_Channel
TclpOpenTemporaryFile(
TCL_UNUSED(Tcl_Obj *) /*dirObj*/,
Tcl_Obj *basenameObj,
TCL_UNUSED(Tcl_Obj *) /*extensionObj*/,
Tcl_Obj *resultingNameObj)
{
WCHAR name[MAX_PATH];
char *namePtr;
HANDLE handle;
DWORD flags = FILE_ATTRIBUTE_TEMPORARY;
int length, counter, counter2;
Tcl_DString buf;
if (!resultingNameObj) {
flags |= FILE_FLAG_DELETE_ON_CLOSE;
}
namePtr = (char *) name;
length = GetTempPathW(MAX_PATH, name);
if (length == 0) {
goto gotError;
}
namePtr += length * sizeof(WCHAR);
if (basenameObj) {
const char *string = TclGetStringFromObj(basenameObj, &length);
Tcl_DStringInit(&buf);
Tcl_UtfToWCharDString(string, length, &buf);
memcpy(namePtr, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf));
namePtr += Tcl_DStringLength(&buf);
Tcl_DStringFree(&buf);
} else {
const WCHAR *baseStr = L"TCL";
length = 3 * sizeof(WCHAR);
memcpy(namePtr, baseStr, length);
namePtr += length;
}
counter = TclpGetClicks() % 65533;
counter2 = 1024; /* Only try this many times! Prevents
* an infinite loop. */
do {
char number[TCL_INTEGER_SPACE + 4];
sprintf(number, "%d.TMP", counter);
counter = (unsigned short) (counter + 1);
Tcl_DStringInit(&buf);
Tcl_UtfToWCharDString(number, strlen(number), &buf);
Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf) + 1);
memcpy(namePtr, Tcl_DStringValue(&buf), Tcl_DStringLength(&buf) + 1);
Tcl_DStringFree(&buf);
handle = CreateFileW(name,
GENERIC_READ|GENERIC_WRITE, 0, NULL, CREATE_NEW, flags, NULL);
} while (handle == INVALID_HANDLE_VALUE
&& --counter2 > 0
&& GetLastError() == ERROR_FILE_EXISTS);
if (handle == INVALID_HANDLE_VALUE) {
goto gotError;
}
|
| ︙ | ︙ | |||
3276 3277 3278 3279 3280 3281 3282 |
TclPipeThreadCreateTI(
TclPipeThreadInfo **pipeTIPtr,
ClientData clientData,
HANDLE wakeEvent)
{
TclPipeThreadInfo *pipeTI;
#ifndef _PTI_USE_CKALLOC
| | | | | 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 |
TclPipeThreadCreateTI(
TclPipeThreadInfo **pipeTIPtr,
ClientData clientData,
HANDLE wakeEvent)
{
TclPipeThreadInfo *pipeTI;
#ifndef _PTI_USE_CKALLOC
pipeTI = (TclPipeThreadInfo *)malloc(sizeof(TclPipeThreadInfo));
#else
pipeTI = (TclPipeThreadInfo *)ckalloc(sizeof(TclPipeThreadInfo));
#endif /* !_PTI_USE_CKALLOC */
pipeTI->evControl = CreateEventW(NULL, FALSE, FALSE, NULL);
pipeTI->state = PTI_STATE_IDLE;
pipeTI->clientData = clientData;
pipeTI->evWakeUp = wakeEvent;
return (*pipeTIPtr = pipeTI);
}
/*
|
| ︙ | ︙ | |||
3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 |
case PTI_STATE_IDLE:
/*
* Thread was idle/waiting, notify it goes teardown
*/
SetEvent(evControl);
*pipeTIPtr = NULL;
case PTI_STATE_DOWN:
return 1;
default:
/*
* Thread works currently, we should try to end it, own the TI
* structure (because of possible sharing the joint structures with
| > | 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 |
case PTI_STATE_IDLE:
/*
* Thread was idle/waiting, notify it goes teardown
*/
SetEvent(evControl);
*pipeTIPtr = NULL;
/* FALLTHRU */
case PTI_STATE_DOWN:
return 1;
default:
/*
* Thread works currently, we should try to end it, own the TI
* structure (because of possible sharing the joint structures with
|
| ︙ | ︙ | |||
3640 3641 3642 3643 3644 3645 3646 |
if (pipeTI->evWakeUp) {
SetEvent(pipeTI->evWakeUp);
}
CloseHandle(pipeTI->evControl);
#ifndef _PTI_USE_CKALLOC
free(pipeTI);
#else
| | | 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 |
if (pipeTI->evWakeUp) {
SetEvent(pipeTI->evWakeUp);
}
CloseHandle(pipeTI->evControl);
#ifndef _PTI_USE_CKALLOC
free(pipeTI);
#else
ckfree(pipeTI);
#endif /* !_PTI_USE_CKALLOC */
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
3690 3691 3692 3693 3694 3695 3696 |
CloseHandle(pipeTI->evControl);
if (pipeTI->evWakeUp) {
SetEvent(pipeTI->evWakeUp);
}
#ifndef _PTI_USE_CKALLOC
free(pipeTI);
#else
| | | 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 |
CloseHandle(pipeTI->evControl);
if (pipeTI->evWakeUp) {
SetEvent(pipeTI->evWakeUp);
}
#ifndef _PTI_USE_CKALLOC
free(pipeTI);
#else
ckfree(pipeTI);
/* be sure all subsystems used are finalized */
Tcl_FinalizeThread();
#endif /* !_PTI_USE_CKALLOC */
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinPort.h.
| ︙ | ︙ | |||
10 11 12 13 14 15 16 | * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _TCLWINPORT #define _TCLWINPORT | | > > > > | | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 | * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef _TCLWINPORT #define _TCLWINPORT #if !defined(_WIN64) && !defined(__MINGW_USE_VC2005_COMPAT) /* See [Bug 3354324]: file mtime sets wrong time */ # define __MINGW_USE_VC2005_COMPAT #endif #if defined(_MSC_VER) && defined(_WIN64) && !defined(STATIC_BUILD) \ && !defined(MP_32BIT) && !defined(MP_64BIT) # define MP_64BIT #endif /* * We must specify the lower version we intend to support. * * WINVER = 0x0501 means Windows XP and above */ |
| ︙ | ︙ | |||
78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 | #include <io.h> #include <errno.h> #include <fcntl.h> #include <float.h> #include <malloc.h> #include <process.h> #include <signal.h> #include <limits.h> #ifndef __GNUC__ # define strncasecmp _strnicmp # define strcasecmp _stricmp #endif /* | > > > > > > > > | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 | #include <io.h> #include <errno.h> #include <fcntl.h> #include <float.h> #include <malloc.h> #include <process.h> #include <signal.h> #ifdef HAVE_INTTYPES_H # include <inttypes.h> #endif #include <limits.h> #ifdef HAVE_STDINT_H # include <stdint.h> #else # include "../compat/stdint.h" #endif #ifndef __GNUC__ # define strncasecmp _strnicmp # define strcasecmp _stricmp #endif /* |
| ︙ | ︙ | |||
298 299 300 301 302 303 304 | #endif #ifndef WIFSIGNALED # define WIFSIGNALED(stat) ((*((int *) &(stat))) & 0xC0000000) #endif #ifndef WTERMSIG | | | | 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 | #endif #ifndef WIFSIGNALED # define WIFSIGNALED(stat) ((*((int *) &(stat))) & 0xC0000000) #endif #ifndef WTERMSIG # define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7F) #endif #ifndef WIFSTOPPED # define WIFSTOPPED(stat) 0 #endif #ifndef WSTOPSIG # define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xFF) #endif /* * Define constants for waitpid() system call if they aren't defined * by a system header file. */ |
| ︙ | ︙ | |||
468 469 470 471 472 473 474 475 476 477 478 479 480 481 | /* * MSVC 8.0 started to mark many standard C library functions depreciated * including the *printf family and others. Tell it to shut up. * (_MSC_VER is 1200 for VC6, 1300 or 1310 for vc7.net, 1400 for 8.0) */ #if defined(_MSC_VER) # pragma warning(disable:4244) # if _MSC_VER >= 1400 # pragma warning(disable:4267) # pragma warning(disable:4996) # endif #endif | > | 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 | /* * MSVC 8.0 started to mark many standard C library functions depreciated * including the *printf family and others. Tell it to shut up. * (_MSC_VER is 1200 for VC6, 1300 or 1310 for vc7.net, 1400 for 8.0) */ #if defined(_MSC_VER) # pragma warning(disable:4146) # pragma warning(disable:4244) # if _MSC_VER >= 1400 # pragma warning(disable:4267) # pragma warning(disable:4996) # endif #endif |
| ︙ | ︙ | |||
524 525 526 527 528 529 530 | #endif /* * The following defines wrap the system memory allocation routines for * use by tclAlloc.c. */ | | | > > > | 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 | #endif /* * The following defines wrap the system memory allocation routines for * use by tclAlloc.c. */ #define TclpSysAlloc(size, isBin) ((void*)HeapAlloc(GetProcessHeap(), \ (DWORD)0, (DWORD)size)) #define TclpSysFree(ptr) (HeapFree(GetProcessHeap(), \ (DWORD)0, (HGLOBAL)ptr)) #define TclpSysRealloc(ptr, size) ((void*)HeapReAlloc(GetProcessHeap(), \ (DWORD)0, (LPVOID)ptr, (DWORD)size)) /* This type is not defined in the Windows headers */ #define socklen_t int /* * The following macros have trivial definitions, allowing generic code to * address platform-specific issues. */ #define TclpReleaseFile(file) ckfree(file) /* * The following macros and declarations wrap the C runtime library * functions. */ #define TclpExit exit #ifndef INVALID_SET_FILE_POINTER #define INVALID_SET_FILE_POINTER 0xFFFFFFFF #endif /* INVALID_SET_FILE_POINTER */ #ifndef LABEL_SECURITY_INFORMATION # define LABEL_SECURITY_INFORMATION (0x00000010L) #endif #define Tcl_DirEntry void #define TclDIR void #endif /* _TCLWINPORT */ |
Changes to win/tclWinReg.c.
| ︙ | ︙ | |||
90 91 92 93 94 95 96 | * Declarations for functions defined in this file. */ static void AppendSystemError(Tcl_Interp *interp, DWORD error); static int BroadcastValue(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static DWORD ConvertDWORD(DWORD type, DWORD value); | | | 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 | * Declarations for functions defined in this file. */ static void AppendSystemError(Tcl_Interp *interp, DWORD error); static int BroadcastValue(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static DWORD ConvertDWORD(DWORD type, DWORD value); static void DeleteCmd(void *clientData); static int DeleteKey(Tcl_Interp *interp, Tcl_Obj *keyNameObj, REGSAM mode); static int DeleteValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj, Tcl_Obj *valueNameObj, REGSAM mode); static int GetKeyNames(Tcl_Interp *interp, Tcl_Obj *keyNameObj, Tcl_Obj *patternObj, REGSAM mode); static int GetType(Tcl_Interp *interp, Tcl_Obj *keyNameObj, |
| ︙ | ︙ | |||
112 113 114 115 116 117 118 | static DWORD OpenSubKey(char *hostName, HKEY rootKey, char *keyName, REGSAM mode, int flags, HKEY *keyPtr); static int ParseKeyName(Tcl_Interp *interp, char *name, char **hostNamePtr, HKEY *rootKeyPtr, char **keyNamePtr); static DWORD RecursiveDeleteKey(HKEY hStartKey, | | | > > > > > > > > > > > > > > > > | 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 |
static DWORD OpenSubKey(char *hostName, HKEY rootKey,
char *keyName, REGSAM mode, int flags,
HKEY *keyPtr);
static int ParseKeyName(Tcl_Interp *interp, char *name,
char **hostNamePtr, HKEY *rootKeyPtr,
char **keyNamePtr);
static DWORD RecursiveDeleteKey(HKEY hStartKey,
const WCHAR * pKeyName, REGSAM mode);
static int RegistryObjCmd(void *clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int SetValue(Tcl_Interp *interp, Tcl_Obj *keyNameObj,
Tcl_Obj *valueNameObj, Tcl_Obj *dataObj,
Tcl_Obj *typeObj, REGSAM mode);
#if (TCL_MAJOR_VERSION < 9) && (TCL_MINOR_VERSION < 7)
# if TCL_UTF_MAX > 3
# define Tcl_WCharToUtfDString(a,b,c) Tcl_WinTCharToUtf((TCHAR *)(a),(b)*sizeof(WCHAR),c)
# define Tcl_UtfToWCharDString(a,b,c) (WCHAR *)Tcl_WinUtfToTChar(a,b,c)
# else
# define Tcl_WCharToUtfDString Tcl_UniCharToUtfDString
# define Tcl_UtfToWCharDString Tcl_UtfToUniCharDString
# endif
#endif
static unsigned char *
getByteArrayFromObj(
Tcl_Obj *objPtr,
size_t *lengthPtr
) {
int length;
unsigned char *result = Tcl_GetByteArrayFromObj(objPtr, &length);
#if TCL_MAJOR_VERSION > 8
if (sizeof(TCL_HASH_TYPE) > sizeof(int)) {
/* 64-bit and TIP #494 situation: */
*lengthPtr = *(TCL_HASH_TYPE *) objPtr->internalRep.twoPtrValue.ptr1;
} else
#endif
/* 32-bit or without TIP #494 */
*lengthPtr = (size_t) (unsigned) length;
return result;
}
#ifdef __cplusplus
extern "C" {
#endif
DLLEXPORT int Registry_Init(Tcl_Interp *interp);
DLLEXPORT int Registry_Unload(Tcl_Interp *interp, int flags);
#ifdef __cplusplus
}
#endif
/*
*----------------------------------------------------------------------
*
* Registry_Init --
*
* This function initializes the registry command.
|
| ︙ | ︙ | |||
171 172 173 174 175 176 177 |
if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
return TCL_ERROR;
}
cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd,
interp, DeleteCmd);
Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd);
| | | 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 |
if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
return TCL_ERROR;
}
cmd = Tcl_CreateObjCommand(interp, "registry", RegistryObjCmd,
interp, DeleteCmd);
Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, cmd);
return Tcl_PkgProvideEx(interp, "registry", "1.3.5", NULL);
}
/*
*----------------------------------------------------------------------
*
* Registry_Unload --
*
|
| ︙ | ︙ | |||
197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 |
int
Registry_Unload(
Tcl_Interp *interp, /* Interpreter for unloading */
int flags) /* Flags passed by the unload system */
{
Tcl_Command cmd;
Tcl_Obj *objv[3];
/*
* Unregister the registry package. There is no Tcl_PkgForget()
*/
objv[0] = Tcl_NewStringObj("package", -1);
objv[1] = Tcl_NewStringObj("forget", -1);
objv[2] = Tcl_NewStringObj("registry", -1);
Tcl_EvalObjv(interp, 3, objv, TCL_EVAL_GLOBAL);
/*
* Delete the originally registered command.
*/
| > | | 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 |
int
Registry_Unload(
Tcl_Interp *interp, /* Interpreter for unloading */
int flags) /* Flags passed by the unload system */
{
Tcl_Command cmd;
Tcl_Obj *objv[3];
(void)flags;
/*
* Unregister the registry package. There is no Tcl_PkgForget()
*/
objv[0] = Tcl_NewStringObj("package", -1);
objv[1] = Tcl_NewStringObj("forget", -1);
objv[2] = Tcl_NewStringObj("registry", -1);
Tcl_EvalObjv(interp, 3, objv, TCL_EVAL_GLOBAL);
/*
* Delete the originally registered command.
*/
cmd = (Tcl_Command)Tcl_GetAssocData(interp, REGISTRY_ASSOC_KEY, NULL);
if (cmd != NULL) {
Tcl_DeleteCommandFromToken(interp, cmd);
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
238 239 240 241 242 243 244 | * The unload command will not attempt to delete this command. * *---------------------------------------------------------------------- */ static void DeleteCmd( | | | | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 |
* The unload command will not attempt to delete this command.
*
*----------------------------------------------------------------------
*/
static void
DeleteCmd(
void *clientData)
{
Tcl_Interp *interp = (Tcl_Interp *)clientData;
Tcl_SetAssocData(interp, REGISTRY_ASSOC_KEY, NULL, NULL);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
263 264 265 266 267 268 269 | * None. * *---------------------------------------------------------------------- */ static int RegistryObjCmd( | | > | 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 |
* None.
*
*----------------------------------------------------------------------
*/
static int
RegistryObjCmd(
void *dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument values. */
{
int n = 1;
int index, argc;
REGSAM mode = 0;
const char *errString = NULL;
static const char *const subcommands[] = {
"broadcast", "delete", "get", "keys", "set", "type", "values", NULL
};
enum SubCmdIdx {
BroadcastIdx, DeleteIdx, GetIdx, KeysIdx, SetIdx, TypeIdx, ValuesIdx
};
static const char *const modes[] = {
"-32bit", "-64bit", NULL
};
(void)dummy;
if (objc < 2) {
wrongArgs:
Tcl_WrongNumArgs(interp, 1, objv, "?-32bit|-64bit? option ?arg ...?");
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
411 412 413 414 415 416 417 |
static int
DeleteKey(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Name of key to delete. */
REGSAM mode) /* Mode flags to pass. */
{
char *tail, *buffer, *hostName, *keyName;
| | | | 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 |
static int
DeleteKey(
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Name of key to delete. */
REGSAM mode) /* Mode flags to pass. */
{
char *tail, *buffer, *hostName, *keyName;
const WCHAR *nativeTail;
HKEY rootKey, subkey;
DWORD result;
Tcl_DString buf;
REGSAM saveMode = mode;
/*
* Find the parent of the key being deleted and open it.
*/
keyName = Tcl_GetString(keyNameObj);
buffer = (char *)Tcl_Alloc(keyNameObj->length + 1);
strcpy(buffer, keyName);
if (ParseKeyName(interp, buffer, &hostName, &rootKey,
&keyName) != TCL_OK) {
Tcl_Free(buffer);
return TCL_ERROR;
}
|
| ︙ | ︙ | |||
464 465 466 467 468 469 470 |
return TCL_ERROR;
}
/*
* Now we recursively delete the key and everything below it.
*/
| > | | 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 |
return TCL_ERROR;
}
/*
* Now we recursively delete the key and everything below it.
*/
Tcl_DStringInit(&buf);
nativeTail = Tcl_UtfToWCharDString(tail, -1, &buf);
result = RecursiveDeleteKey(subkey, nativeTail, saveMode);
Tcl_DStringFree(&buf);
if (result != ERROR_SUCCESS && result != ERROR_FILE_NOT_FOUND) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("unable to delete key: ", -1));
AppendSystemError(interp, result);
|
| ︙ | ︙ | |||
520 521 522 523 524 525 526 |
mode |= KEY_SET_VALUE;
if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
valueName = Tcl_GetString(valueNameObj);
| > | | | 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 |
mode |= KEY_SET_VALUE;
if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
valueName = Tcl_GetString(valueNameObj);
Tcl_DStringInit(&ds);
Tcl_UtfToWCharDString(valueName, valueNameObj->length, &ds);
result = RegDeleteValueW(key, (const WCHAR *)Tcl_DStringValue(&ds));
Tcl_DStringFree(&ds);
if (result != ERROR_SUCCESS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unable to delete value \"%s\" from key \"%s\": ",
Tcl_GetString(valueNameObj), Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
result = TCL_ERROR;
|
| ︙ | ︙ | |||
564 565 566 567 568 569 570 |
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Key to enumerate. */
Tcl_Obj *patternObj, /* Optional match pattern. */
REGSAM mode) /* Mode flags to pass. */
{
const char *pattern; /* Pattern being matched against subkeys */
HKEY key; /* Handle to the key being examined */
| | | 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 |
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Key to enumerate. */
Tcl_Obj *patternObj, /* Optional match pattern. */
REGSAM mode) /* Mode flags to pass. */
{
const char *pattern; /* Pattern being matched against subkeys */
HKEY key; /* Handle to the key being examined */
WCHAR buffer[MAX_KEY_LENGTH];
/* Buffer to hold the subkey name */
DWORD bufSize; /* Size of the buffer */
DWORD index; /* Position of the current subkey */
char *name; /* Subkey name */
Tcl_Obj *resultPtr; /* List of subkeys being accumulated */
int result = TCL_OK; /* Return value from this command */
Tcl_DString ds; /* Buffer to translate subkey name to UTF-8 */
|
| ︙ | ︙ | |||
595 596 597 598 599 600 601 |
/*
* Enumerate the subkeys.
*/
resultPtr = Tcl_NewObj();
for (index = 0;; ++index) {
bufSize = MAX_KEY_LENGTH;
| | > | | 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 |
/*
* Enumerate the subkeys.
*/
resultPtr = Tcl_NewObj();
for (index = 0;; ++index) {
bufSize = MAX_KEY_LENGTH;
result = RegEnumKeyExW(key, index, buffer, &bufSize,
NULL, NULL, NULL, NULL);
if (result != ERROR_SUCCESS) {
if (result == ERROR_NO_MORE_ITEMS) {
result = TCL_OK;
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unable to enumerate subkeys of \"%s\": ",
Tcl_GetString(keyNameObj)));
AppendSystemError(interp, result);
result = TCL_ERROR;
}
break;
}
Tcl_DStringInit(&ds);
name = Tcl_WCharToUtfDString(buffer, bufSize, &ds);
if (pattern && !Tcl_StringMatch(name, pattern)) {
Tcl_DStringFree(&ds);
continue;
}
result = Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));
Tcl_DStringFree(&ds);
|
| ︙ | ︙ | |||
659 660 661 662 663 664 665 |
Tcl_Obj *valueNameObj, /* Name of value to get. */
REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
DWORD result, type;
Tcl_DString ds;
const char *valueName;
| | > | | | 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 |
Tcl_Obj *valueNameObj, /* Name of value to get. */
REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
DWORD result, type;
Tcl_DString ds;
const char *valueName;
const WCHAR *nativeValue;
/*
* Attempt to open the key for reading.
*/
mode |= KEY_QUERY_VALUE;
if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
/*
* Get the type of the value.
*/
valueName = Tcl_GetString(valueNameObj);
Tcl_DStringInit(&ds);
nativeValue = Tcl_UtfToWCharDString(valueName, valueNameObj->length, &ds);
result = RegQueryValueExW(key, nativeValue, NULL, &type,
NULL, NULL);
Tcl_DStringFree(&ds);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unable to get type of value \"%s\" from key \"%s\": ",
|
| ︙ | ︙ | |||
728 729 730 731 732 733 734 |
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Name of key. */
Tcl_Obj *valueNameObj, /* Name of value to get. */
REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
const char *valueName;
| | | 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 |
Tcl_Interp *interp, /* Current interpreter. */
Tcl_Obj *keyNameObj, /* Name of key. */
Tcl_Obj *valueNameObj, /* Name of value to get. */
REGSAM mode) /* Mode flags to pass. */
{
HKEY key;
const char *valueName;
const WCHAR *nativeValue;
DWORD result, length, type;
Tcl_DString data, buf;
/*
* Attempt to open the key for reading.
*/
|
| ︙ | ︙ | |||
753 754 755 756 757 758 759 |
*
* This allows short values to be read from the registy in one call.
* Longer values need a second call with an expanded DString.
*/
Tcl_DStringInit(&data);
Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1);
| | > | | | | | | 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 |
*
* This allows short values to be read from the registy in one call.
* Longer values need a second call with an expanded DString.
*/
Tcl_DStringInit(&data);
Tcl_DStringSetLength(&data, TCL_DSTRING_STATIC_SIZE - 1);
length = TCL_DSTRING_STATIC_SIZE/sizeof(WCHAR) - 1;
valueName = Tcl_GetString(valueNameObj);
Tcl_DStringInit(&buf);
nativeValue = Tcl_UtfToWCharDString(valueName, valueNameObj->length, &buf);
result = RegQueryValueExW(key, nativeValue, NULL, &type,
(BYTE *) Tcl_DStringValue(&data), &length);
while (result == ERROR_MORE_DATA) {
/*
* The Windows docs say that in this error case, we just need to
* expand our buffer and request more data. Required for
* HKEY_PERFORMANCE_DATA
*/
length = Tcl_DStringLength(&data) * (2 / sizeof(WCHAR));
Tcl_DStringSetLength(&data, (int) length * sizeof(WCHAR));
result = RegQueryValueExW(key, nativeValue,
NULL, &type, (BYTE *) Tcl_DStringValue(&data), &length);
}
Tcl_DStringFree(&buf);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unable to get value \"%s\" from key \"%s\": ",
|
| ︙ | ︙ | |||
805 806 807 808 809 810 811 |
/*
* Multistrings are stored as an array of null-terminated strings,
* terminated by two null characters. Also do a bounds check in case
* we get bogus data.
*/
while ((p < end) && *((WCHAR *) p) != 0) {
| | > | < | > > | 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 |
/*
* Multistrings are stored as an array of null-terminated strings,
* terminated by two null characters. Also do a bounds check in case
* we get bogus data.
*/
while ((p < end) && *((WCHAR *) p) != 0) {
WCHAR *wp = (WCHAR *) p;
Tcl_DStringInit(&buf);
Tcl_WCharToUtfDString(wp, wcslen(wp), &buf);
Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(Tcl_DStringValue(&buf),
Tcl_DStringLength(&buf)));
while (*wp++ != 0) {/* empty body */}
p = (char *) wp;
Tcl_DStringFree(&buf);
}
Tcl_SetObjResult(interp, resultPtr);
} else if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) {
WCHAR *wp = (WCHAR *) Tcl_DStringValue(&data);
Tcl_DStringInit(&buf);
Tcl_WCharToUtfDString((const WCHAR *)Tcl_DStringValue(&data), wcslen(wp), &buf);
Tcl_DStringResult(interp, &buf);
} else {
/*
* Save binary data as a byte array.
*/
Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(
|
| ︙ | ︙ | |||
876 877 878 879 880 881 882 |
mode |= KEY_QUERY_VALUE;
if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
resultPtr = Tcl_NewObj();
Tcl_DStringInit(&buffer);
| | | < < | > | 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 |
mode |= KEY_QUERY_VALUE;
if (OpenKey(interp, keyNameObj, mode, 0, &key) != TCL_OK) {
return TCL_ERROR;
}
resultPtr = Tcl_NewObj();
Tcl_DStringInit(&buffer);
Tcl_DStringSetLength(&buffer, (int) (MAX_KEY_LENGTH * sizeof(WCHAR)));
index = 0;
result = TCL_OK;
if (patternObj) {
pattern = Tcl_GetString(patternObj);
} else {
pattern = NULL;
}
/*
* Enumerate the values under the given subkey until we get an error,
* indicating the end of the list. Note that we need to reset size after
* each iteration because RegEnumValue smashes the old value.
*/
size = MAX_KEY_LENGTH;
while (RegEnumValueW(key,index, (WCHAR *)Tcl_DStringValue(&buffer),
&size, NULL, NULL, NULL, NULL) == ERROR_SUCCESS) {
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString((const WCHAR *)Tcl_DStringValue(&buffer), size, &ds);
name = Tcl_DStringValue(&ds);
if (!pattern || Tcl_StringMatch(name, pattern)) {
result = Tcl_ListObjAppendElement(interp, resultPtr,
Tcl_NewStringObj(name, Tcl_DStringLength(&ds)));
if (result != TCL_OK) {
Tcl_DStringFree(&ds);
break;
|
| ︙ | ︙ | |||
949 950 951 952 953 954 955 |
HKEY *keyPtr) /* Returned HKEY. */
{
char *keyName, *buffer, *hostName;
HKEY rootKey;
DWORD result;
keyName = Tcl_GetString(keyNameObj);
| | | 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 |
HKEY *keyPtr) /* Returned HKEY. */
{
char *keyName, *buffer, *hostName;
HKEY rootKey;
DWORD result;
keyName = Tcl_GetString(keyNameObj);
buffer = (char *)Tcl_Alloc(keyNameObj->length + 1);
strcpy(buffer, keyName);
result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName);
if (result == TCL_OK) {
result = OpenSubKey(hostName, rootKey, keyName, mode, flags, keyPtr);
if (result != ERROR_SUCCESS) {
Tcl_SetObjResult(interp,
|
| ︙ | ︙ | |||
1004 1005 1006 1007 1008 1009 1010 |
Tcl_DString buf;
/*
* Attempt to open the root key on a remote host if necessary.
*/
if (hostName) {
| > | | > | | | | 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 |
Tcl_DString buf;
/*
* Attempt to open the root key on a remote host if necessary.
*/
if (hostName) {
Tcl_DStringInit(&buf);
hostName = (char *) Tcl_UtfToWCharDString(hostName, -1, &buf);
result = RegConnectRegistryW((WCHAR *)hostName, rootKey,
&rootKey);
Tcl_DStringFree(&buf);
if (result != ERROR_SUCCESS) {
return result;
}
}
/*
* Now open the specified key with the requested permissions. Note that
* this key must be closed by the caller.
*/
if (keyName) {
Tcl_DStringInit(&buf);
keyName = (char *) Tcl_UtfToWCharDString(keyName, -1, &buf);
}
if (flags & REG_CREATE) {
DWORD create;
result = RegCreateKeyExW(rootKey, (WCHAR *)keyName, 0, NULL,
REG_OPTION_NON_VOLATILE, mode, NULL, keyPtr, &create);
} else if (rootKey == HKEY_PERFORMANCE_DATA) {
/*
* Here we fudge it for this special root key. See MSDN for more info
* on HKEY_PERFORMANCE_DATA and the peculiarities surrounding it.
*/
*keyPtr = HKEY_PERFORMANCE_DATA;
result = ERROR_SUCCESS;
} else {
result = RegOpenKeyExW(rootKey, (WCHAR *)keyName, 0, mode,
keyPtr);
}
if (keyName) {
Tcl_DStringFree(&buf);
}
/*
|
| ︙ | ︙ | |||
1155 1156 1157 1158 1159 1160 1161 |
*
*----------------------------------------------------------------------
*/
static DWORD
RecursiveDeleteKey(
HKEY startKey, /* Parent of key to be deleted. */
| | | | | | | | | | | | 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 |
*
*----------------------------------------------------------------------
*/
static DWORD
RecursiveDeleteKey(
HKEY startKey, /* Parent of key to be deleted. */
const WCHAR *keyName, /* Name of key to be deleted in external
* encoding, not UTF. */
REGSAM mode) /* Mode flags to pass. */
{
DWORD result, size;
Tcl_DString subkey;
HKEY hKey;
REGSAM saveMode = mode;
static int checkExProc = 0;
static LONG (* regDeleteKeyExProc) (HKEY, LPCWSTR, REGSAM, DWORD) = (LONG (*) (HKEY, LPCWSTR, REGSAM, DWORD)) NULL;
/*
* Do not allow NULL or empty key name.
*/
if (!keyName || *keyName == '\0') {
return ERROR_BADKEY;
}
mode |= KEY_ENUMERATE_SUB_KEYS | DELETE | KEY_QUERY_VALUE;
result = RegOpenKeyExW(startKey, keyName, 0, mode, &hKey);
if (result != ERROR_SUCCESS) {
return result;
}
Tcl_DStringInit(&subkey);
Tcl_DStringSetLength(&subkey, (int) (MAX_KEY_LENGTH * sizeof(WCHAR)));
mode = saveMode;
while (result == ERROR_SUCCESS) {
/*
* Always get index 0 because key deletion changes ordering.
*/
size = MAX_KEY_LENGTH;
result = RegEnumKeyExW(hKey, 0, (WCHAR *)Tcl_DStringValue(&subkey),
&size, NULL, NULL, NULL, NULL);
if (result == ERROR_NO_MORE_ITEMS) {
/*
* RegDeleteKeyEx doesn't exist on non-64bit XP platforms, so we
* can't compile with it in. We need to check for it at runtime
* and use it if we find it.
*/
if (mode && !checkExProc) {
HMODULE handle;
checkExProc = 1;
handle = GetModuleHandleW(L"ADVAPI32");
regDeleteKeyExProc = (LONG (*) (HKEY, LPCWSTR, REGSAM, DWORD))
(void *)GetProcAddress(handle, "RegDeleteKeyExW");
}
if (mode && regDeleteKeyExProc) {
result = regDeleteKeyExProc(startKey, keyName, mode, 0);
} else {
result = RegDeleteKeyW(startKey, keyName);
}
break;
} else if (result == ERROR_SUCCESS) {
result = RecursiveDeleteKey(hKey,
(const WCHAR *) Tcl_DStringValue(&subkey), mode);
}
}
Tcl_DStringFree(&subkey);
RegCloseKey(hKey);
return result;
}
|
| ︙ | ︙ | |||
1271 1272 1273 1274 1275 1276 1277 |
}
mode |= KEY_ALL_ACCESS;
if (OpenKey(interp, keyNameObj, mode, 1, &key) != TCL_OK) {
return TCL_ERROR;
}
valueName = Tcl_GetString(valueNameObj);
| > | | | 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 |
}
mode |= KEY_ALL_ACCESS;
if (OpenKey(interp, keyNameObj, mode, 1, &key) != TCL_OK) {
return TCL_ERROR;
}
valueName = Tcl_GetString(valueNameObj);
Tcl_DStringInit(&nameBuf);
valueName = (char *) Tcl_UtfToWCharDString(valueName, valueNameObj->length, &nameBuf);
if (type == REG_DWORD || type == REG_DWORD_BIG_ENDIAN) {
int value;
if (Tcl_GetIntFromObj(interp, dataObj, &value) != TCL_OK) {
RegCloseKey(key);
Tcl_DStringFree(&nameBuf);
return TCL_ERROR;
}
value = ConvertDWORD((DWORD) type, (DWORD) value);
result = RegSetValueExW(key, (WCHAR *) valueName, 0,
(DWORD) type, (BYTE *) &value, sizeof(DWORD));
} else if (type == REG_MULTI_SZ) {
Tcl_DString data, buf;
int objc, i;
Tcl_Obj **objv;
if (Tcl_ListObjGetElements(interp, dataObj, &objc, &objv) != TCL_OK) {
|
| ︙ | ︙ | |||
1315 1316 1317 1318 1319 1320 1321 | /* * Add a null character to separate this value from the next. */ Tcl_DStringAppend(&data, "", 1); /* NUL-terminated string */ } | > | | > | | | | 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 |
/*
* Add a null character to separate this value from the next.
*/
Tcl_DStringAppend(&data, "", 1); /* NUL-terminated string */
}
Tcl_DStringInit(&buf);
Tcl_UtfToWCharDString(Tcl_DStringValue(&data), Tcl_DStringLength(&data)+1,
&buf);
result = RegSetValueExW(key, (WCHAR *) valueName, 0,
(DWORD) type, (BYTE *) Tcl_DStringValue(&buf),
(DWORD) Tcl_DStringLength(&buf));
Tcl_DStringFree(&data);
Tcl_DStringFree(&buf);
} else if (type == REG_SZ || type == REG_EXPAND_SZ) {
Tcl_DString buf;
const char *data = Tcl_GetString(dataObj);
Tcl_DStringInit(&buf);
data = (char *) Tcl_UtfToWCharDString(data, dataObj->length, &buf);
/*
* Include the null in the length, padding if needed for WCHAR.
*/
Tcl_DStringSetLength(&buf, Tcl_DStringLength(&buf)+1);
result = RegSetValueExW(key, (WCHAR *) valueName, 0,
(DWORD) type, (BYTE *) data, (DWORD) Tcl_DStringLength(&buf) + 1);
Tcl_DStringFree(&buf);
} else {
BYTE *data;
size_t bytelength;
/*
* Store binary data in the registry.
*/
data = (BYTE *) getByteArrayFromObj(dataObj, &bytelength);
result = RegSetValueExW(key, (WCHAR *) valueName, 0,
(DWORD) type, data, (DWORD) bytelength);
}
Tcl_DStringFree(&nameBuf);
RegCloseKey(key);
if (result != ERROR_SUCCESS) {
|
| ︙ | ︙ | |||
1406 1407 1408 1409 1410 1411 1412 |
}
if (Tcl_GetIntFromObj(interp, objv[2], &timeout) != TCL_OK) {
return TCL_ERROR;
}
}
str = Tcl_GetString(objv[0]);
| > | | | 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 |
}
if (Tcl_GetIntFromObj(interp, objv[2], &timeout) != TCL_OK) {
return TCL_ERROR;
}
}
str = Tcl_GetString(objv[0]);
Tcl_DStringInit(&ds);
wstr = Tcl_UtfToWCharDString(str, objv[0]->length, &ds);
if (Tcl_DStringLength(&ds) == 0) {
wstr = NULL;
}
/*
* Use the ignore the result.
*/
result = SendMessageTimeoutW(HWND_BROADCAST, WM_SETTINGCHANGE,
(WPARAM) 0, (LPARAM) wstr, SMTO_ABORTIFHUNG, (UINT) timeout, &sendResult);
Tcl_DStringFree(&ds);
objPtr = Tcl_NewObj();
Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) result));
Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewWideIntObj((Tcl_WideInt) sendResult));
Tcl_SetObjResult(interp, objPtr);
|
| ︙ | ︙ | |||
1450 1451 1452 1453 1454 1455 1456 |
static void
AppendSystemError(
Tcl_Interp *interp, /* Current interpreter. */
DWORD error) /* Result code from error. */
{
int length;
| | | | > | | 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 |
static void
AppendSystemError(
Tcl_Interp *interp, /* Current interpreter. */
DWORD error) /* Result code from error. */
{
int length;
WCHAR *tMsgPtr, **tMsgPtrPtr = &tMsgPtr;
const char *msg;
char id[TCL_INTEGER_SPACE], msgBuf[24 + TCL_INTEGER_SPACE];
Tcl_DString ds;
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
if (Tcl_IsShared(resultPtr)) {
resultPtr = Tcl_DuplicateObj(resultPtr);
}
length = FormatMessageW(FORMAT_MESSAGE_FROM_SYSTEM
| FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, error,
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), (WCHAR *) tMsgPtrPtr,
0, NULL);
if (length == 0) {
sprintf(msgBuf, "unknown error: %ld", error);
msg = msgBuf;
} else {
char *msgPtr;
Tcl_DStringInit(&ds);
Tcl_WCharToUtfDString(tMsgPtr, wcslen(tMsgPtr), &ds);
LocalFree(tMsgPtr);
msgPtr = Tcl_DStringValue(&ds);
length = Tcl_DStringLength(&ds);
/*
* Trim the trailing CR/LF from the system message.
|
| ︙ | ︙ |
Changes to win/tclWinSerial.c.
| ︙ | ︙ | |||
164 165 166 167 168 169 170 | /* * Declarations for functions used only in this file. */ static int SerialBlockProc(ClientData instanceData, int mode); static void SerialCheckProc(ClientData clientData, int flags); static int SerialCloseProc(ClientData instanceData, | | | 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 | /* * Declarations for functions used only in this file. */ static int SerialBlockProc(ClientData instanceData, int mode); static void SerialCheckProc(ClientData clientData, int flags); static int SerialCloseProc(ClientData instanceData, Tcl_Interp *interp, int flags); static int SerialEventProc(Tcl_Event *evPtr, int flags); static void SerialExitHandler(ClientData clientData); static int SerialGetHandleProc(ClientData instanceData, int direction, ClientData *handlePtr); static ThreadSpecificData *SerialInit(void); static int SerialInputProc(ClientData instanceData, char *buf, int toRead, int *errorCode); |
| ︙ | ︙ | |||
200 201 202 203 204 205 206 |
* This structure describes the channel type structure for command serial
* based IO.
*/
static const Tcl_ChannelType serialChannelType = {
"serial", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
| | | | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 |
* This structure describes the channel type structure for command serial
* based IO.
*/
static const Tcl_ChannelType serialChannelType = {
"serial", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
TCL_CLOSE2PROC, /* Close proc. */
SerialInputProc, /* Input proc. */
SerialOutputProc, /* Output proc. */
NULL, /* Seek proc. */
SerialSetOptionProc, /* Set option proc. */
SerialGetOptionProc, /* Get option proc. */
SerialWatchProc, /* Set up notifier to watch the channel. */
SerialGetHandleProc, /* Get an OS handle from channel. */
SerialCloseProc, /* close2proc. */
SerialBlockProc, /* Set blocking or non-blocking mode.*/
NULL, /* flush proc. */
NULL, /* handler proc. */
NULL, /* wide seek proc */
SerialThreadActionProc, /* thread action proc */
NULL /* truncate */
};
|
| ︙ | ︙ | |||
281 282 283 284 285 286 287 | * Removes the serial event source. * *---------------------------------------------------------------------- */ static void SerialExitHandler( | | | 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 |
* Removes the serial event source.
*
*----------------------------------------------------------------------
*/
static void
SerialExitHandler(
TCL_UNUSED(ClientData))
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
SerialInfo *infoPtr;
/*
* Clear all eventually pending output. Otherwise Tcl's exit could totally
* block, because it performs a blocking flush on all open channels. Note
|
| ︙ | ︙ | |||
319 320 321 322 323 324 325 | * Resets the process list. * *---------------------------------------------------------------------- */ static void ProcExitHandler( | | | 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 |
* Resets the process list.
*
*----------------------------------------------------------------------
*/
static void
ProcExitHandler(
TCL_UNUSED(ClientData))
{
Tcl_MutexLock(&serialMutex);
initialized = 0;
Tcl_MutexUnlock(&serialMutex);
}
/*
|
| ︙ | ︙ | |||
396 397 398 399 400 401 402 403 404 | * * Side effects: * Adjusts the block time if needed. * *---------------------------------------------------------------------- */ void SerialSetupProc( | > > > > | | 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 |
*
* Side effects:
* Adjusts the block time if needed.
*
*----------------------------------------------------------------------
*/
#ifdef __cplusplus
#define min(a, b) (((a) < (b)) ? (a) : (b))
#endif
void
SerialSetupProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
SerialInfo *infoPtr;
int block = 1;
int msec = INT_MAX; /* min. found block time */
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
|
| ︙ | ︙ | |||
453 454 455 456 457 458 459 | * May queue an event. * *---------------------------------------------------------------------- */ static void SerialCheckProc( | | | 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 |
* May queue an event.
*
*----------------------------------------------------------------------
*/
static void
SerialCheckProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
SerialInfo *infoPtr;
SerialEvent *evPtr;
int needEvent;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
COMSTAT cStat;
|
| ︙ | ︙ | |||
527 528 529 530 531 532 533 |
/*
* Queue an event if the serial is signaled for reading or writing.
*/
if (needEvent) {
infoPtr->flags |= SERIAL_PENDING;
| | | 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 |
/*
* Queue an event if the serial is signaled for reading or writing.
*/
if (needEvent) {
infoPtr->flags |= SERIAL_PENDING;
evPtr = (SerialEvent *)ckalloc(sizeof(SerialEvent));
evPtr->header.proc = SerialEventProc;
evPtr->infoPtr = infoPtr;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
}
}
}
|
| ︙ | ︙ | |||
593 594 595 596 597 598 599 |
*
*----------------------------------------------------------------------
*/
static int
SerialCloseProc(
ClientData instanceData, /* Pointer to SerialInfo structure. */
| | > | > > > | | 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 |
*
*----------------------------------------------------------------------
*/
static int
SerialCloseProc(
ClientData instanceData, /* Pointer to SerialInfo structure. */
TCL_UNUSED(Tcl_Interp *),
int flags)
{
SerialInfo *serialPtr = (SerialInfo *) instanceData;
int errorCode = 0, result = 0;
SerialInfo *infoPtr, **nextPtrPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) {
return EINVAL;
}
if (serialPtr->validMask & TCL_READABLE) {
PurgeComm(serialPtr->handle, PURGE_RXABORT | PURGE_RXCLEAR);
CloseHandle(serialPtr->osRead.hEvent);
}
serialPtr->validMask &= ~TCL_READABLE;
|
| ︙ | ︙ | |||
658 659 660 661 662 663 664 |
}
/*
* Wrap the error file into a channel and give it to the cleanup routine.
*/
if (serialPtr->writeBuf != NULL) {
| | | | 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 |
}
/*
* Wrap the error file into a channel and give it to the cleanup routine.
*/
if (serialPtr->writeBuf != NULL) {
ckfree(serialPtr->writeBuf);
serialPtr->writeBuf = NULL;
}
ckfree(serialPtr);
if (errorCode == 0) {
return result;
}
return errorCode;
}
|
| ︙ | ︙ | |||
1023 1024 1025 1026 1027 1028 1029 |
if (toWrite > infoPtr->writeBufLen) {
/*
* Reallocate the buffer to be large enough to hold the data.
*/
if (infoPtr->writeBuf) {
| | | | 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 |
if (toWrite > infoPtr->writeBufLen) {
/*
* Reallocate the buffer to be large enough to hold the data.
*/
if (infoPtr->writeBuf) {
ckfree(infoPtr->writeBuf);
}
infoPtr->writeBufLen = toWrite;
infoPtr->writeBuf = (char *)ckalloc(toWrite);
}
memcpy(infoPtr->writeBuf, buf, toWrite);
infoPtr->toWrite = toWrite;
ResetEvent(infoPtr->evWritable);
TclPipeThreadSignal(&infoPtr->writeTI);
bytesWritten = (DWORD) toWrite;
|
| ︙ | ︙ | |||
1238 1239 1240 1241 1242 1243 1244 |
*
*----------------------------------------------------------------------
*/
static int
SerialGetHandleProc(
ClientData instanceData, /* The serial state. */
| | | 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 |
*
*----------------------------------------------------------------------
*/
static int
SerialGetHandleProc(
ClientData instanceData, /* The serial state. */
TCL_UNUSED(int) /*direction*/,
ClientData *handlePtr) /* Where to store the handle. */
{
SerialInfo *infoPtr = (SerialInfo *) instanceData;
*handlePtr = (ClientData) infoPtr->handle;
return TCL_OK;
}
|
| ︙ | ︙ | |||
1287 1288 1289 1290 1291 1292 1293 | break; } infoPtr = (SerialInfo *) pipeTI->clientData; buf = infoPtr->writeBuf; toWrite = infoPtr->toWrite; | | | 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 |
break;
}
infoPtr = (SerialInfo *) pipeTI->clientData;
buf = infoPtr->writeBuf;
toWrite = infoPtr->toWrite;
myWrite.hEvent = CreateEventW(NULL, TRUE, FALSE, NULL);
/*
* Loop until all of the bytes are written or an error occurs.
*/
while (toWrite > 0) {
/*
|
| ︙ | ︙ | |||
1399 1400 1401 1402 1403 1404 1405 |
{
SerialInit();
/*
* If an open channel is specified, close it
*/
| | | | 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 |
{
SerialInit();
/*
* If an open channel is specified, close it
*/
if (handle != INVALID_HANDLE_VALUE && CloseHandle(handle) == FALSE) {
return INVALID_HANDLE_VALUE;
}
/*
* Multithreaded I/O needs the overlapped flag set otherwise
* ClearCommError blocks under Windows NT/2000 until serial output is
* finished
*/
handle = CreateFileW(name, access, 0, 0, OPEN_EXISTING,
FILE_FLAG_OVERLAPPED, 0);
return handle;
}
/*
*----------------------------------------------------------------------
|
| ︙ | ︙ | |||
1443 1444 1445 1446 1447 1448 1449 |
char *channelName,
int permissions)
{
SerialInfo *infoPtr;
SerialInit();
| | | 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 |
char *channelName,
int permissions)
{
SerialInfo *infoPtr;
SerialInit();
infoPtr = (SerialInfo *)ckalloc(sizeof(SerialInfo));
memset(infoPtr, 0, sizeof(SerialInfo));
infoPtr->validMask = permissions;
infoPtr->handle = handle;
infoPtr->channel = (Tcl_Channel) NULL;
infoPtr->readable = 0;
infoPtr->writable = 1;
|
| ︙ | ︙ | |||
1482 1483 1484 1485 1486 1487 1488 |
* Default is blocking.
*/
SetCommTimeouts(handle, &no_timeout);
InitializeCriticalSection(&infoPtr->csWrite);
if (permissions & TCL_READABLE) {
| | | | | 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 |
* Default is blocking.
*/
SetCommTimeouts(handle, &no_timeout);
InitializeCriticalSection(&infoPtr->csWrite);
if (permissions & TCL_READABLE) {
infoPtr->osRead.hEvent = CreateEventW(NULL, TRUE, FALSE, NULL);
}
if (permissions & TCL_WRITABLE) {
/*
* Initially the channel is writable and the writeThread is idle.
*/
infoPtr->osWrite.hEvent = CreateEventW(NULL, TRUE, FALSE, NULL);
infoPtr->evWritable = CreateEventW(NULL, TRUE, TRUE, NULL);
infoPtr->writeThread = CreateThread(NULL, 256, SerialWriterThread,
TclPipeThreadCreateTI(&infoPtr->writeTI, infoPtr,
infoPtr->evWritable), 0, NULL);
}
/*
* Files have default translation of AUTO and ^Z eof char, which means
|
| ︙ | ︙ | |||
1665 1666 1667 1668 1669 1670 1671 |
* Option -mode baud,parity,databits,stopbits
*/
if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) {
if (!GetCommState(infoPtr->handle, &dcb)) {
goto getStateFailed;
}
| > | | | 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 |
* Option -mode baud,parity,databits,stopbits
*/
if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) {
if (!GetCommState(infoPtr->handle, &dcb)) {
goto getStateFailed;
}
Tcl_DStringInit(&ds);
native = Tcl_UtfToWCharDString(value, -1, &ds);
result = BuildCommDCBW(native, &dcb);
Tcl_DStringFree(&ds);
if (result == FALSE) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad value \"%s\" for -mode: should be baud,parity,data,stop",
value));
|
| ︙ | ︙ | |||
1769 1770 1771 1772 1773 1774 1775 |
badXchar:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -xchar: should be a list of"
" two elements with each a single 8-bit character", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL);
}
| | | 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 |
badXchar:
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"bad value for -xchar: should be a list of"
" two elements with each a single 8-bit character", -1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL);
}
ckfree(argv);
return TCL_ERROR;
}
/*
* These dereferences are safe, even in the zero-length string cases,
* because that just makes the xon/xoff character into NUL. When the
* character looks like it is UTF-8 encoded, decode it before casting
|
| ︙ | ︙ | |||
1800 1801 1802 1803 1804 1805 1806 |
dcb.XonChar = (char) character;
charLen = Tcl_UtfToUniChar(argv[1], &character);
if ((character > 0xFF) || argv[1][charLen]) {
goto badXchar;
}
dcb.XoffChar = (char) character;
}
| | | 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 |
dcb.XonChar = (char) character;
charLen = Tcl_UtfToUniChar(argv[1], &character);
if ((character > 0xFF) || argv[1][charLen]) {
goto badXchar;
}
dcb.XoffChar = (char) character;
}
ckfree(argv);
if (!SetCommState(infoPtr->handle, &dcb)) {
goto setStateFailed;
}
return TCL_OK;
}
|
| ︙ | ︙ | |||
1825 1826 1827 1828 1829 1830 1831 |
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);
}
| | | 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 |
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) {
result = TCL_ERROR;
break;
|
| ︙ | ︙ | |||
1883 1884 1885 1886 1887 1888 1889 | NULL); } result = TCL_ERROR; break; } } | | | 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 |
NULL);
}
result = TCL_ERROR;
break;
}
}
ckfree(argv);
return result;
}
/*
* Option -sysbuffer {read_size write_size}
* Option -sysbuffer read_size
*/
|
| ︙ | ︙ | |||
1909 1910 1911 1912 1913 1914 1915 |
if (argc == 1) {
inSize = atoi(argv[0]);
outSize = infoPtr->sysBufWrite;
} else if (argc == 2) {
inSize = atoi(argv[0]);
outSize = atoi(argv[1]);
}
| | | 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 |
if (argc == 1) {
inSize = atoi(argv[0]);
outSize = infoPtr->sysBufWrite;
} else if (argc == 2) {
inSize = atoi(argv[0]);
outSize = atoi(argv[1]);
}
ckfree(argv);
if ((argc < 1) || (argc > 2) || (inSize <= 0) || (outSize <= 0)) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad value \"%s\" for -sysbuffer: should be "
"a list of one or two integers > 0", value));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "SYS_BUFFER", NULL);
|
| ︙ | ︙ | |||
2147 2148 2149 2150 2151 2152 2153 |
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-xchar");
Tcl_DStringStartSublist(dsPtr);
}
if (len==0 || (len>1 && strncmp(optionName, "-xchar", len) == 0)) {
| | | 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 |
*/
if (len == 0) {
Tcl_DStringAppendElement(dsPtr, "-xchar");
Tcl_DStringStartSublist(dsPtr);
}
if (len==0 || (len>1 && strncmp(optionName, "-xchar", len) == 0)) {
char buf[4];
valid = 1;
if (!GetCommState(infoPtr->handle, &dcb)) {
if (interp != NULL) {
TclWinConvertError(GetLastError());
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't get comm state: %s", Tcl_PosixError(interp)));
|
| ︙ | ︙ |
Changes to win/tclWinSock.c.
| ︙ | ︙ | |||
231 232 233 234 235 236 237 |
* list. This value is also checked by
* the event structure. */
TcpState *socketList; /* Every open socket in this thread has an
* entry on this list. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
| | | 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 |
* list. This value is also checked by
* the event structure. */
TcpState *socketList; /* Every open socket in this thread has an
* entry on this list. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
static WNDCLASSW windowClass;
/*
* Static routines for this file:
*/
static int TcpConnect(Tcl_Interp *interp,
TcpState *state);
|
| ︙ | ︙ | |||
276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 |
* This structure describes the channel type structure for TCP socket
* based IO:
*/
static const Tcl_ChannelType tcpChannelType = {
"tcp", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
TcpCloseProc, /* Close proc. */
TcpInputProc, /* Input proc. */
TcpOutputProc, /* Output proc. */
NULL, /* Seek proc. */
TcpSetOptionProc, /* Set option proc. */
TcpGetOptionProc, /* Get option proc. */
TcpWatchProc, /* Initialize notifier. */
TcpGetHandleProc, /* Get OS handles out of channel. */
| > > > > | 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 |
* This structure describes the channel type structure for TCP socket
* based IO:
*/
static const Tcl_ChannelType tcpChannelType = {
"tcp", /* Type name. */
TCL_CHANNEL_VERSION_5, /* v5 channel */
#ifndef TCL_NO_DEPRECATED
TcpCloseProc, /* Close proc. */
#else
TCL_CLOSE2PROC, /* Close proc. */
#endif
TcpInputProc, /* Input proc. */
TcpOutputProc, /* Output proc. */
NULL, /* Seek proc. */
TcpSetOptionProc, /* Set option proc. */
TcpGetOptionProc, /* Get option proc. */
TcpWatchProc, /* Initialize notifier. */
TcpGetHandleProc, /* Get OS handles out of channel. */
|
| ︙ | ︙ | |||
306 307 308 309 310 311 312 |
{0, 0, NULL, NULL, InitializeHostName, NULL, NULL};
/*
* Simple wrapper round the SendMessage syscall.
*/
#define SendSelectMessage(tsdPtr, message, payload) \
| | | 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 |
{0, 0, NULL, NULL, InitializeHostName, NULL, NULL};
/*
* Simple wrapper round the SendMessage syscall.
*/
#define SendSelectMessage(tsdPtr, message, payload) \
SendMessageW((tsdPtr)->hwnd, SOCKET_SELECT, \
(WPARAM) (message), (LPARAM) (payload))
/*
* Address print debug functions
*/
#if 0
|
| ︙ | ︙ | |||
356 357 358 359 360 361 362 |
*
*----------------------------------------------------------------------
*/
void
InitializeHostName(
char **valuePtr,
| | | | > | | < | 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 |
*
*----------------------------------------------------------------------
*/
void
InitializeHostName(
char **valuePtr,
unsigned int *lengthPtr,
Tcl_Encoding *encodingPtr)
{
WCHAR wbuf[256];
DWORD length = sizeof(wbuf)/sizeof(WCHAR);
Tcl_DString ds;
Tcl_DStringInit(&ds);
if (GetComputerNameExW(ComputerNamePhysicalDnsFullyQualified, wbuf, &length) != 0) {
/*
* Convert string from native to UTF then change to lowercase.
*/
Tcl_UtfToLower(Tcl_WCharToUtfDString(wbuf, -1, &ds));
} else {
if (TclpHasSockets(NULL) == TCL_OK) {
/*
* The buffer size of 256 is recommended by the MSDN page that
* documents gethostname() as being always adequate.
*/
Tcl_DString inDs;
|
| ︙ | ︙ | |||
393 394 395 396 397 398 399 |
}
Tcl_DStringFree(&inDs);
}
}
*encodingPtr = Tcl_GetEncoding(NULL, "utf-8");
*lengthPtr = Tcl_DStringLength(&ds);
| | | 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 |
}
Tcl_DStringFree(&inDs);
}
}
*encodingPtr = Tcl_GetEncoding(NULL, "utf-8");
*lengthPtr = Tcl_DStringLength(&ds);
*valuePtr = (char *)ckalloc(*lengthPtr + 1);
memcpy(*valuePtr, Tcl_DStringValue(&ds), *lengthPtr + 1);
Tcl_DStringFree(&ds);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
485 486 487 488 489 490 491 |
*
*----------------------------------------------------------------------
*/
void
TclpFinalizeSockets(void)
{
| | | | 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 |
*
*----------------------------------------------------------------------
*/
void
TclpFinalizeSockets(void)
{
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
/*
* Careful! This is a finalizer!
*/
if (tsdPtr == NULL) {
return;
}
if (tsdPtr->socketThread != NULL) {
if (tsdPtr->hwnd != NULL) {
PostMessageW(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0);
/*
* Wait for the thread to exit. This ensures that we are
* completely cleaned up before we leave this function.
*/
WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
|
| ︙ | ︙ | |||
538 539 540 541 542 543 544 | * * Side effects: * Sets the device into blocking or nonblocking mode. * *---------------------------------------------------------------------- */ | < | | 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 |
*
* Side effects:
* Sets the device into blocking or nonblocking mode.
*
*----------------------------------------------------------------------
*/
static int
TcpBlockModeProc(
ClientData instanceData, /* Socket state. */
int mode) /* The mode to set. Can be one of
* TCL_MODE_BLOCKING or
* TCL_MODE_NONBLOCKING. */
{
TcpState *statePtr = (TcpState *)instanceData;
if (mode == TCL_MODE_NONBLOCKING) {
SET_BITS(statePtr->flags, TCP_NONBLOCKING);
} else {
CLEAR_BITS(statePtr->flags, TCP_NONBLOCKING);
}
return 0;
|
| ︙ | ︙ | |||
642 643 644 645 646 647 648 |
/*
* Loop in the blocking case until the connect signal is present
*/
while (1) {
/*
| | | | | 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 |
/*
* Loop in the blocking case until the connect signal is present
*/
while (1) {
/*
* Get the statePtr lock.
*/
tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
/*
* Check for connect event.
*/
if (GOT_BITS(statePtr->readyEvents, FD_CONNECT)) {
|
| ︙ | ︙ | |||
770 771 772 773 774 775 776 | * * Side effects: * Reads input from the input device of the channel. * *---------------------------------------------------------------------- */ | < | | | 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 |
*
* Side effects:
* Reads input from the input device of the channel.
*
*----------------------------------------------------------------------
*/
static int
TcpInputProc(
ClientData instanceData, /* Socket state. */
char *buf, /* Where to store data read. */
int bufSize, /* How much space is available in the
* buffer? */
int *errorCodePtr) /* Where to store error code. */
{
TcpState *statePtr = (TcpState *)instanceData;
int bytesRead;
DWORD error;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
*errorCodePtr = 0;
/*
* Check that WinSock is initialized; do not call it if not, to prevent
* system crashes. This can happen at exit time if the exit handler for
* WinSock ran before other exit handlers that want to use sockets.
|
| ︙ | ︙ | |||
922 923 924 925 926 927 928 |
static int
TcpOutputProc(
ClientData instanceData, /* Socket state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
{
| | | | 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 |
static int
TcpOutputProc(
ClientData instanceData, /* Socket state. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCodePtr) /* Where to store error code. */
{
TcpState *statePtr = (TcpState *)instanceData;
int written;
DWORD error;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
*errorCodePtr = 0;
/*
* Check that WinSock is initialized; do not call it if not, to prevent
* system crashes. This can happen at exit time if the exit handler for
* WinSock ran before other exit handlers that want to use sockets.
|
| ︙ | ︙ | |||
1030 1031 1032 1033 1034 1035 1036 | * * Side effects: * Closes the socket. * *---------------------------------------------------------------------- */ | < | | | 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 |
*
* Side effects:
* Closes the socket.
*
*----------------------------------------------------------------------
*/
static int
TcpCloseProc(
ClientData instanceData, /* The socket to close. */
TCL_UNUSED(Tcl_Interp *))
{
TcpState *statePtr = (TcpState *)instanceData;
/* TIP #218 */
int errorCode = 0;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* Check that WinSock is initialized; do not call it if not, to prevent
* system crashes. This can happen at exit time if the exit handler for
|
| ︙ | ︙ | |||
1062 1063 1064 1065 1066 1067 1068 |
TcpFdList *thisfd = statePtr->sockets;
statePtr->sockets = thisfd->next;
if (closesocket(thisfd->fd) == SOCKET_ERROR) {
TclWinConvertError((DWORD) WSAGetLastError());
errorCode = Tcl_GetErrno();
}
| | | 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 |
TcpFdList *thisfd = statePtr->sockets;
statePtr->sockets = thisfd->next;
if (closesocket(thisfd->fd) == SOCKET_ERROR) {
TclWinConvertError((DWORD) WSAGetLastError());
errorCode = Tcl_GetErrno();
}
ckfree(thisfd);
}
}
if (statePtr->addrlist != NULL) {
freeaddrinfo(statePtr->addrlist);
}
if (statePtr->myaddrlist != NULL) {
|
| ︙ | ︙ | |||
1104 1105 1106 1107 1108 1109 1110 |
/*
* TIP #218. Removed the code removing the structure from the global
* socket list. This is now done by the thread action callbacks, and only
* there. This happens before this code is called. We can free without
* fear of damaging the list.
*/
| | | 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 |
/*
* TIP #218. Removed the code removing the structure from the global
* socket list. This is now done by the thread action callbacks, and only
* there. This happens before this code is called. We can free without
* fear of damaging the list.
*/
ckfree(statePtr);
return errorCode;
}
/*
*----------------------------------------------------------------------
*
* TcpClose2Proc --
|
| ︙ | ︙ | |||
1131 1132 1133 1134 1135 1136 1137 |
static int
TcpClose2Proc(
ClientData instanceData, /* The socket to close. */
Tcl_Interp *interp, /* For error reporting. */
int flags) /* Flags that indicate which side to close. */
{
| | | | < < < < | < < < < < < < | | | > > > | | | 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 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 |
static int
TcpClose2Proc(
ClientData instanceData, /* The socket to close. */
Tcl_Interp *interp, /* For error reporting. */
int flags) /* Flags that indicate which side to close. */
{
TcpState *statePtr = (TcpState *)instanceData;
int readError = 0;
int writeError = 0;
/*
* Shutdown the OS socket handle.
*/
if ((flags & (TCL_CLOSE_READ|TCL_CLOSE_WRITE)) == 0) {
return TcpCloseProc(instanceData, interp);
}
/*
* Single fd operation: Tcl_OpenTcpServer() does not set TCL_READABLE or
* TCL_WRITABLE so this should never be called for a server socket.
*/
if ((flags & TCL_CLOSE_READ) && (shutdown(statePtr->sockets->fd, SD_RECEIVE) == SOCKET_ERROR)) {
TclWinConvertError((DWORD) WSAGetLastError());
readError = Tcl_GetErrno();
}
if ((flags & TCL_CLOSE_WRITE) && (shutdown(statePtr->sockets->fd, SD_SEND) == SOCKET_ERROR)) {
TclWinConvertError((DWORD) WSAGetLastError());
writeError = Tcl_GetErrno();
}
return (readError != 0) ? readError : writeError;
}
/*
*----------------------------------------------------------------------
*
* TcpSetOptionProc --
*
|
| ︙ | ︙ | |||
1188 1189 1190 1191 1192 1193 1194 |
*/
static int
TcpSetOptionProc(
ClientData instanceData, /* Socket state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Name of the option to set. */
| | > > | 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 |
*/
static int
TcpSetOptionProc(
ClientData instanceData, /* Socket state. */
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Name of the option to set. */
TCL_UNUSED(const char *) /*value*/) /* New value for option. */
{
#ifdef TCL_FEATURE_KEEPALIVE_NAGLE
TcpState *statePtr = instanceData;
SOCKET sock;
#else
(void)instanceData;
#endif /*TCL_FEATURE_KEEPALIVE_NAGLE*/
/*
* Check that WinSock is initialized; do not call it if not, to prevent
* system crashes. This can happen at exit time if the exit handler for
* WinSock ran before other exit handlers that want to use sockets.
*/
|
| ︙ | ︙ | |||
1296 1297 1298 1299 1300 1301 1302 |
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Name of the option to retrieve the value
* for, or NULL to get all options and their
* values. */
Tcl_DString *dsPtr) /* Where to store the computed value;
* initialized by caller. */
{
| | | 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 |
Tcl_Interp *interp, /* For error reporting - can be NULL. */
const char *optionName, /* Name of the option to retrieve the value
* for, or NULL to get all options and their
* values. */
Tcl_DString *dsPtr) /* Where to store the computed value;
* initialized by caller. */
{
TcpState *statePtr = (TcpState *)instanceData;
char host[NI_MAXHOST], port[NI_MAXSERV];
SOCKET sock;
size_t len = 0;
int reverseDNS = 0;
#define SUPPRESS_RDNS_VAR "::tcl::unsupported::noReverseDNS"
/*
|
| ︙ | ︙ | |||
1615 1616 1617 1618 1619 1620 1621 |
static void
TcpWatchProc(
ClientData instanceData, /* The socket state. */
int mask) /* Events of interest; an OR-ed combination of
* TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
| | | 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 |
static void
TcpWatchProc(
ClientData instanceData, /* The socket state. */
int mask) /* Events of interest; an OR-ed combination of
* TCL_READABLE, TCL_WRITABLE and
* TCL_EXCEPTION. */
{
TcpState *statePtr = (TcpState *)instanceData;
/*
* Update the watch events mask. Only if the socket is not a server
* socket. [Bug 557878]
*/
if (!statePtr->acceptProc) {
|
| ︙ | ︙ | |||
1662 1663 1664 1665 1666 1667 1668 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < | | | 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
TcpGetHandleProc(
ClientData instanceData, /* The socket state. */
TCL_UNUSED(int) /*direction*/,
ClientData *handlePtr) /* Where to store the handle. */
{
TcpState *statePtr = (TcpState *)instanceData;
*handlePtr = INT2PTR(statePtr->sockets->fd);
return TCL_OK;
}
|
| ︙ | ︙ | |||
1726 1727 1728 1729 1730 1731 1732 |
int async_connect = GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
/* We are started with async connect and the
* connect notification was not yet
* received. */
int async_callback = GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING);
/* We were called by the event procedure and
* continue our loop. */
| | | 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 |
int async_connect = GOT_BITS(statePtr->flags, TCP_ASYNC_CONNECT);
/* We are started with async connect and the
* connect notification was not yet
* received. */
int async_callback = GOT_BITS(statePtr->flags, TCP_ASYNC_PENDING);
/* We were called by the event procedure and
* continue our loop. */
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (async_callback) {
goto reenter;
}
for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL;
statePtr->addr = statePtr->addr->ai_next) {
|
| ︙ | ︙ | |||
2145 2146 2147 2148 2149 2150 2151 |
char channelName[SOCK_CHAN_LENGTH];
ThreadSpecificData *tsdPtr;
if (TclpHasSockets(NULL) != TCL_OK) {
return NULL;
}
| | | 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 |
char channelName[SOCK_CHAN_LENGTH];
ThreadSpecificData *tsdPtr;
if (TclpHasSockets(NULL) != TCL_OK) {
return NULL;
}
tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
/*
* Set kernel space buffering and non-blocking.
*/
TclSockMinimumBuffers(sock, TCP_BUFFER_SIZE);
|
| ︙ | ︙ | |||
2337 2338 2339 2340 2341 2342 2343 |
error:
if (addrlist != NULL) {
freeaddrinfo(addrlist);
}
if (statePtr != NULL) {
| | | 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 |
error:
if (addrlist != NULL) {
freeaddrinfo(addrlist);
}
if (statePtr != NULL) {
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
statePtr->acceptProc = acceptProc;
statePtr->acceptProcData = acceptProcData;
sprintf(channelName, SOCK_TEMPLATE, statePtr);
statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
statePtr, 0);
/*
|
| ︙ | ︙ | |||
2393 2394 2395 2396 2397 2398 2399 | * Side effects: * Creates a new connection socket. Calls the registered callback for the * connection acceptance mechanism. * *---------------------------------------------------------------------- */ | < | | 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 |
* Side effects:
* Creates a new connection socket. Calls the registered callback for the
* connection acceptance mechanism.
*
*----------------------------------------------------------------------
*/
static void
TcpAccept(
TcpFdList *fds, /* Server socket that accepted newSocket. */
SOCKET newSocket, /* Newly accepted socket. */
address addr) /* Address of new socket. */
{
TcpState *newInfoPtr;
TcpState *statePtr = fds->statePtr;
int len = sizeof(addr);
char channelName[SOCK_CHAN_LENGTH];
char host[NI_MAXHOST], port[NI_MAXSERV];
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
/*
* Win-NT has a misfeature that sockets are inherited in child processes
* by default. Turn off the inherit bit.
*/
SetHandleInformation((HANDLE) newSocket, HANDLE_FLAG_INHERIT, 0);
|
| ︙ | ︙ | |||
2476 2477 2478 2479 2480 2481 2482 |
*----------------------------------------------------------------------
*/
static void
InitSockets(void)
{
DWORD id;
| | | 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 |
*----------------------------------------------------------------------
*/
static void
InitSockets(void)
{
DWORD id;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
if (!initialized) {
initialized = 1;
TclCreateLateExitHandler(SocketExitHandler, NULL);
/*
* Create the async notification window with a new class. We must
|
| ︙ | ︙ | |||
2500 2501 2502 2503 2504 2505 2506 | windowClass.hbrBackground = NULL; windowClass.lpszMenuName = NULL; windowClass.lpszClassName = className; windowClass.lpfnWndProc = SocketProc; windowClass.hIcon = NULL; windowClass.hCursor = NULL; | | | 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 |
windowClass.hbrBackground = NULL;
windowClass.lpszMenuName = NULL;
windowClass.lpszClassName = className;
windowClass.lpfnWndProc = SocketProc;
windowClass.hIcon = NULL;
windowClass.hCursor = NULL;
if (!RegisterClassW(&windowClass)) {
TclWinConvertError(GetLastError());
goto initFailure;
}
}
/*
* Check for per-thread initialization.
|
| ︙ | ︙ | |||
2525 2526 2527 2528 2529 2530 2531 |
*/
tsdPtr = TCL_TSD_INIT(&dataKey);
tsdPtr->pendingTcpState = NULL;
tsdPtr->socketList = NULL;
tsdPtr->hwnd = NULL;
tsdPtr->threadId = Tcl_GetCurrentThread();
| | | | 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 |
*/
tsdPtr = TCL_TSD_INIT(&dataKey);
tsdPtr->pendingTcpState = NULL;
tsdPtr->socketList = NULL;
tsdPtr->hwnd = NULL;
tsdPtr->threadId = Tcl_GetCurrentThread();
tsdPtr->readyEvent = CreateEventW(NULL, FALSE, FALSE, NULL);
if (tsdPtr->readyEvent == NULL) {
goto initFailure;
}
tsdPtr->socketListLock = CreateEventW(NULL, FALSE, TRUE, NULL);
if (tsdPtr->socketListLock == NULL) {
goto initFailure;
}
tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread, tsdPtr, 0,
&id);
if (tsdPtr->socketThread == NULL) {
goto initFailure;
|
| ︙ | ︙ | |||
2582 2583 2584 2585 2586 2587 2588 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < | 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
SocketsEnabled(void)
{
int enabled;
Tcl_MutexLock(&socketMutex);
enabled = (initialized == 1);
|
| ︙ | ︙ | |||
2612 2613 2614 2615 2616 2617 2618 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < | | | 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 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
SocketExitHandler(
TCL_UNUSED(ClientData))
{
Tcl_MutexLock(&socketMutex);
/*
* Make sure the socket event handling window is cleaned-up for, at
* most, this thread.
*/
TclpFinalizeSockets();
UnregisterClassW(className, TclWinGetTclInstance());
initialized = 0;
Tcl_MutexUnlock(&socketMutex);
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
2649 2650 2651 2652 2653 2654 2655 | * Adjusts the block time if needed. * *---------------------------------------------------------------------- */ void SocketSetupProc( | | | 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 |
* Adjusts the block time if needed.
*
*----------------------------------------------------------------------
*/
void
SocketSetupProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
TcpState *statePtr;
Tcl_Time blockTime = { 0, 0 };
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!GOT_BITS(flags, TCL_FILE_EVENTS)) {
|
| ︙ | ︙ | |||
2694 2695 2696 2697 2698 2699 2700 | * May queue an event. * *---------------------------------------------------------------------- */ static void SocketCheckProc( | | | 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 |
* May queue an event.
*
*----------------------------------------------------------------------
*/
static void
SocketCheckProc(
TCL_UNUSED(ClientData),
int flags) /* Event flags as passed to Tcl_DoOneEvent. */
{
TcpState *statePtr;
SocketEvent *evPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!GOT_BITS(flags, TCL_FILE_EVENTS)) {
|
| ︙ | ︙ | |||
2718 2719 2720 2721 2722 2723 2724 |
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
for (statePtr = tsdPtr->socketList; statePtr != NULL;
statePtr = statePtr->nextPtr) {
if (GOT_BITS(statePtr->readyEvents,
statePtr->watchEvents | FD_CONNECT | FD_ACCEPT)
&& !GOT_BITS(statePtr->flags, SOCKET_PENDING)) {
SET_BITS(statePtr->flags, SOCKET_PENDING);
| | | 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 |
WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
for (statePtr = tsdPtr->socketList; statePtr != NULL;
statePtr = statePtr->nextPtr) {
if (GOT_BITS(statePtr->readyEvents,
statePtr->watchEvents | FD_CONNECT | FD_ACCEPT)
&& !GOT_BITS(statePtr->flags, SOCKET_PENDING)) {
SET_BITS(statePtr->flags, SOCKET_PENDING);
evPtr = (SocketEvent *)ckalloc(sizeof(SocketEvent));
evPtr->header.proc = SocketEventProc;
evPtr->socket = statePtr->sockets->fd;
Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
}
}
SetEvent(tsdPtr->socketListLock);
}
|
| ︙ | ︙ | |||
2993 2994 2995 2996 2997 2998 2999 |
TcpFdList *fds = statePtr->sockets;
if (fds == NULL) {
/*
* Add the first FD.
*/
| | | | 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 |
TcpFdList *fds = statePtr->sockets;
if (fds == NULL) {
/*
* Add the first FD.
*/
statePtr->sockets = (TcpFdList *)ckalloc(sizeof(TcpFdList));
fds = statePtr->sockets;
} else {
/*
* Find end of list and append FD.
*/
while (fds->next != NULL) {
fds = fds->next;
}
fds->next = (TcpFdList *)ckalloc(sizeof(TcpFdList));
fds = fds->next;
}
/*
* Populate new FD.
*/
|
| ︙ | ︙ | |||
3037 3038 3039 3040 3041 3042 3043 |
*
*----------------------------------------------------------------------
*/
static TcpState *
NewSocketInfo(SOCKET socket)
{
| | | 3028 3029 3030 3031 3032 3033 3034 3035 3036 3037 3038 3039 3040 3041 3042 |
*
*----------------------------------------------------------------------
*/
static TcpState *
NewSocketInfo(SOCKET socket)
{
TcpState *statePtr = (TcpState *)ckalloc(sizeof(TcpState));
memset(statePtr, 0, sizeof(TcpState));
/*
* TIP #218. Removed the code inserting the new structure into the global
* list. This is now handled in the thread action callbacks, and only
* there.
|
| ︙ | ︙ | |||
3080 3081 3082 3083 3084 3085 3086 |
int events, /* Events to look for. May be one of
* FD_READ or FD_WRITE.
*/
int *errorCodePtr) /* Where to store errors? */
{
int result = 1;
int oldMode;
| | | 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 |
int events, /* Events to look for. May be one of
* FD_READ or FD_WRITE.
*/
int *errorCodePtr) /* Where to store errors? */
{
int result = 1;
int oldMode;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
/*
* Be sure to disable event servicing so we are truly modal.
*/
oldMode = Tcl_SetServiceMode(TCL_SERVICE_NONE);
|
| ︙ | ︙ | |||
3166 3167 3168 3169 3170 3171 3172 |
*/
static DWORD WINAPI
SocketThread(
LPVOID arg)
{
MSG msg;
| | | | | | | 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 |
*/
static DWORD WINAPI
SocketThread(
LPVOID arg)
{
MSG msg;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)arg;
/*
* Create a dummy window receiving socket events.
*/
tsdPtr->hwnd = CreateWindowW(className, className, WS_TILED, 0, 0, 0, 0,
NULL, NULL, windowClass.hInstance, arg);
/*
* Signalize thread creator that we are done creating the window.
*/
SetEvent(tsdPtr->readyEvent);
/*
* If unable to create the window, exit this thread immediately.
*/
if (tsdPtr->hwnd == NULL) {
return 1;
}
/*
* Process all messages on the socket window until WM_QUIT. This threads
* exits only when instructed to do so by the call to
* PostMessageW(SOCKET_TERMINATE) in TclpFinalizeSockets().
*/
while (GetMessageW(&msg, NULL, 0, 0) > 0) {
DispatchMessageW(&msg);
}
/*
* This releases waiters on thread exit in TclpFinalizeSockets()
*/
SetEvent(tsdPtr->readyEvent);
|
| ︙ | ︙ | |||
3241 3242 3243 3244 3245 3246 3247 |
int event, error;
SOCKET socket;
TcpState *statePtr;
int info_found = 0;
TcpFdList *fds = NULL;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
#ifdef _WIN64
| | | | | | | 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 |
int event, error;
SOCKET socket;
TcpState *statePtr;
int info_found = 0;
TcpFdList *fds = NULL;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
#ifdef _WIN64
GetWindowLongPtrW(hwnd, GWLP_USERDATA);
#else
GetWindowLongW(hwnd, GWL_USERDATA);
#endif
switch (message) {
default:
return DefWindowProcW(hwnd, message, wParam, lParam);
break;
case WM_CREATE:
/*
* Store the initial tsdPtr, it's from a different thread, so it's not
* directly accessible, but needed.
*/
#ifdef _WIN64
SetWindowLongPtrW(hwnd, GWLP_USERDATA,
(LONG_PTR) ((LPCREATESTRUCT)lParam)->lpCreateParams);
#else
SetWindowLongW(hwnd, GWL_USERDATA,
(LONG) ((LPCREATESTRUCT)lParam)->lpCreateParams);
#endif
break;
case WM_DESTROY:
PostQuitMessage(0);
break;
|
| ︙ | ︙ | |||
3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 |
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* TcpThreadActionProc --
*
* Insert or remove any thread local refs to this channel.
*
* Results:
* None.
*
* Side effects:
* Changes thread local list of valid channels.
*
*----------------------------------------------------------------------
*/
static void
TcpThreadActionProc(
ClientData instanceData,
int action)
{
ThreadSpecificData *tsdPtr;
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 3468 3469 3470 3471 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 |
}
return 0;
}
/*
*----------------------------------------------------------------------
*
* TclWinGetSockOpt, et al. --
*
* Those functions are historically exported by the stubs table and
* just use the original system calls now.
*
* Warning:
* Those functions are depreciated and will be removed with TCL 9.0.
*
* Results:
* As defined for each function.
*
* Side effects:
* As defined for each function.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
#undef TclWinGetSockOpt
int
TclWinGetSockOpt(
SOCKET s,
int level,
int optname,
char *optval,
int *optlen)
{
return getsockopt(s, level, optname, optval, optlen);
}
#undef TclWinSetSockOpt
int
TclWinSetSockOpt(
SOCKET s,
int level,
int optname,
const char *optval,
int optlen)
{
return setsockopt(s, level, optname, optval, optlen);
}
#undef TclpInetNtoa
char *
TclpInetNtoa(
struct in_addr addr)
{
return inet_ntoa(addr);
}
#undef TclWinGetServByName
struct servent *
TclWinGetServByName(
const char *name,
const char *proto)
{
return getservbyname(name, proto);
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* TcpThreadActionProc --
*
* Insert or remove any thread local refs to this channel.
*
* Results:
* None.
*
* Side effects:
* Changes thread local list of valid channels.
*
*----------------------------------------------------------------------
*/
static void
TcpThreadActionProc(
ClientData instanceData,
int action)
{
ThreadSpecificData *tsdPtr;
TcpState *statePtr = (TcpState *)instanceData;
int notifyCmd;
if (action == TCL_CHANNEL_THREAD_INSERT) {
/*
* Ensure that socket subsystem is initialized in this thread, or else
* sockets will not work.
*/
|
| ︙ | ︙ |
Changes to win/tclWinTest.c.
| ︙ | ︙ | |||
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, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" /* * For TestplatformChmod on Windows */ #ifdef _WIN32 #include <aclapi.h> #endif /* * MinGW 3.4.2 does not define this. */ #ifndef INHERITED_ACE #define INHERITED_ACE (0x10) #endif /* * Forward declarations of functions defined later in this file: */ | > > > > > | < | < < | < | | | < | 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 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif #include "tclInt.h" #ifdef TCL_WITH_EXTERNAL_TOMMATH # include "tommath.h" #else # include "tclTomMath.h" #endif /* * For TestplatformChmod on Windows */ #ifdef _WIN32 #include <aclapi.h> #endif /* * MinGW 3.4.2 does not define this. */ #ifndef INHERITED_ACE #define INHERITED_ACE (0x10) #endif /* * Forward declarations of functions defined later in this file: */ static Tcl_ObjCmdProc TesteventloopCmd; static Tcl_ObjCmdProc TestvolumetypeCmd; static Tcl_ObjCmdProc TestwinclockCmd; static Tcl_ObjCmdProc TestwinsleepCmd; static Tcl_ObjCmdProc TestSizeCmd; static Tcl_ObjCmdProc TestExceptionCmd; static int TestplatformChmod(const char *nativePath, int pmode); static Tcl_ObjCmdProc TestchmodCmd; /* *---------------------------------------------------------------------- * * TclplatformtestInit -- * * Defines commands that test platform specific functionality for Windows |
| ︙ | ︙ | |||
74 75 76 77 78 79 80 81 82 83 84 85 86 87 |
Tcl_CreateObjCommand(interp, "testchmod", TestchmodCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testeventloop", TesteventloopCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testvolumetype", TestvolumetypeCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testwinclock", TestwinclockCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testwinsleep", TestwinsleepCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testexcept", TestExceptionCmd, NULL, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TesteventloopCmd --
| > | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 |
Tcl_CreateObjCommand(interp, "testchmod", TestchmodCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testeventloop", TesteventloopCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testvolumetype", TestvolumetypeCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testwinclock", TestwinclockCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testwinsleep", TestwinsleepCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testexcept", TestExceptionCmd, NULL, NULL);
Tcl_CreateObjCommand(interp, "testsize", TestSizeCmd, NULL, NULL);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TesteventloopCmd --
|
| ︙ | ︙ | |||
97 98 99 100 101 102 103 | * None. * *---------------------------------------------------------------------- */ static int TesteventloopCmd( | | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TesteventloopCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static int *framePtr = NULL;/* Pointer to integer on stack frame of
* innermost invocation of the "wait"
* subcommand. */
|
| ︙ | ︙ | |||
132 133 134 135 136 137 138 |
* that we do not explicitly call Tcl_ServiceEvent().
*/
done = 0;
while (!done) {
MSG msg;
| | | | 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 |
* that we do not explicitly call Tcl_ServiceEvent().
*/
done = 0;
while (!done) {
MSG msg;
if (!GetMessageW(&msg, NULL, 0, 0)) {
/*
* The application is exiting, so repost the quit message and
* start unwinding.
*/
PostQuitMessage((int) msg.wParam);
break;
}
TranslateMessage(&msg);
DispatchMessageW(&msg);
}
(void) Tcl_SetServiceMode(oldMode);
framePtr = oldFramePtr;
} else {
Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[1]),
"\": must be done or wait", NULL);
return TCL_ERROR;
|
| ︙ | ︙ | |||
173 174 175 176 177 178 179 | * None. * *---------------------------------------------------------------------- */ static int TestvolumetypeCmd( | | | 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestvolumetypeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
#define VOL_BUF_SIZE 32
int found;
char volType[VOL_BUF_SIZE];
|
| ︙ | ︙ | |||
239 240 241 242 243 244 245 | * None. * *---------------------------------------------------------------------- */ static int TestwinclockCmd( | | | 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 |
* None.
*
*----------------------------------------------------------------------
*/
static int
TestwinclockCmd(
TCL_UNUSED(ClientData),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
{
static const FILETIME posixEpoch = { 0xD53E8000, 0x019DB1DE };
/* The Posix epoch, expressed as a Windows
* FILETIME */
|
| ︙ | ︙ | |||
288 289 290 291 292 293 294 |
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
static int
TestwinsleepCmd(
| | > > > > > > > > > > > > > > > > > > > > > > > > > > | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 |
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
static int
TestwinsleepCmd(
TCL_UNUSED(ClientData),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const * objv) /* Parameter vector */
{
int ms;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "ms");
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) {
return TCL_ERROR;
}
Sleep((DWORD) ms);
return TCL_OK;
}
static int
TestSizeCmd(
TCL_UNUSED(ClientData),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Parameter count */
Tcl_Obj *const * objv) /* Parameter vector */
{
if (objc != 2) {
goto syntax;
}
if (strcmp(Tcl_GetString(objv[1]), "time_t") == 0) {
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(sizeof(time_t)));
return TCL_OK;
}
if (strcmp(Tcl_GetString(objv[1]), "st_mtime") == 0) {
Tcl_StatBuf *statPtr;
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(sizeof(statPtr->st_mtime)));
return TCL_OK;
}
syntax:
Tcl_WrongNumArgs(interp, 1, objv, "time_t|st_mtime");
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* TestExceptionCmd --
*
* Causes this process to end with the named exception. Used for testing
|
| ︙ | ︙ | |||
331 332 333 334 335 336 337 | * This Tcl process closes, hard... Bang! * *---------------------------------------------------------------------- */ static int TestExceptionCmd( | | | 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 |
* This Tcl process closes, hard... Bang!
*
*----------------------------------------------------------------------
*/
static int
TestExceptionCmd(
TCL_UNUSED(ClientData),
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
{
static const char *const cmds[] = {
"access_violation", "datatype_misalignment", "array_bounds",
"float_denormal", "float_divbyzero", "float_inexact",
|
| ︙ | ︙ | |||
384 385 386 387 388 389 390 |
* main() where the process will now be terminated with this exception
* code by the default handler the C run-time provides.
*/
/* SMASH! */
RaiseException(exceptions[cmd], EXCEPTION_NONCONTINUABLE, 0, NULL);
| < | 411 412 413 414 415 416 417 418 419 420 421 422 423 424 |
* main() where the process will now be terminated with this exception
* code by the default handler the C run-time provides.
*/
/* SMASH! */
RaiseException(exceptions[cmd], EXCEPTION_NONCONTINUABLE, 0, NULL);
return TCL_OK;
}
static int
TestplatformChmod(
const char *nativePath,
int pmode)
|
| ︙ | ︙ | |||
429 430 431 432 433 434 435 |
attr = GetFileAttributesA(nativePath);
/*
* nativePath not found
*/
| | | 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 |
attr = GetFileAttributesA(nativePath);
/*
* nativePath not found
*/
if (attr == 0xFFFFFFFF) {
res = -1;
goto done;
}
/*
* If nativePath is not a directory, there is no special handling.
*/
|
| ︙ | ︙ | |||
461 462 463 464 465 466 467 |
if (!GetFileSecurityA(nativePath, infoBits, NULL, 0, &secDescLen)) {
DWORD secDescLen2 = 0;
if (GetLastError() != ERROR_INSUFFICIENT_BUFFER) {
goto done;
}
| | | | 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 |
if (!GetFileSecurityA(nativePath, infoBits, NULL, 0, &secDescLen)) {
DWORD secDescLen2 = 0;
if (GetLastError() != ERROR_INSUFFICIENT_BUFFER) {
goto done;
}
secDesc = (BYTE *)ckalloc(secDescLen);
if (!GetFileSecurityA(nativePath, infoBits,
(PSECURITY_DESCRIPTOR) secDesc, secDescLen, &secDescLen2)
|| (secDescLen < secDescLen2)) {
goto done;
}
}
/*
* Get the World SID.
*/
userSid = (SID *)ckalloc(GetSidLengthRequired((UCHAR) 1));
InitializeSid(userSid, &userSidAuthority, (BYTE) 1);
*(GetSidSubAuthority(userSid, 0)) = SECURITY_WORLD_RID;
/*
* If curAclPresent == false then curAcl and curAclDefaulted not valid.
*/
|
| ︙ | ︙ | |||
499 500 501 502 503 504 505 |
/*
* Allocate memory for the new ACL.
*/
newAclSize = ACLSize.AclBytesInUse + sizeof(ACCESS_DENIED_ACE)
+ GetLengthSid(userSid) - sizeof(DWORD);
| | | 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 |
/*
* Allocate memory for the new ACL.
*/
newAclSize = ACLSize.AclBytesInUse + sizeof(ACCESS_DENIED_ACE)
+ GetLengthSid(userSid) - sizeof(DWORD);
newAcl = (PACL) ckalloc(newAclSize);
/*
* Initialize the new ACL.
*/
if (!InitializeAcl(newAcl, newAclSize, ACL_REVISION)) {
goto done;
|
| ︙ | ︙ | |||
576 577 578 579 580 581 582 |
DACL_SECURITY_INFORMATION /*| PROTECTED_DACL_SECURITY_INFORMATION*/,
NULL, NULL, newAcl, NULL) == ERROR_SUCCESS) {
res = 0;
}
done:
if (secDesc) {
| | | | | | 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 |
DACL_SECURITY_INFORMATION /*| PROTECTED_DACL_SECURITY_INFORMATION*/,
NULL, NULL, newAcl, NULL) == ERROR_SUCCESS) {
res = 0;
}
done:
if (secDesc) {
ckfree(secDesc);
}
if (newAcl) {
ckfree(newAcl);
}
if (userSid) {
ckfree(userSid);
}
if (userDomain) {
ckfree(userDomain);
}
if (res != 0) {
return res;
}
/*
|
| ︙ | ︙ | |||
620 621 622 623 624 625 626 | * Changes permissions of specified files. * *--------------------------------------------------------------------------- */ static int TestchmodCmd( | | | 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 |
* Changes permissions of specified files.
*
*---------------------------------------------------------------------------
*/
static int
TestchmodCmd(
TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Parameter count */
Tcl_Obj *const * objv) /* Parameter vector */
{
int i, mode;
if (objc < 2) {
|
| ︙ | ︙ |
Changes to win/tclWinThrd.c.
| ︙ | ︙ | |||
174 175 176 177 178 179 180 |
| _MCW_PC
#endif
);
lpOrigStartAddress = winThreadPtr->lpStartAddress;
lpOrigParameter = winThreadPtr->lpParameter;
| | | 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 |
| _MCW_PC
#endif
);
lpOrigStartAddress = winThreadPtr->lpStartAddress;
lpOrigParameter = winThreadPtr->lpParameter;
ckfree(winThreadPtr);
return lpOrigStartAddress(lpOrigParameter);
}
/*
*----------------------------------------------------------------------
*
* TclpThreadCreate --
|
| ︙ | ︙ | |||
200 201 202 203 204 205 206 |
*/
int
TclpThreadCreate(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread. */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread. */
ClientData clientData, /* The one argument to Main(). */
| | | | 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 |
*/
int
TclpThreadCreate(
Tcl_ThreadId *idPtr, /* Return, the ID of the thread. */
Tcl_ThreadCreateProc *proc, /* Main() function of the thread. */
ClientData clientData, /* The one argument to Main(). */
int stackSize, /* Size of stack for the new thread. */
int flags) /* Flags controlling behaviour of the new
* thread. */
{
WinThread *winThreadPtr; /* Per-thread startup info */
HANDLE tHandle;
winThreadPtr = (WinThread *)ckalloc(sizeof(WinThread));
winThreadPtr->lpStartAddress = (LPTHREAD_START_ROUTINE) proc;
winThreadPtr->lpParameter = clientData;
winThreadPtr->fpControl = _controlfp(0, 0);
EnterCriticalSection(&joinLock);
*idPtr = 0; /* must initialize as Tcl_Thread is a pointer and
|
| ︙ | ︙ | |||
564 565 566 567 568 569 570 |
TclpMasterLock();
/*
* Double inside master lock check to avoid a race.
*/
if (*mutexPtr == NULL) {
| | | 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 |
TclpMasterLock();
/*
* Double inside master lock check to avoid a race.
*/
if (*mutexPtr == NULL) {
csPtr = (CRITICAL_SECTION *)ckalloc(sizeof(CRITICAL_SECTION));
InitializeCriticalSection(csPtr);
*mutexPtr = (Tcl_Mutex)csPtr;
TclRememberMutex(mutexPtr);
}
TclpMasterUnlock();
}
csPtr = *((CRITICAL_SECTION **)mutexPtr);
|
| ︙ | ︙ | |||
625 626 627 628 629 630 631 |
TclpFinalizeMutex(
Tcl_Mutex *mutexPtr)
{
CRITICAL_SECTION *csPtr = *(CRITICAL_SECTION **)mutexPtr;
if (csPtr != NULL) {
DeleteCriticalSection(csPtr);
| | | 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 |
TclpFinalizeMutex(
Tcl_Mutex *mutexPtr)
{
CRITICAL_SECTION *csPtr = *(CRITICAL_SECTION **)mutexPtr;
if (csPtr != NULL) {
DeleteCriticalSection(csPtr);
ckfree(csPtr);
*mutexPtr = NULL;
}
}
/*
*----------------------------------------------------------------------
*
|
| ︙ | ︙ | |||
678 679 680 681 682 683 684 |
TclpMasterLock();
/*
* Create the per-thread event and queue pointers.
*/
if (tsdPtr->flags == WIN_THREAD_UNINIT) {
| | | 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 |
TclpMasterLock();
/*
* Create the per-thread event and queue pointers.
*/
if (tsdPtr->flags == WIN_THREAD_UNINIT) {
tsdPtr->condEvent = CreateEventW(NULL, TRUE /* manual reset */,
FALSE /* non signaled */, NULL);
tsdPtr->nextPtr = NULL;
tsdPtr->prevPtr = NULL;
tsdPtr->flags = WIN_THREAD_RUNNING;
doExit = 1;
}
TclpMasterUnlock();
|
| ︙ | ︙ | |||
707 708 709 710 711 712 713 |
TclpMasterLock();
/*
* Initialize the per-condition queue pointers and Mutex.
*/
if (*condPtr == NULL) {
| | | 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 |
TclpMasterLock();
/*
* Initialize the per-condition queue pointers and Mutex.
*/
if (*condPtr == NULL) {
winCondPtr = (WinCondition *)ckalloc(sizeof(WinCondition));
InitializeCriticalSection(&winCondPtr->condLock);
winCondPtr->firstPtr = NULL;
winCondPtr->lastPtr = NULL;
*condPtr = (Tcl_Condition) winCondPtr;
TclRememberCondition(condPtr);
}
TclpMasterUnlock();
|
| ︙ | ︙ | |||
918 919 920 921 922 923 924 |
* The per-thread condition waiting event is reclaimed earlier in a
* per-thread exit handler, which is called before thread local storage is
* reclaimed.
*/
if (winCondPtr != NULL) {
DeleteCriticalSection(&winCondPtr->condLock);
| | | | 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 |
* The per-thread condition waiting event is reclaimed earlier in a
* per-thread exit handler, which is called before thread local storage is
* reclaimed.
*/
if (winCondPtr != NULL) {
DeleteCriticalSection(&winCondPtr->condLock);
ckfree(winCondPtr);
*condPtr = NULL;
}
}
/*
* Additions by AOL for specialized thread memory allocator.
*/
#ifdef USE_THREAD_ALLOC
Tcl_Mutex *
TclpNewAllocMutex(void)
{
allocMutex *lockPtr;
lockPtr = (allocMutex *)malloc(sizeof(allocMutex));
if (lockPtr == NULL) {
Tcl_Panic("could not allocate lock");
}
lockPtr->tlock = (Tcl_Mutex) &lockPtr->wlock;
InitializeCriticalSection(&lockPtr->wlock);
return &lockPtr->tlock;
}
|
| ︙ | ︙ | |||
1033 1034 1035 1036 1037 1038 1039 |
void *
TclpThreadCreateKey(void)
{
DWORD *key;
| | | | | | 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 |
void *
TclpThreadCreateKey(void)
{
DWORD *key;
key = (DWORD *)TclpSysAlloc(sizeof *key, 0);
if (key == NULL) {
Tcl_Panic("unable to allocate thread key!");
}
*key = TlsAlloc();
if (*key == TLS_OUT_OF_INDEXES) {
Tcl_Panic("unable to allocate thread-local storage");
}
return key;
}
void
TclpThreadDeleteKey(
void *keyPtr)
{
DWORD *key = (DWORD *)keyPtr;
if (!TlsFree(*key)) {
Tcl_Panic("unable to delete key");
}
TclpSysFree(keyPtr);
}
void
TclpThreadSetMasterTSD(
void *tsdKeyPtr,
void *ptr)
{
DWORD *key = (DWORD *)tsdKeyPtr;
if (!TlsSetValue(*key, ptr)) {
Tcl_Panic("unable to set master TSD value");
}
}
void *
TclpThreadGetMasterTSD(
void *tsdKeyPtr)
{
DWORD *key = (DWORD *)tsdKeyPtr;
return TlsGetValue(*key);
}
#endif /* TCL_THREADS */
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
Changes to win/tclWinTime.c.
| ︙ | ︙ | |||
8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 |
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
/*
* Number of samples over which to estimate the performance counter.
*/
#define SAMPLES 64
/*
* Data for managing high-resolution timers.
*/
typedef struct {
CRITICAL_SECTION cs; /* Mutex guarding this structure. */
int initialized; /* Flag == 1 if this structure is
| > > > > > > > > > > > > > > > > > > > > > > > > > | 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 |
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclInt.h"
#define SECSPERDAY (60L * 60L * 24L)
#define SECSPERYEAR (SECSPERDAY * 365L)
#define SECSPER4YEAR (SECSPERYEAR * 4L + SECSPERDAY)
/*
* Number of samples over which to estimate the performance counter.
*/
#define SAMPLES 64
/*
* The following arrays contain the day of year for the last day of each
* month, where index 1 is January.
*/
#ifndef TCL_NO_DEPRECATED
static const int normalDays[] = {
-1, 30, 58, 89, 119, 150, 180, 211, 242, 272, 303, 333, 364
};
static const int leapDays[] = {
-1, 30, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365
};
typedef struct {
char tzName[64]; /* Time zone name */
struct tm tm; /* time information */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#endif /* TCL_NO_DEPRECATED */
/*
* Data for managing high-resolution timers.
*/
typedef struct {
CRITICAL_SECTION cs; /* Mutex guarding this structure. */
int initialized; /* Flag == 1 if this structure is
|
| ︙ | ︙ | |||
69 70 71 72 73 74 75 |
{ NULL, 0, 0, NULL, NULL, 0 },
0,
0,
1,
(HANDLE) NULL,
(HANDLE) NULL,
(HANDLE) NULL,
| | | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 |
{ NULL, 0, 0, NULL, NULL, 0 },
0,
0,
1,
(HANDLE) NULL,
(HANDLE) NULL,
(HANDLE) NULL,
#if defined(HAVE_CAST_TO_UNION) && !defined(__cplusplus)
(LARGE_INTEGER) (Tcl_WideInt) 0,
(ULARGE_INTEGER) (DWORDLONG) 0,
(LARGE_INTEGER) (Tcl_WideInt) 0,
(LARGE_INTEGER) (Tcl_WideInt) 0,
(LARGE_INTEGER) (Tcl_WideInt) 0,
#else
{0, 0},
|
| ︙ | ︙ | |||
95 96 97 98 99 100 101 |
* Scale to convert wide click values from the TclpGetWideClicks native
* resolution to microsecond resolution and back.
*/
static struct {
int initialized; /* 1 if initialized, 0 otherwise */
int perfCounter; /* 1 if performance counter usable for wide clicks */
double microsecsScale; /* Denominator scale between clock / microsecs */
| | > > > | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 |
* Scale to convert wide click values from the TclpGetWideClicks native
* resolution to microsecond resolution and back.
*/
static struct {
int initialized; /* 1 if initialized, 0 otherwise */
int perfCounter; /* 1 if performance counter usable for wide clicks */
double microsecsScale; /* Denominator scale between clock / microsecs */
} wideClick = {0, 0, 0.0};
/*
* Declarations for functions defined later in this file.
*/
#ifndef TCL_NO_DEPRECATED
static struct tm * ComputeGMT(const time_t *tp);
#endif /* TCL_NO_DEPRECATED */
static void StopCalibration(ClientData clientData);
static DWORD WINAPI CalibrationThread(LPVOID arg);
static void UpdateTimeEachSecond(void);
static void ResetCounterSamples(Tcl_WideUInt fileTime,
Tcl_WideInt perfCounter, Tcl_WideInt perfFreq);
static Tcl_WideInt AccumulateSample(Tcl_WideInt perfCounter,
Tcl_WideUInt fileTime);
|
| ︙ | ︙ | |||
140 141 142 143 144 145 146 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | | | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 |
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
unsigned long
TclpGetSeconds(void)
{
Tcl_WideInt usecSincePosixEpoch;
/* Try to use high resolution timer */
if ( tclGetTimeProcPtr == NativeGetTime
&& (usecSincePosixEpoch = NativeGetMicroseconds())
|
| ︙ | ︙ | |||
166 167 168 169 170 171 172 | *---------------------------------------------------------------------- * * TclpGetClicks -- * * This procedure returns a value that represents the highest resolution * clock available on the system. There are no guarantees on what the * resolution will be. In Tcl we will call this value a "click". The | | | | | | 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 |
*----------------------------------------------------------------------
*
* TclpGetClicks --
*
* This procedure returns a value that represents the highest resolution
* clock available on the system. There are no guarantees on what the
* resolution will be. In Tcl we will call this value a "click". The
* start time is also system dependent.
*
* Results:
* Number of clicks from some start time.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
unsigned long
TclpGetClicks(void)
{
Tcl_WideInt usecSincePosixEpoch;
/* Try to use high resolution timer */
if ( tclGetTimeProcPtr == NativeGetTime
&& (usecSincePosixEpoch = NativeGetMicroseconds())
) {
return (unsigned long)usecSincePosixEpoch;
} else {
/*
* Use the Tcl_GetTime abstraction to get the time in microseconds, as
* nearly as we can, and return it.
*/
Tcl_Time now; /* Current Tcl time */
tclGetTimeProcPtr(&now, tclTimeClientData); /* Tcl_GetTime inlined */
return (unsigned long)(now.sec * 1000000) + now.usec;
}
}
/*
*----------------------------------------------------------------------
*
* TclpGetWideClicks --
|
| ︙ | ︙ | |||
381 382 383 384 385 386 387 | * See above. * *---------------------------------------------------------------------- */ static void NativeScaleTime( | | | | 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 |
* See above.
*
*----------------------------------------------------------------------
*/
static void
NativeScaleTime(
TCL_UNUSED(Tcl_Time *),
TCL_UNUSED(ClientData))
{
/*
* Native scale is 1:1. Nothing is done.
*/
}
/*
|
| ︙ | ︙ | |||
491 492 493 494 495 496 497 | */ SYSTEM_INFO systemInfo; int regs[4]; GetSystemInfo(&systemInfo); if (TclWinCPUID(0, regs) == TCL_OK | | | | | 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 |
*/
SYSTEM_INFO systemInfo;
int regs[4];
GetSystemInfo(&systemInfo);
if (TclWinCPUID(0, regs) == TCL_OK
&& regs[1] == 0x756E6547 /* "Genu" */
&& regs[3] == 0x49656E69 /* "ineI" */
&& regs[2] == 0x6C65746E /* "ntel" */
&& TclWinCPUID(1, regs) == TCL_OK
&& ((regs[0]&0x00000F00) == 0x00000F00 /* Pentium 4 */
|| ((regs[0] & 0x00F00000) /* Extended family */
&& (regs[3] & 0x10000000))) /* Hyperthread */
&& (((regs[1]&0x00FF0000) >> 16)/* CPU count */
== (int)systemInfo.dwNumberOfProcessors)) {
timeInfo.perfCounterAvailable = TRUE;
|
| ︙ | ︙ | |||
516 517 518 519 520 521 522 |
* calibrate it.
*/
if (timeInfo.perfCounterAvailable) {
DWORD id;
InitializeCriticalSection(&timeInfo.cs);
| | | | 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 |
* calibrate it.
*/
if (timeInfo.perfCounterAvailable) {
DWORD id;
InitializeCriticalSection(&timeInfo.cs);
timeInfo.readyEvent = CreateEventW(NULL, FALSE, FALSE, NULL);
timeInfo.exitEvent = CreateEventW(NULL, FALSE, FALSE, NULL);
timeInfo.calibrationThread = CreateThread(NULL, 256,
CalibrationThread, (LPVOID) NULL, 0, &id);
SetThreadPriority(timeInfo.calibrationThread,
THREAD_PRIORITY_HIGHEST);
/*
* Wait for the thread just launched to start running, and
|
| ︙ | ︙ | |||
617 618 619 620 621 622 623 |
*
*----------------------------------------------------------------------
*/
static void
NativeGetTime(
Tcl_Time *timePtr,
| | | 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 |
*
*----------------------------------------------------------------------
*/
static void
NativeGetTime(
Tcl_Time *timePtr,
TCL_UNUSED(ClientData))
{
Tcl_WideInt usecSincePosixEpoch;
/*
* Try to use high resolution timer.
*/
if ( (usecSincePosixEpoch = NativeGetMicroseconds()) ) {
|
| ︙ | ︙ | |||
662 663 664 665 666 667 668 | *---------------------------------------------------------------------- */ void TclWinResetTimerResolution(void); static void StopCalibration( | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 |
*----------------------------------------------------------------------
*/
void TclWinResetTimerResolution(void);
static void
StopCalibration(
TCL_UNUSED(ClientData))
{
SetEvent(timeInfo.exitEvent);
/*
* If Tcl_Finalize was called from DllMain, the calibration thread is in a
* paused state so we need to timeout and continue.
*/
WaitForSingleObject(timeInfo.calibrationThread, 100);
CloseHandle(timeInfo.exitEvent);
CloseHandle(timeInfo.calibrationThread);
}
/*
*----------------------------------------------------------------------
*
* TclpGetDate --
*
* This function converts between seconds and struct tm. If useGMT is
* true, then the returned date will be in Greenwich Mean Time (GMT).
* Otherwise, it will be in the local time zone.
*
* Results:
* Returns a static tm structure.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
struct tm *
TclpGetDate(
const time_t *t,
int useGMT)
{
struct tm *tmPtr;
time_t time;
#if defined(_WIN64) || (defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400))
# define t2 *t /* no need to cripple time to 32-bit */
#else
time_t t2 = *(__time32_t *)t;
#endif
if (!useGMT) {
#if defined(_MSC_VER) && (_MSC_VER >= 1900)
# undef timezone /* prevent conflict with timezone() function */
long timezone = 0;
#endif
tzset();
/*
* If we are in the valid range, let the C run-time library handle it.
* Otherwise we need to fake it. Note that this algorithm ignores
* daylight savings time before the epoch.
*/
/*
* Hm, Borland's localtime manages to return NULL under certain
* circumstances (e.g. wintime.test, test 1.2). Nobody tests for this,
* since 'localtime' isn't supposed to do this, possibly leading to
* crashes.
*
* Patch: We only call this function if we are at least one day into
* the epoch, else we handle it ourselves (like we do for times < 0).
* H. Giese, June 2003
*/
#ifdef __BORLANDC__
#define LOCALTIME_VALIDITY_BOUNDARY SECSPERDAY
#else
#define LOCALTIME_VALIDITY_BOUNDARY 0
#endif
if (t2 >= LOCALTIME_VALIDITY_BOUNDARY) {
return TclpLocaltime(&t2);
}
#if defined(_MSC_VER) && (_MSC_VER >= 1900)
_get_timezone(&timezone);
#endif
time = t2 - timezone;
/*
* If we aren't near to overflowing the long, just add the bias and
* use the normal calculation. Otherwise we will need to adjust the
* result at the end.
*/
if (t2 < (LONG_MAX - 2*SECSPERDAY) && t2 > (LONG_MIN + 2*SECSPERDAY)) {
tmPtr = ComputeGMT(&time);
} else {
tmPtr = ComputeGMT(&t2);
tzset();
/*
* Add the bias directly to the tm structure to avoid overflow.
* Propagate seconds overflow into minutes, hours and days.
*/
time = tmPtr->tm_sec - timezone;
tmPtr->tm_sec = (int)(time % 60);
if (tmPtr->tm_sec < 0) {
tmPtr->tm_sec += 60;
time -= 60;
}
time = tmPtr->tm_min + time/60;
tmPtr->tm_min = (int)(time % 60);
if (tmPtr->tm_min < 0) {
tmPtr->tm_min += 60;
time -= 60;
}
time = tmPtr->tm_hour + time/60;
tmPtr->tm_hour = (int)(time % 24);
if (tmPtr->tm_hour < 0) {
tmPtr->tm_hour += 24;
time -= 24;
}
time /= 24;
tmPtr->tm_mday += (int)time;
tmPtr->tm_yday += (int)time;
tmPtr->tm_wday = (tmPtr->tm_wday + (int)time) % 7;
}
} else {
tmPtr = ComputeGMT(&t2);
}
return tmPtr;
}
/*
*----------------------------------------------------------------------
*
* ComputeGMT --
*
* This function computes GMT given the number of seconds since the epoch
* (midnight Jan 1 1970).
*
* Results:
* Returns a (per thread) statically allocated struct tm.
*
* Side effects:
* Updates the values of the static struct tm.
*
*----------------------------------------------------------------------
*/
static struct tm *
ComputeGMT(
const time_t *tp)
{
struct tm *tmPtr;
long tmp, rem;
int isLeap;
const int *days;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
tmPtr = &tsdPtr->tm;
/*
* Compute the 4 year span containing the specified time.
*/
tmp = (long)(*tp / SECSPER4YEAR);
rem = (long)(*tp % SECSPER4YEAR);
/*
* Correct for weird mod semantics so the remainder is always positive.
*/
if (rem < 0) {
tmp--;
rem += SECSPER4YEAR;
}
/*
* Compute the year after 1900 by taking the 4 year span and adjusting for
* the remainder. This works because 2000 is a leap year, and 1900/2100
* are out of the range.
*/
tmp = (tmp * 4) + 70;
isLeap = 0;
if (rem >= SECSPERYEAR) { /* 1971, etc. */
tmp++;
rem -= SECSPERYEAR;
if (rem >= SECSPERYEAR) { /* 1972, etc. */
tmp++;
rem -= SECSPERYEAR;
if (rem >= SECSPERYEAR + SECSPERDAY) { /* 1973, etc. */
tmp++;
rem -= SECSPERYEAR + SECSPERDAY;
} else {
isLeap = 1;
}
}
}
tmPtr->tm_year = tmp;
/*
* Compute the day of year and leave the seconds in the current day in the
* remainder.
*/
tmPtr->tm_yday = rem / SECSPERDAY;
rem %= SECSPERDAY;
/*
* Compute the time of day.
*/
tmPtr->tm_hour = rem / 3600;
rem %= 3600;
tmPtr->tm_min = rem / 60;
tmPtr->tm_sec = rem % 60;
/*
* Compute the month and day of month.
*/
days = (isLeap) ? leapDays : normalDays;
for (tmp = 1; days[tmp] < tmPtr->tm_yday; tmp++) {
/* empty body */
}
tmPtr->tm_mon = --tmp;
tmPtr->tm_mday = tmPtr->tm_yday - days[tmp];
/*
* Compute day of week. Epoch started on a Thursday.
*/
tmPtr->tm_wday = (long)(*tp / SECSPERDAY) + 4;
if ((*tp % SECSPERDAY) < 0) {
tmPtr->tm_wday--;
}
tmPtr->tm_wday %= 7;
if (tmPtr->tm_wday < 0) {
tmPtr->tm_wday += 7;
}
return tmPtr;
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* CalibrationThread --
*
* Thread that manages calibration of the hi-resolution time derived from
* the performance counter, to keep it synchronized with the system
|
| ︙ | ︙ | |||
704 705 706 707 708 709 710 | * body of this procedure. * *---------------------------------------------------------------------- */ static DWORD WINAPI CalibrationThread( | | | 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 |
* body of this procedure.
*
*----------------------------------------------------------------------
*/
static DWORD WINAPI
CalibrationThread(
TCL_UNUSED(LPVOID))
{
FILETIME curFileTime;
DWORD waitResult;
/*
* Get initial system time and performance counter.
*/
|
| ︙ | ︙ | |||
748 749 750 751 752 753 754 |
waitResult = WaitForSingleObjectEx(timeInfo.exitEvent, 1000, FALSE);
if (waitResult == WAIT_OBJECT_0) {
break;
}
UpdateTimeEachSecond();
}
| < | 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 |
waitResult = WaitForSingleObjectEx(timeInfo.exitEvent, 1000, FALSE);
if (waitResult == WAIT_OBJECT_0) {
break;
}
UpdateTimeEachSecond();
}
return (DWORD) 0;
}
/*
*----------------------------------------------------------------------
*
* UpdateTimeEachSecond --
|
| ︙ | ︙ | |||
1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 |
timeInfo.sampleNo = 0;
}
return estFreq;
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetTimeProc --
*
* TIP #233 (Virtualized Time): Registers two handlers for the
* virtualization of Tcl's access to time information.
| > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 |
timeInfo.sampleNo = 0;
}
return estFreq;
}
}
/*
*----------------------------------------------------------------------
*
* TclpGmtime --
*
* Wrapper around the 'gmtime' library function to make it thread safe.
*
* Results:
* Returns a pointer to a 'struct tm' in thread-specific data.
*
* Side effects:
* Invokes gmtime or gmtime_r as appropriate.
*
*----------------------------------------------------------------------
*/
#ifndef TCL_NO_DEPRECATED
struct tm *
TclpGmtime(
const time_t *timePtr) /* Pointer to the number of seconds since the
* local system's epoch */
{
/*
* The MS implementation of gmtime is thread safe because it returns the
* time in a block of thread-local storage, and Windows does not provide a
* Posix gmtime_r function.
*/
#if defined(_WIN64) || defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400)
return gmtime(timePtr);
#else
return _gmtime32((const __time32_t *)timePtr);
#endif
}
/*
*----------------------------------------------------------------------
*
* TclpLocaltime --
*
* Wrapper around the 'localtime' library function to make it thread
* safe.
*
* Results:
* Returns a pointer to a 'struct tm' in thread-specific data.
*
* Side effects:
* Invokes localtime or localtime_r as appropriate.
*
*----------------------------------------------------------------------
*/
struct tm *
TclpLocaltime(
const time_t *timePtr) /* Pointer to the number of seconds since the
* local system's epoch */
{
/*
* The MS implementation of localtime is thread safe because it returns
* the time in a block of thread-local storage, and Windows does not
* provide a Posix localtime_r function.
*/
#if defined(_WIN64) || defined(_USE_64BIT_TIME_T) || (defined(_MSC_VER) && _MSC_VER < 1400)
return localtime(timePtr);
#else
return _localtime32((const __time32_t *)timePtr);
#endif
}
#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
* Tcl_SetTimeProc --
*
* TIP #233 (Virtualized Time): Registers two handlers for the
* virtualization of Tcl's access to time information.
|
| ︙ | ︙ |